{-# LANGUAGE LambdaCase #-}

{- |
Module      : Singular.Provider.Koios.Recorded
Description : A Koios transport answering from recorded fixtures
License     : Apache-2.0

A 'Transport' that answers each request from a fixture directory
recorded from a live Koios service by the @koios-http@ recorder. The
answers are raw — status, headers and body — so the client pages and
decodes them exactly as it does live answers.

Each fixture is one JSON file holding the request, the Koios schema
revision, the time of recording, the SHA-256 of the answer body and the
answer. Loading a directory refuses a fixture whose body does not match
its hash, a set whose fixtures disagree on the schema revision, two
fixtures for one request, and an empty directory. A request with no
fixture is answered by 'NoRecording', which the client reports as
'Singular.Provider.Koios.Client.NotRecorded'.
-}
module Singular.Provider.Koios.Recorded
    ( -- * Fixtures
      Fixture (..)
    , FixtureRequest (..)
    , fixtureRequestOf
    , fixtureFileName
    , encodeFixture
    , decodeFixture
    , bodySha256

      -- * Fixture sets
    , FixtureSet (..)
    , FixtureFailure (..)
    , loadFixtureSet

      -- * Transport
    , recordedTransport
    ) where

import Control.Exception (IOException, try)
import Crypto.Hash (Digest, SHA256, hash)
import Data.Aeson
    ( Value (..)
    , eitherDecode
    , object
    , withObject
    , (.:)
    , (.=)
    )
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson.KeyMap qualified as KM
import Data.Aeson.Types (Parser, parseEither)
import Data.ByteArray.Encoding (Base (Base16), convertToBase)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as Base16
import Data.ByteString.Lazy qualified as BSL
import Data.List (find, isSuffixOf, nub, sort)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Time (UTCTime)
import System.Directory (listDirectory)
import System.FilePath ((</>))

import Singular.Provider.Koios.Client
    ( Answer (..)
    , Exchange (..)
    , NoAnswer (..)
    , RawRequest (..)
    , Transport (..)
    )
import Singular.Provider.Koios.Wire
    ( Body (..)
    , Call
    , Method (..)
    , callName
    )

{- | The part of a request a fixture is keyed by: call, method, path,
query in sorted order, and body. Headers, such as a bearer token, are
never part of it.
-}
data FixtureRequest = FixtureRequest
    { FixtureRequest -> Call
fixtureCall :: Call
    , FixtureRequest -> Method
fixtureMethod :: Method
    , FixtureRequest -> Text
fixturePath :: Text
    , FixtureRequest -> [(Text, Text)]
fixtureQuery :: [(Text, Text)]
    , FixtureRequest -> Body
fixtureBody :: Body
    }
    deriving stock (FixtureRequest -> FixtureRequest -> Bool
(FixtureRequest -> FixtureRequest -> Bool)
-> (FixtureRequest -> FixtureRequest -> Bool) -> Eq FixtureRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FixtureRequest -> FixtureRequest -> Bool
== :: FixtureRequest -> FixtureRequest -> Bool
$c/= :: FixtureRequest -> FixtureRequest -> Bool
/= :: FixtureRequest -> FixtureRequest -> Bool
Eq, Int -> FixtureRequest -> ShowS
[FixtureRequest] -> ShowS
FixtureRequest -> String
(Int -> FixtureRequest -> ShowS)
-> (FixtureRequest -> String)
-> ([FixtureRequest] -> ShowS)
-> Show FixtureRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FixtureRequest -> ShowS
showsPrec :: Int -> FixtureRequest -> ShowS
$cshow :: FixtureRequest -> String
show :: FixtureRequest -> String
$cshowList :: [FixtureRequest] -> ShowS
showList :: [FixtureRequest] -> ShowS
Show)

-- | The fixture key of a raw request.
fixtureRequestOf :: RawRequest -> FixtureRequest
fixtureRequestOf :: RawRequest -> FixtureRequest
fixtureRequestOf RawRequest
raw =
    FixtureRequest
        { fixtureCall :: Call
fixtureCall = RawRequest -> Call
rawCall RawRequest
raw
        , fixtureMethod :: Method
fixtureMethod = RawRequest -> Method
rawMethod RawRequest
raw
        , fixturePath :: Text
fixturePath = RawRequest -> Text
rawPath RawRequest
raw
        , fixtureQuery :: [(Text, Text)]
fixtureQuery = [(Text, Text)] -> [(Text, Text)]
forall a. Ord a => [a] -> [a]
sort (RawRequest -> [(Text, Text)]
rawQuery RawRequest
raw)
        , fixtureBody :: Body
fixtureBody = RawRequest -> Body
rawBody RawRequest
raw
        }

-- | One recorded answer.
data Fixture = Fixture
    { Fixture -> FixtureRequest
fixtureRequest :: FixtureRequest
    , Fixture -> Text
fixtureRevision :: Text
    -- ^ The Koios schema revision the answer was recorded under
    , Fixture -> UTCTime
fixtureRecordedAt :: UTCTime
    , Fixture -> Text
fixtureSha256 :: Text
    -- ^ Hex SHA-256 of the answer body
    , Fixture -> Answer
fixtureAnswer :: Answer
    }
    deriving stock (Fixture -> Fixture -> Bool
(Fixture -> Fixture -> Bool)
-> (Fixture -> Fixture -> Bool) -> Eq Fixture
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Fixture -> Fixture -> Bool
== :: Fixture -> Fixture -> Bool
$c/= :: Fixture -> Fixture -> Bool
/= :: Fixture -> Fixture -> Bool
Eq, Int -> Fixture -> ShowS
[Fixture] -> ShowS
Fixture -> String
(Int -> Fixture -> ShowS)
-> (Fixture -> String) -> ([Fixture] -> ShowS) -> Show Fixture
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Fixture -> ShowS
showsPrec :: Int -> Fixture -> ShowS
$cshow :: Fixture -> String
show :: Fixture -> String
$cshowList :: [Fixture] -> ShowS
showList :: [Fixture] -> ShowS
Show)

-- | A file name derived from the request alone.
fixtureFileName :: FixtureRequest -> FilePath
fixtureFileName :: FixtureRequest -> String
fixtureFileName FixtureRequest
r =
    Text -> String
T.unpack (Call -> Text
callName (FixtureRequest -> Call
fixtureCall FixtureRequest
r))
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> ShowS
forall a. Int -> [a] -> [a]
take
            Int
16
            (Text -> String
T.unpack (ByteString -> Text
bodySha256 (LazyByteString -> ByteString
BSL.toStrict (Value -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
encodePretty (FixtureRequest -> Value
requestJson FixtureRequest
r)))))
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".json"

-- | The JSON text of a fixture.
encodeFixture :: Fixture -> BSL.ByteString
encodeFixture :: Fixture -> LazyByteString
encodeFixture Fixture
f =
    Value -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
encodePretty (Value -> LazyByteString) -> Value -> LazyByteString
forall a b. (a -> b) -> a -> b
$
        [Pair] -> Value
object
            [ Key
"request" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= FixtureRequest -> Value
requestJson (Fixture -> FixtureRequest
fixtureRequest Fixture
f)
            , Key
"schema_revision" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Fixture -> Text
fixtureRevision Fixture
f
            , Key
"recorded_at" Key -> UTCTime -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Fixture -> UTCTime
fixtureRecordedAt Fixture
f
            , Key
"sha256" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Fixture -> Text
fixtureSha256 Fixture
f
            , Key
"answer"
                Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                    [ Key
"status" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Answer -> Int
answerStatus Answer
a
                    , Key
"headers" Key -> [(Text, Text)] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Answer -> [(Text, Text)]
answerHeaders Answer
a
                    , Key
"body" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
TE.decodeUtf8Lenient (Answer -> ByteString
answerBody Answer
a)
                    ]
            ]
  where
    a :: Answer
a = Fixture -> Answer
fixtureAnswer Fixture
f

requestJson :: FixtureRequest -> Value
requestJson :: FixtureRequest -> Value
requestJson FixtureRequest
r =
    [Pair] -> Value
object
        [ Key
"call" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Call -> Text
callName (FixtureRequest -> Call
fixtureCall FixtureRequest
r)
        , Key
"method" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Method -> Text
methodName (FixtureRequest -> Method
fixtureMethod FixtureRequest
r)
        , Key
"path" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= FixtureRequest -> Text
fixturePath FixtureRequest
r
        , Key
"query" Key -> [(Text, Text)] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= FixtureRequest -> [(Text, Text)]
fixtureQuery FixtureRequest
r
        , Key
"body" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= case FixtureRequest -> Body
fixtureBody FixtureRequest
r of
            Body
NoBody -> Value
Null
            JsonBody Value
v -> [Pair] -> Value
object [Key
"json" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
v]
            CborBody ByteString
b -> [Pair] -> Value
object [Key
"cbor" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
TE.decodeUtf8 (ByteString -> ByteString
Base16.encode ByteString
b)]
        ]

methodName :: Method -> Text
methodName :: Method -> Text
methodName = \case
    Method
Get -> Text
"GET"
    Method
Post -> Text
"POST"

-- | Read a fixture's JSON text.
decodeFixture :: BSL.ByteString -> Either Text Fixture
decodeFixture :: LazyByteString -> Either Text Fixture
decodeFixture LazyByteString
bytes = do
    v <- (String -> Either Text Value)
-> (Value -> Either Text Value)
-> Either String Value
-> Either Text Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Either Text Value
forall a b. a -> Either a b
Left (Text -> Either Text Value)
-> (String -> Text) -> String -> Either Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) Value -> Either Text Value
forall a b. b -> Either a b
Right (LazyByteString -> Either String Value
forall a. FromJSON a => LazyByteString -> Either String a
eitherDecode LazyByteString
bytes)
    either (Left . T.pack) Right (parseEither fixture v)
  where
    fixture :: Value -> Parser Fixture
fixture = String -> (Object -> Parser Fixture) -> Value -> Parser Fixture
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"fixture" ((Object -> Parser Fixture) -> Value -> Parser Fixture)
-> (Object -> Parser Fixture) -> Value -> Parser Fixture
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        req <- Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"request" Parser Value
-> (Value -> Parser FixtureRequest) -> Parser FixtureRequest
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser FixtureRequest
requestOf
        answer <- o .: "answer"
        Fixture req
            <$> o .: "schema_revision"
            <*> o .: "recorded_at"
            <*> o .: "sha256"
            <*> answerOf answer
    answerOf :: Value -> Parser Answer
answerOf = String -> (Object -> Parser Answer) -> Value -> Parser Answer
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"answer" ((Object -> Parser Answer) -> Value -> Parser Answer)
-> (Object -> Parser Answer) -> Value -> Parser Answer
forall a b. (a -> b) -> a -> b
$ \Object
a ->
        Int -> [(Text, Text)] -> ByteString -> Answer
Answer
            (Int -> [(Text, Text)] -> ByteString -> Answer)
-> Parser Int -> Parser ([(Text, Text)] -> ByteString -> Answer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
a Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"status"
            Parser ([(Text, Text)] -> ByteString -> Answer)
-> Parser [(Text, Text)] -> Parser (ByteString -> Answer)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
a Object -> Key -> Parser [(Text, Text)]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"headers"
            Parser (ByteString -> Answer) -> Parser ByteString -> Parser Answer
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Parser Text -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
a Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"body")
    requestOf :: Value -> Parser FixtureRequest
    requestOf :: Value -> Parser FixtureRequest
requestOf = String
-> (Object -> Parser FixtureRequest)
-> Value
-> Parser FixtureRequest
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"request" ((Object -> Parser FixtureRequest)
 -> Value -> Parser FixtureRequest)
-> (Object -> Parser FixtureRequest)
-> Value
-> Parser FixtureRequest
forall a b. (a -> b) -> a -> b
$ \Object
r -> do
        name <- Object
r Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"call"
        call <- case [c | c <- [minBound .. maxBound], callName c == name] of
            Call
c : [Call]
_ -> Call -> Parser Call
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Call
c
            [] -> String -> Parser Call
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unknown call: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name)
        method <-
            r .: "method" >>= \case
                Text
"GET" -> Method -> Parser Method
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Method
Get
                Text
"POST" -> Method -> Parser Method
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Method
Post
                Text
other -> String -> Parser Method
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unknown method: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Text
other :: Text))
        body <-
            r .: "body" >>= \case
                Value
Null -> Body -> Parser Body
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Body
NoBody
                Object Object
b
                    | Just Value
j <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"json" Object
b -> Body -> Parser Body
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Body
JsonBody Value
j)
                    | Just (String Text
c) <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"cbor" Object
b ->
                        (String -> Parser Body)
-> (ByteString -> Parser Body)
-> Either String ByteString
-> Parser Body
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser Body
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Body -> Parser Body
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Body -> Parser Body)
-> (ByteString -> Body) -> ByteString -> Parser Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Body
CborBody) (ByteString -> Either String ByteString
Base16.decode (Text -> ByteString
TE.encodeUtf8 Text
c))
                Value
_ -> String -> Parser Body
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unknown body"
        FixtureRequest call method
            <$> r .: "path"
            <*> (sort <$> r .: "query")
            <*> pure body

-- | Hex SHA-256 of an answer body.
bodySha256 :: ByteString -> Text
bodySha256 :: ByteString -> Text
bodySha256 ByteString
body =
    ByteString -> Text
TE.decodeUtf8 (Base -> Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base16 (ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash ByteString
body :: Digest SHA256))

-- | A loaded fixture directory, all under one schema revision.
data FixtureSet = FixtureSet
    { FixtureSet -> Text
setRevision :: Text
    , FixtureSet -> [Fixture]
setFixtures :: [Fixture]
    }
    deriving stock (FixtureSet -> FixtureSet -> Bool
(FixtureSet -> FixtureSet -> Bool)
-> (FixtureSet -> FixtureSet -> Bool) -> Eq FixtureSet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FixtureSet -> FixtureSet -> Bool
== :: FixtureSet -> FixtureSet -> Bool
$c/= :: FixtureSet -> FixtureSet -> Bool
/= :: FixtureSet -> FixtureSet -> Bool
Eq, Int -> FixtureSet -> ShowS
[FixtureSet] -> ShowS
FixtureSet -> String
(Int -> FixtureSet -> ShowS)
-> (FixtureSet -> String)
-> ([FixtureSet] -> ShowS)
-> Show FixtureSet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FixtureSet -> ShowS
showsPrec :: Int -> FixtureSet -> ShowS
$cshow :: FixtureSet -> String
show :: FixtureSet -> String
$cshowList :: [FixtureSet] -> ShowS
showList :: [FixtureSet] -> ShowS
Show)

-- | Why a fixture directory cannot be used.
data FixtureFailure
    = -- | A file that is not a fixture, or a directory that cannot be read
      FixtureUnreadable FilePath Text
    | -- | A fixture whose body does not hash to its recorded SHA-256
      FixtureHashMismatch FilePath
    | -- | Fixtures recorded under different schema revisions
      RevisionMismatch [(FilePath, Text)]
    | -- | Two fixtures for one request
      DuplicateRequest FilePath FilePath
    | -- | A directory with no fixture
      NoFixtures FilePath
    deriving stock (FixtureFailure -> FixtureFailure -> Bool
(FixtureFailure -> FixtureFailure -> Bool)
-> (FixtureFailure -> FixtureFailure -> Bool) -> Eq FixtureFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FixtureFailure -> FixtureFailure -> Bool
== :: FixtureFailure -> FixtureFailure -> Bool
$c/= :: FixtureFailure -> FixtureFailure -> Bool
/= :: FixtureFailure -> FixtureFailure -> Bool
Eq, Int -> FixtureFailure -> ShowS
[FixtureFailure] -> ShowS
FixtureFailure -> String
(Int -> FixtureFailure -> ShowS)
-> (FixtureFailure -> String)
-> ([FixtureFailure] -> ShowS)
-> Show FixtureFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FixtureFailure -> ShowS
showsPrec :: Int -> FixtureFailure -> ShowS
$cshow :: FixtureFailure -> String
show :: FixtureFailure -> String
$cshowList :: [FixtureFailure] -> ShowS
showList :: [FixtureFailure] -> ShowS
Show)

-- | Load every @.json@ fixture of a directory.
loadFixtureSet :: FilePath -> IO (Either FixtureFailure FixtureSet)
loadFixtureSet :: String -> IO (Either FixtureFailure FixtureSet)
loadFixtureSet String
dir =
    IO [String] -> IO (Either IOException [String])
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO [String]
listDirectory String
dir) IO (Either IOException [String])
-> (Either IOException [String]
    -> IO (Either FixtureFailure FixtureSet))
-> IO (Either FixtureFailure FixtureSet)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left IOException
e ->
            Either FixtureFailure FixtureSet
-> IO (Either FixtureFailure FixtureSet)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FixtureFailure -> Either FixtureFailure FixtureSet
forall a b. a -> Either a b
Left (String -> Text -> FixtureFailure
FixtureUnreadable String
dir (String -> Text
T.pack (IOException -> String
forall a. Show a => a -> String
show (IOException
e :: IOException)))))
        Right [String]
entries -> do
            let names :: [String]
names = [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
".json" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) [String]
entries)
            loaded <- (String -> IO (Either FixtureFailure (String, Fixture)))
-> [String] -> IO [Either FixtureFailure (String, Fixture)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String -> IO (Either FixtureFailure (String, Fixture))
load [String]
names
            pure (sequence loaded >>= assemble)
  where
    load :: String -> IO (Either FixtureFailure (String, Fixture))
load String
name = do
        let path :: String
path = String
dir String -> ShowS
</> String
name
        -- read strictly inside the catch, so a failure after opening is caught
        read' <- IO LazyByteString -> IO (Either IOException LazyByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (ByteString -> LazyByteString
BSL.fromStrict (ByteString -> LazyByteString)
-> IO ByteString -> IO LazyByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
path)
        pure $ case read' of
            Left IOException
e -> FixtureFailure -> Either FixtureFailure (String, Fixture)
forall a b. a -> Either a b
Left (String -> Text -> FixtureFailure
FixtureUnreadable String
path (String -> Text
T.pack (IOException -> String
forall a. Show a => a -> String
show (IOException
e :: IOException))))
            Right LazyByteString
bytes -> String -> LazyByteString -> Either FixtureFailure (String, Fixture)
fixtureAt String
path LazyByteString
bytes
    fixtureAt :: String -> LazyByteString -> Either FixtureFailure (String, Fixture)
fixtureAt String
path LazyByteString
bytes =
        case LazyByteString -> Either Text Fixture
decodeFixture LazyByteString
bytes of
            Left Text
e -> FixtureFailure -> Either FixtureFailure (String, Fixture)
forall a b. a -> Either a b
Left (String -> Text -> FixtureFailure
FixtureUnreadable String
path Text
e)
            Right Fixture
f
                | ByteString -> Text
bodySha256 (Answer -> ByteString
answerBody (Fixture -> Answer
fixtureAnswer Fixture
f)) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Fixture -> Text
fixtureSha256 Fixture
f ->
                    FixtureFailure -> Either FixtureFailure (String, Fixture)
forall a b. a -> Either a b
Left (String -> FixtureFailure
FixtureHashMismatch String
path)
                | Bool
otherwise -> (String, Fixture) -> Either FixtureFailure (String, Fixture)
forall a b. b -> Either a b
Right (String
path, Fixture
f)
    assemble :: [(String, Fixture)] -> Either FixtureFailure FixtureSet
assemble = \case
        [] -> FixtureFailure -> Either FixtureFailure FixtureSet
forall a b. a -> Either a b
Left (String -> FixtureFailure
NoFixtures String
dir)
        loaded :: [(String, Fixture)]
loaded@((String
_, Fixture
first') : [(String, Fixture)]
_)
            | [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub (((String, Fixture) -> Text) -> [(String, Fixture)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Fixture -> Text
fixtureRevision (Fixture -> Text)
-> ((String, Fixture) -> Fixture) -> (String, Fixture) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Fixture) -> Fixture
forall a b. (a, b) -> b
snd) [(String, Fixture)]
loaded)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 ->
                FixtureFailure -> Either FixtureFailure FixtureSet
forall a b. a -> Either a b
Left ([(String, Text)] -> FixtureFailure
RevisionMismatch [(String
p, Fixture -> Text
fixtureRevision Fixture
f) | (String
p, Fixture
f) <- [(String, Fixture)]
loaded])
            | Just (String
a, String
b) <- [(String, Fixture)] -> Maybe (String, String)
forall {b}. [(b, Fixture)] -> Maybe (b, b)
duplicate [(String, Fixture)]
loaded -> FixtureFailure -> Either FixtureFailure FixtureSet
forall a b. a -> Either a b
Left (String -> String -> FixtureFailure
DuplicateRequest String
a String
b)
            | Bool
otherwise ->
                FixtureSet -> Either FixtureFailure FixtureSet
forall a b. b -> Either a b
Right
                    FixtureSet
                        { setRevision :: Text
setRevision = Fixture -> Text
fixtureRevision Fixture
first'
                        , setFixtures :: [Fixture]
setFixtures = ((String, Fixture) -> Fixture) -> [(String, Fixture)] -> [Fixture]
forall a b. (a -> b) -> [a] -> [b]
map (String, Fixture) -> Fixture
forall a b. (a, b) -> b
snd [(String, Fixture)]
loaded
                        }
    duplicate :: [(b, Fixture)] -> Maybe (b, b)
duplicate [(b, Fixture)]
loaded =
        case [ (b
p, b
q)
             | ((b
p, Fixture
f), Int
i) <- [(b, Fixture)] -> [Int] -> [((b, Fixture), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(b, Fixture)]
loaded [Int
0 :: Int ..]
             , ((b
q, Fixture
g), Int
j) <- [(b, Fixture)] -> [Int] -> [((b, Fixture), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(b, Fixture)]
loaded [Int
0 ..]
             , Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
j
             , Fixture -> FixtureRequest
fixtureRequest Fixture
f FixtureRequest -> FixtureRequest -> Bool
forall a. Eq a => a -> a -> Bool
== Fixture -> FixtureRequest
fixtureRequest Fixture
g
             ] of
            (b, b)
d : [(b, b)]
_ -> (b, b) -> Maybe (b, b)
forall a. a -> Maybe a
Just (b, b)
d
            [] -> Maybe (b, b)
forall a. Maybe a
Nothing

-- | Answer each request from the set; one attempt per request.
recordedTransport :: (Applicative m) => FixtureSet -> Transport m
recordedTransport :: forall (m :: * -> *). Applicative m => FixtureSet -> Transport m
recordedTransport FixtureSet
set = (RawRequest -> m Exchange) -> Transport m
forall (m :: * -> *). (RawRequest -> m Exchange) -> Transport m
Transport ((RawRequest -> m Exchange) -> Transport m)
-> (RawRequest -> m Exchange) -> Transport m
forall a b. (a -> b) -> a -> b
$ \RawRequest
raw ->
    let key :: FixtureRequest
key = RawRequest -> FixtureRequest
fixtureRequestOf RawRequest
raw
    in  Exchange -> m Exchange
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            Exchange
                { exchangeAttempts :: Int
exchangeAttempts = Int
1
                , exchangeResult :: Either NoAnswer Answer
exchangeResult =
                    case (Fixture -> Bool) -> [Fixture] -> Maybe Fixture
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((FixtureRequest -> FixtureRequest -> Bool
forall a. Eq a => a -> a -> Bool
== FixtureRequest
key) (FixtureRequest -> Bool)
-> (Fixture -> FixtureRequest) -> Fixture -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fixture -> FixtureRequest
fixtureRequest) (FixtureSet -> [Fixture]
setFixtures FixtureSet
set) of
                        Just Fixture
f -> Answer -> Either NoAnswer Answer
forall a b. b -> Either a b
Right (Fixture -> Answer
fixtureAnswer Fixture
f)
                        Maybe Fixture
Nothing -> NoAnswer -> Either NoAnswer Answer
forall a b. a -> Either a b
Left (Text -> NoAnswer
NoRecording (FixtureRequest -> Text
describe FixtureRequest
key))
                }
  where
    describe :: FixtureRequest -> Text
describe FixtureRequest
r =
        Method -> Text
methodName (FixtureRequest -> Method
fixtureMethod FixtureRequest
r)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FixtureRequest -> Text
fixturePath FixtureRequest
r
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([(Text, Text)] -> String
forall a. Show a => a -> String
show (FixtureRequest -> [(Text, Text)]
fixtureQuery FixtureRequest
r))