{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module VCR.Serialize (
  saveTape
, loadTape
) where

import Imports

import Control.Exception
import Data.Either
import Data.Text (Text)
import Data.Ord
import Data.ByteString.Char8 qualified as B
import Data.ByteString.Lazy.Char8 qualified as L
import Data.CaseInsensitive qualified as CI
import Data.Yaml
import Data.Yaml qualified as Yaml
import Data.Yaml.Pretty qualified as Yaml
import System.IO.Error
import System.Directory
import System.FilePath

import WebMock hiding (withRequestAction)

saveTape :: FilePath -> [(Request, Response)] -> IO ()
saveTape :: FilePath -> [(Request, Response)] -> IO ()
saveTape FilePath
file [(Request, Response)]
interactions = do
  FilePath -> IO ()
ensureDirectory FilePath
file
  FilePath -> ByteString -> IO ()
B.writeFile FilePath
file (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> [Interaction] -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
Yaml.encodePretty Config
conf ([(Request, Response)] -> [Interaction]
toInteractions [(Request, Response)]
interactions)
  where
    conf :: Config
conf = (Text -> Text -> Ordering) -> Config -> Config
Yaml.setConfCompare ((Text -> Int) -> Text -> Text -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Text -> Int
f) Config
Yaml.defConfig

    f :: Text -> Int
    f :: Text -> Int
f Text
name = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
forall a. Bounded a => a
maxBound (Text -> [(Text, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name [(Text, Int)]
fieldOrder)

    toInteractions :: [(Request, Response)] -> [Interaction]
    toInteractions :: [(Request, Response)] -> [Interaction]
toInteractions = ((Request, Response) -> Interaction)
-> [(Request, Response)] -> [Interaction]
forall a b. (a -> b) -> [a] -> [b]
map \ (Request
request, Response
response) -> (Request -> Response -> Interaction
Interaction Request
request Response
response)

fieldOrder :: [(Text, Int)]
fieldOrder :: [(Text, Int)]
fieldOrder = ([Text] -> [Int] -> [(Text, Int)])
-> [Int] -> [Text] -> [(Text, Int)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Text] -> [Int] -> [(Text, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [
    Text
"request"
  , Text
"response"

  , Text
"method"
  , Text
"url"

  , Text
"status"
  , Text
"headers"
  , Text
"body"

  , Text
"code"
  , Text
"message"

  , Text
"name"
  , Text
"value"
  ]

ensureDirectory :: FilePath -> IO ()
ensureDirectory :: FilePath -> IO ()
ensureDirectory = Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeDirectory

loadTape :: FilePath -> IO [(Request, Response)]
loadTape :: FilePath -> IO [(Request, Response)]
loadTape FilePath
file = [(Request, Response)]
-> Either () [(Request, Response)] -> [(Request, Response)]
forall b a. b -> Either a b -> b
fromRight [] (Either () [(Request, Response)] -> [(Request, Response)])
-> IO (Either () [(Request, Response)]) -> IO [(Request, Response)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IOError -> Maybe ())
-> IO [(Request, Response)] -> IO (Either () [(Request, Response)])
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (FilePath -> IO [(Request, Response)]
unsafeLoadTape FilePath
file)

unsafeLoadTape :: FilePath -> IO [(Request, Response)]
unsafeLoadTape :: FilePath -> IO [(Request, Response)]
unsafeLoadTape FilePath
file = FilePath -> IO ByteString
B.readFile FilePath
file IO ByteString
-> (ByteString -> IO [(Request, Response)])
-> IO [(Request, Response)]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Interaction] -> [(Request, Response)])
-> IO [Interaction] -> IO [(Request, Response)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Interaction] -> [(Request, Response)]
fromInteractions (IO [Interaction] -> IO [(Request, Response)])
-> (ByteString -> IO [Interaction])
-> ByteString
-> IO [(Request, Response)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO [Interaction]
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Yaml.decodeThrow
  where
    fromInteractions :: [Interaction] -> [(Request, Response)]
    fromInteractions :: [Interaction] -> [(Request, Response)]
fromInteractions = (Interaction -> (Request, Response))
-> [Interaction] -> [(Request, Response)]
forall a b. (a -> b) -> [a] -> [b]
map \ (Interaction Request
request Response
response) -> (Request
request, Response
response)

data Interaction = Interaction Request Response

instance ToJSON Interaction where
  toJSON :: Interaction -> Value
toJSON (Interaction Request
request Response
response) = [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
.= Request -> Value
requestToJSON Request
request
      , Key
"response" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Response -> Value
responseToJSON Response
response
      ]
    where
      requestToJSON :: Request -> Value
      requestToJSON :: Request -> Value
requestToJSON Request{FilePath
RequestHeaders
LazyByteString
ByteString
requestMethod :: ByteString
requestUrl :: FilePath
requestHeaders :: RequestHeaders
requestBody :: LazyByteString
requestMethod :: Request -> ByteString
requestUrl :: Request -> FilePath
requestHeaders :: Request -> RequestHeaders
requestBody :: Request -> LazyByteString
..} = [Pair] -> Value
object [
          Key
"method" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> FilePath
B.unpack ByteString
requestMethod
        , Key
"url" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= FilePath
requestUrl
        , Key
"headers" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RequestHeaders -> Value
headersToJSON RequestHeaders
requestHeaders
        , Key
"body" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= LazyByteString -> FilePath
L.unpack LazyByteString
requestBody
        ]

      responseToJSON :: Response -> Value
      responseToJSON :: Response -> Value
responseToJSON Response{RequestHeaders
LazyByteString
Status
responseStatus :: Status
responseHeaders :: RequestHeaders
responseBody :: LazyByteString
responseStatus :: Response -> Status
responseHeaders :: Response -> RequestHeaders
responseBody :: Response -> LazyByteString
..} = [Pair] -> Value
object [
          Key
"status" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Status -> Value
statusToJSON Status
responseStatus
        , Key
"headers" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RequestHeaders -> Value
headersToJSON RequestHeaders
responseHeaders
        , Key
"body" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= LazyByteString -> FilePath
L.unpack LazyByteString
responseBody
        ]
        where
          statusToJSON :: Status -> Value
          statusToJSON :: Status -> Value
statusToJSON (Status Int
code ByteString
message) = [Pair] -> Value
object [
              Key
"code" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
code
            , Key
"message" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> FilePath
B.unpack ByteString
message
            ]

      headersToJSON :: RequestHeaders -> Value
      headersToJSON :: RequestHeaders -> Value
headersToJSON = [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Value] -> Value)
-> (RequestHeaders -> [Value]) -> RequestHeaders -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> Value) -> RequestHeaders -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Header -> Value
headerToJSON
        where
          headerToJSON :: Header -> Value
          headerToJSON :: Header -> Value
headerToJSON (HeaderName
name, ByteString
value) = [Pair] -> Value
object [
              Key
"name" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> FilePath
B.unpack (HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
name)
            , Key
"value" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> FilePath
B.unpack ByteString
value
            ]

instance FromJSON Interaction where
  parseJSON :: Value -> Parser Interaction
parseJSON = FilePath
-> (Object -> Parser Interaction) -> Value -> Parser Interaction
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"Interaction" \ Object
o -> Request -> Response -> Interaction
Interaction
    (Request -> Response -> Interaction)
-> Parser Request -> Parser (Response -> Interaction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"request" Parser Value -> (Value -> Parser Request) -> Parser Request
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 Request
requestFromJSON)
    Parser (Response -> Interaction)
-> Parser Response -> Parser Interaction
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"response" Parser Value -> (Value -> Parser Response) -> Parser Response
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 Response
responseFromJSON)
    where
      requestFromJSON :: Value -> Parser Request
      requestFromJSON :: Value -> Parser Request
requestFromJSON = FilePath -> (Object -> Parser Request) -> Value -> Parser Request
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"Request" \ Object
o ->
        ByteString
-> FilePath -> RequestHeaders -> LazyByteString -> Request
Request
        (ByteString
 -> FilePath -> RequestHeaders -> LazyByteString -> Request)
-> Parser ByteString
-> Parser (FilePath -> RequestHeaders -> LazyByteString -> Request)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> ByteString
B.pack (FilePath -> ByteString) -> Parser FilePath -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser FilePath
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"method")
        Parser (FilePath -> RequestHeaders -> LazyByteString -> Request)
-> Parser FilePath
-> Parser (RequestHeaders -> LazyByteString -> Request)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser FilePath
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"url"
        Parser (RequestHeaders -> LazyByteString -> Request)
-> Parser RequestHeaders -> Parser (LazyByteString -> Request)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o Object -> Key -> Parser [Object]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"headers" Parser [Object]
-> ([Object] -> Parser RequestHeaders) -> Parser RequestHeaders
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Object] -> Parser RequestHeaders
headersFromJSON)
        Parser (LazyByteString -> Request)
-> Parser LazyByteString -> Parser Request
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> LazyByteString
L.pack (FilePath -> LazyByteString)
-> Parser FilePath -> Parser LazyByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser FilePath
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"body")

      responseFromJSON :: Value -> Parser Response
      responseFromJSON :: Value -> Parser Response
responseFromJSON = FilePath -> (Object -> Parser Response) -> Value -> Parser Response
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"Response" \ Object
o -> Status -> RequestHeaders -> LazyByteString -> Response
Response
        (Status -> RequestHeaders -> LazyByteString -> Response)
-> Parser Status
-> Parser (RequestHeaders -> LazyByteString -> Response)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"status" Parser Object -> (Object -> Parser Status) -> Parser Status
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Parser Status
statusFromJSON)
        Parser (RequestHeaders -> LazyByteString -> Response)
-> Parser RequestHeaders -> Parser (LazyByteString -> Response)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o Object -> Key -> Parser [Object]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"headers" Parser [Object]
-> ([Object] -> Parser RequestHeaders) -> Parser RequestHeaders
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Object] -> Parser RequestHeaders
headersFromJSON)
        Parser (LazyByteString -> Response)
-> Parser LazyByteString -> Parser Response
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> LazyByteString
L.pack (FilePath -> LazyByteString)
-> Parser FilePath -> Parser LazyByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser FilePath
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"body")
        where
          statusFromJSON :: Object -> Parser Status
          statusFromJSON :: Object -> Parser Status
statusFromJSON Object
o = Int -> ByteString -> Status
Status
            (Int -> ByteString -> Status)
-> Parser Int -> Parser (ByteString -> Status)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"code")
            Parser (ByteString -> Status) -> Parser ByteString -> Parser Status
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> ByteString
B.pack (FilePath -> ByteString) -> Parser FilePath -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser FilePath
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"message")

      headersFromJSON :: [Object] -> Parser RequestHeaders
      headersFromJSON :: [Object] -> Parser RequestHeaders
headersFromJSON = (Object -> Parser Header) -> [Object] -> Parser RequestHeaders
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Object -> Parser Header
headerFromJSON
        where
          headerFromJSON :: Object -> Parser Header
          headerFromJSON :: Object -> Parser Header
headerFromJSON Object
o = (,)
            (HeaderName -> ByteString -> Header)
-> Parser HeaderName -> Parser (ByteString -> Header)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> HeaderName)
-> (FilePath -> ByteString) -> FilePath -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
B.pack (FilePath -> HeaderName) -> Parser FilePath -> Parser HeaderName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser FilePath
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name")
            Parser (ByteString -> Header) -> Parser ByteString -> Parser Header
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> ByteString
B.pack (FilePath -> ByteString) -> Parser FilePath -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser FilePath
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value")