-- |
-- Description : Record and replay HTTP interactions
--
-- This module provides functionality for recording and replaying HTTP
-- interactions using a tape. A tape represents a stored log of
-- request/response pairs and can be operated in two modes:
--
-- * `AnyOrder` (the default): Requests may be replayed in any order.  In this
--   mode the tape is interpreted as a mapping from requests to responses.
-- * `Sequential`: Requests must be replayed in the order in which they were
--   recorded.  In this mode the tape is interpreted as a list of
--   request/response pairs.
--
-- The module exports the following operations to work with tapes:
--
-- * `with` - Replays previously recorded interactions and records new ones.
-- * `record` - Records new interactions, overwriting any existing ones.
-- * `play` - Replays previously recorded interactions and fails when a
--   requested interaction is not found on the tape.
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module VCR (
  -- * Types
  Tape(..)
, Mode(..)
  -- * Tape Operations
, with
, record
, play
) where

import Imports

import Control.Exception
import Control.Concurrent.MVar
import Control.Concurrent.Async
import Data.List
import Data.Either
import Data.String
import Data.Map.Strict (Map)
import Data.Map qualified as Map
import GHC.Stack (HasCallStack)
import Test.HUnit

import WebMock hiding (withRequestAction)
import WebMock qualified

import VCR.Serialize qualified as Serialize

-- | A `Tape` is used to record and replay HTTP interactions.
--
-- It consists of:
--
-- * A `file` path to persist the tape to.
-- * A `mode` that controls whether interactions are replayed sequentially or
--   in any order.
-- * A `redact` function that can modify HTTP requests (by default this redacts
--   the @Authorization@ header).
data Tape = Tape {
  Tape -> FilePath
file :: FilePath -- ^ Path to the tape file.
, Tape -> Mode
mode :: Mode -- ^ Mode of operation.
, Tape -> Request -> Request
redact :: Request -> Request -- ^ Function to redact sensitive information from a request.
}

-- | Represents the mode of operation for a tape.
data Mode =
    Sequential -- ^ Requests must be replayed in the order in which they were recorded.
  | AnyOrder -- ^ Requests may be replayed in any order.
  deriving (Mode -> Mode -> Bool
(Mode -> Mode -> Bool) -> (Mode -> Mode -> Bool) -> Eq Mode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
/= :: Mode -> Mode -> Bool
Eq, Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> FilePath
(Int -> Mode -> ShowS)
-> (Mode -> FilePath) -> ([Mode] -> ShowS) -> Show Mode
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mode -> ShowS
showsPrec :: Int -> Mode -> ShowS
$cshow :: Mode -> FilePath
show :: Mode -> FilePath
$cshowList :: [Mode] -> ShowS
showList :: [Mode] -> ShowS
Show)

instance IsString Tape where
  fromString :: FilePath -> Tape
fromString FilePath
file = FilePath -> Mode -> (Request -> Request) -> Tape
Tape FilePath
file Mode
AnyOrder Request -> Request
redactAuthorization

-- | Execute an action with the given tape in read-write mode.
--
-- * Replay interactions that have been recorded earlier.
-- * Record new interactions that do not yet exist on the tape.
--
-- Use `with` when you want to both replay and record interactions.
with :: HasCallStack => Tape -> IO a -> IO a
with :: forall a. HasCallStack => Tape -> IO a -> IO a
with = ReadWriteMode -> Tape -> IO a -> IO a
forall a. HasCallStack => ReadWriteMode -> Tape -> IO a -> IO a
runTape ReadWriteMode
ReadWriteMode

-- | Execute an action with the given tape in write mode.
--
-- * Overwrite interactions that have been recorded earlier.
-- * Record new interactions that do not yet exist on the tape.
--
-- Use `record` when you want to update a tape with new responses, replacing
-- any existing interactions for a given request.
record :: Tape -> IO a -> IO a
record :: forall a. Tape -> IO a -> IO a
record = ReadWriteMode -> Tape -> IO a -> IO a
forall a. HasCallStack => ReadWriteMode -> Tape -> IO a -> IO a
runTape ReadWriteMode
WriteMode

-- | Execute an action with the given tape in read mode.
--
-- * Replay interactions that have been recorded earlier.
-- * Fail on new interactions that do not yet exist on the tape.
--
-- Use `play` when you want to test against recorded responses while at the
-- same time also deny real HTTP requests for interactions that have not been
-- recorded.
play :: HasCallStack => Tape -> IO a -> IO a
play :: forall a. HasCallStack => Tape -> IO a -> IO a
play = ReadWriteMode -> Tape -> IO a -> IO a
forall a. HasCallStack => ReadWriteMode -> Tape -> IO a -> IO a
runTape ReadWriteMode
ReadMode

data OpenTape mode = OpenTape {
  forall (mode :: Mode). OpenTape mode -> FilePath
file :: FilePath
, forall (mode :: Mode). OpenTape mode -> InteractionsFor mode
interactions :: InteractionsFor mode
, forall (mode :: Mode). OpenTape mode -> Request -> Request
redact :: Request -> Request
}

type family InteractionsFor (mode :: Mode)

type instance InteractionsFor AnyOrder = MVar Interactions

data Interactions = Interactions {
  Interactions -> Modified
modified :: Modified
, Interactions -> Map Request (WithIndex (Async Response))
interactions :: Map Request (WithIndex (Async Response))
, Interactions -> Index
nextIndex :: Index
}

data Modified = NotModified | Modified

data WithIndex a = WithIndex Index a

newtype Index = Index Int
  deriving newtype (Index -> Index -> Bool
(Index -> Index -> Bool) -> (Index -> Index -> Bool) -> Eq Index
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Index -> Index -> Bool
== :: Index -> Index -> Bool
$c/= :: Index -> Index -> Bool
/= :: Index -> Index -> Bool
Eq, Int -> Index -> ShowS
[Index] -> ShowS
Index -> FilePath
(Int -> Index -> ShowS)
-> (Index -> FilePath) -> ([Index] -> ShowS) -> Show Index
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Index -> ShowS
showsPrec :: Int -> Index -> ShowS
$cshow :: Index -> FilePath
show :: Index -> FilePath
$cshowList :: [Index] -> ShowS
showList :: [Index] -> ShowS
Show, Eq Index
Eq Index =>
(Index -> Index -> Ordering)
-> (Index -> Index -> Bool)
-> (Index -> Index -> Bool)
-> (Index -> Index -> Bool)
-> (Index -> Index -> Bool)
-> (Index -> Index -> Index)
-> (Index -> Index -> Index)
-> Ord Index
Index -> Index -> Bool
Index -> Index -> Ordering
Index -> Index -> Index
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Index -> Index -> Ordering
compare :: Index -> Index -> Ordering
$c< :: Index -> Index -> Bool
< :: Index -> Index -> Bool
$c<= :: Index -> Index -> Bool
<= :: Index -> Index -> Bool
$c> :: Index -> Index -> Bool
> :: Index -> Index -> Bool
$c>= :: Index -> Index -> Bool
>= :: Index -> Index -> Bool
$cmax :: Index -> Index -> Index
max :: Index -> Index -> Index
$cmin :: Index -> Index -> Index
min :: Index -> Index -> Index
Ord, Int -> Index
Index -> Int
Index -> [Index]
Index -> Index
Index -> Index -> [Index]
Index -> Index -> Index -> [Index]
(Index -> Index)
-> (Index -> Index)
-> (Int -> Index)
-> (Index -> Int)
-> (Index -> [Index])
-> (Index -> Index -> [Index])
-> (Index -> Index -> [Index])
-> (Index -> Index -> Index -> [Index])
-> Enum Index
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Index -> Index
succ :: Index -> Index
$cpred :: Index -> Index
pred :: Index -> Index
$ctoEnum :: Int -> Index
toEnum :: Int -> Index
$cfromEnum :: Index -> Int
fromEnum :: Index -> Int
$cenumFrom :: Index -> [Index]
enumFrom :: Index -> [Index]
$cenumFromThen :: Index -> Index -> [Index]
enumFromThen :: Index -> Index -> [Index]
$cenumFromTo :: Index -> Index -> [Index]
enumFromTo :: Index -> Index -> [Index]
$cenumFromThenTo :: Index -> Index -> Index -> [Index]
enumFromThenTo :: Index -> Index -> Index -> [Index]
Enum, Integer -> Index
Index -> Index
Index -> Index -> Index
(Index -> Index -> Index)
-> (Index -> Index -> Index)
-> (Index -> Index -> Index)
-> (Index -> Index)
-> (Index -> Index)
-> (Index -> Index)
-> (Integer -> Index)
-> Num Index
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Index -> Index -> Index
+ :: Index -> Index -> Index
$c- :: Index -> Index -> Index
- :: Index -> Index -> Index
$c* :: Index -> Index -> Index
* :: Index -> Index -> Index
$cnegate :: Index -> Index
negate :: Index -> Index
$cabs :: Index -> Index
abs :: Index -> Index
$csignum :: Index -> Index
signum :: Index -> Index
$cfromInteger :: Integer -> Index
fromInteger :: Integer -> Index
Num)

type instance InteractionsFor Sequential = MVar InteractionSequence

data InteractionSequence = InteractionSequence {
  InteractionSequence -> Modified
modified :: Modified
, InteractionSequence -> [(Request, Response)]
replay :: [(Request, Response)]
, InteractionSequence -> [(Request, Response)]
rec :: [(Request, Response)]
}

checkLeftover :: HasCallStack => OpenTape Sequential -> IO ()
checkLeftover :: HasCallStack => OpenTape 'Sequential -> IO ()
checkLeftover OpenTape 'Sequential
tape = MVar InteractionSequence -> (InteractionSequence -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar OpenTape 'Sequential
tape.interactions \ InteractionSequence
interactions -> case InteractionSequence
interactions.replay of
  [] -> IO ()
forall (m :: * -> *). Applicative m => m ()
pass
  [(Request, Response)]
_ -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> IO a
assertFailure (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Expected " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
total FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" requests, but only received " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
actual FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"!"
    where
      total :: Int
total = Int
actual Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(Request, Response)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length InteractionSequence
interactions.replay
      actual :: Int
actual = [(Request, Response)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length InteractionSequence
interactions.rec

data ReadWriteMode = ReadMode | WriteMode | ReadWriteMode

shouldRecord :: ReadWriteMode -> Bool
shouldRecord :: ReadWriteMode -> Bool
shouldRecord = \ case
  ReadWriteMode
ReadMode -> Bool
False
  ReadWriteMode
WriteMode -> Bool
True
  ReadWriteMode
ReadWriteMode -> Bool
True

shouldReplay :: ReadWriteMode -> Bool
shouldReplay :: ReadWriteMode -> Bool
shouldReplay = \ case
  ReadWriteMode
ReadMode -> Bool
True
  ReadWriteMode
WriteMode -> Bool
False
  ReadWriteMode
ReadWriteMode -> Bool
True

runTape :: HasCallStack => ReadWriteMode -> Tape -> IO a -> IO a
runTape :: forall a. HasCallStack => ReadWriteMode -> Tape -> IO a -> IO a
runTape ReadWriteMode
mode Tape
tape = case Tape
tape.mode of
  Mode
AnyOrder -> ReadWriteMode -> Tape -> IO a -> IO a
forall a. HasCallStack => ReadWriteMode -> Tape -> IO a -> IO a
runTape'AnyOrder ReadWriteMode
mode Tape
tape
  Mode
Sequential -> ReadWriteMode -> Tape -> IO a -> IO a
forall a. HasCallStack => ReadWriteMode -> Tape -> IO a -> IO a
runTape'Sequential ReadWriteMode
mode Tape
tape

runTape'AnyOrder :: HasCallStack => ReadWriteMode -> Tape -> IO c -> IO c
runTape'AnyOrder :: forall a. HasCallStack => ReadWriteMode -> Tape -> IO a -> IO a
runTape'AnyOrder ReadWriteMode
mode Tape
tape IO c
action = IO (OpenTape 'AnyOrder)
-> (OpenTape 'AnyOrder -> IO ())
-> (OpenTape 'AnyOrder -> IO c)
-> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Tape -> IO (OpenTape 'AnyOrder)
openTape'AnyOrder Tape
tape) OpenTape 'AnyOrder -> IO ()
closeTape'AnyOrder \ OpenTape 'AnyOrder
t ->  do
  ReadWriteMode -> OpenTape 'AnyOrder -> IO c -> IO c
forall a.
HasCallStack =>
ReadWriteMode -> OpenTape 'AnyOrder -> IO a -> IO a
processTape'AnyOrder ReadWriteMode
mode OpenTape 'AnyOrder
t IO c
action

processTape'AnyOrder :: HasCallStack => ReadWriteMode -> OpenTape AnyOrder -> IO a -> IO a
processTape'AnyOrder :: forall a.
HasCallStack =>
ReadWriteMode -> OpenTape 'AnyOrder -> IO a -> IO a
processTape'AnyOrder ReadWriteMode
mode OpenTape 'AnyOrder
tape = (Request -> Request)
-> (IO Response -> Request -> IO Response) -> IO a -> IO a
forall a.
(Request -> Request)
-> (IO Response -> Request -> IO Response) -> IO a -> IO a
withRequestAction OpenTape 'AnyOrder
tape.redact \ IO Response
makeRequest Request
request -> IO (IO Response) -> IO Response
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join do
  MVar Interactions
-> (Interactions -> IO (Interactions, IO Response))
-> IO (IO Response)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar OpenTape 'AnyOrder
tape.interactions \ Interactions
interactions -> do
    case Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ReadWriteMode -> Bool
shouldReplay ReadWriteMode
mode) Maybe ()
-> Maybe (WithIndex (Async Response))
-> Maybe (WithIndex (Async Response))
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Request
-> Map Request (WithIndex (Async Response))
-> Maybe (WithIndex (Async Response))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Request
request Interactions
interactions.interactions of
      Just (WithIndex Index
_ Async Response
response) -> do
        (Interactions, IO Response) -> IO (Interactions, IO Response)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Interactions
interactions, Async Response -> IO Response
forall a. Async a -> IO a
wait Async Response
response)
      Maybe (WithIndex (Async Response))
Nothing | ReadWriteMode -> Bool
shouldRecord ReadWriteMode
mode -> do
        Async Response
response <- IO Response -> IO (Async Response)
forall a. IO a -> IO (Async a)
async IO Response
makeRequest
        (Interactions, IO Response) -> IO (Interactions, IO Response)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> Async Response -> Interactions -> Interactions
addInteraction Request
request Async Response
response Interactions
interactions, Async Response -> IO Response
forall a. Async a -> IO a
wait Async Response
response)
      Maybe (WithIndex (Async Response))
Nothing -> do
        Request -> IO (Interactions, IO Response)
forall a. HasCallStack => Request -> IO a
unexpectedRequest Request
request

addInteraction :: Request -> Async Response -> Interactions -> Interactions
addInteraction :: Request -> Async Response -> Interactions -> Interactions
addInteraction Request
request Async Response
response (Interactions Modified
_ Map Request (WithIndex (Async Response))
interactions Index
nextIndex) =
  case Request
-> Map Request (WithIndex (Async Response))
-> Maybe (WithIndex (Async Response))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Request
request Map Request (WithIndex (Async Response))
interactions of
    Maybe (WithIndex (Async Response))
Nothing -> Interactions {
        $sel:modified:Interactions :: Modified
modified = Modified
Modified
      , $sel:interactions:Interactions :: Map Request (WithIndex (Async Response))
interactions = Request
-> WithIndex (Async Response)
-> Map Request (WithIndex (Async Response))
-> Map Request (WithIndex (Async Response))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Request
request (Index -> Async Response -> WithIndex (Async Response)
forall a. Index -> a -> WithIndex a
WithIndex Index
nextIndex Async Response
response) Map Request (WithIndex (Async Response))
interactions
      , $sel:nextIndex:Interactions :: Index
nextIndex = Index -> Index
forall a. Enum a => a -> a
succ Index
nextIndex
      }
    Just (WithIndex Index
n Async Response
_) -> Interactions {
        $sel:modified:Interactions :: Modified
modified = Modified
Modified
      , $sel:interactions:Interactions :: Map Request (WithIndex (Async Response))
interactions = Request
-> WithIndex (Async Response)
-> Map Request (WithIndex (Async Response))
-> Map Request (WithIndex (Async Response))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Request
request (Index -> Async Response -> WithIndex (Async Response)
forall a. Index -> a -> WithIndex a
WithIndex Index
n Async Response
response) Map Request (WithIndex (Async Response))
interactions
      , Index
$sel:nextIndex:Interactions :: Index
nextIndex :: Index
nextIndex
      }

runTape'Sequential :: HasCallStack => ReadWriteMode -> Tape -> IO c -> IO c
runTape'Sequential :: forall a. HasCallStack => ReadWriteMode -> Tape -> IO a -> IO a
runTape'Sequential ReadWriteMode
mode Tape
tape IO c
action = do
  IO (OpenTape 'Sequential)
-> (OpenTape 'Sequential -> IO ())
-> (OpenTape 'Sequential -> IO c)
-> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (ReadWriteMode -> Tape -> IO (OpenTape 'Sequential)
openTape'Sequential ReadWriteMode
mode Tape
tape) OpenTape 'Sequential -> IO ()
closeTape'Sequential \ OpenTape 'Sequential
t -> do
    ReadWriteMode -> OpenTape 'Sequential -> IO c -> IO c
forall a.
HasCallStack =>
ReadWriteMode -> OpenTape 'Sequential -> IO a -> IO a
processTape'Sequential ReadWriteMode
mode OpenTape 'Sequential
t IO c
action IO c -> IO () -> IO c
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* HasCallStack => OpenTape 'Sequential -> IO ()
OpenTape 'Sequential -> IO ()
checkLeftover OpenTape 'Sequential
t

processTape'Sequential :: HasCallStack => ReadWriteMode -> OpenTape Sequential -> IO a -> IO a
processTape'Sequential :: forall a.
HasCallStack =>
ReadWriteMode -> OpenTape 'Sequential -> IO a -> IO a
processTape'Sequential ReadWriteMode
mode OpenTape 'Sequential
tape = (Request -> Request)
-> (IO Response -> Request -> IO Response) -> IO a -> IO a
forall a.
(Request -> Request)
-> (IO Response -> Request -> IO Response) -> IO a -> IO a
withRequestAction OpenTape 'Sequential
tape.redact \ IO Response
makeRequest Request
request -> do
  MVar InteractionSequence
-> (InteractionSequence -> IO (InteractionSequence, Response))
-> IO Response
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar OpenTape 'Sequential
tape.interactions \ InteractionSequence
interactions -> do
    case InteractionSequence
interactions.replay of
      recorded :: (Request, Response)
recorded@(Request
recordedRequest, Response
recordedResponse) : [(Request, Response)]
replay -> do
        Request
request Request -> Request -> IO ()
forall a. (HasCallStack, Eq a, Show a) => a -> a -> IO ()
@?= Request
recordedRequest
        (InteractionSequence, Response)
-> IO (InteractionSequence, Response)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InteractionSequence
interactions {
            replay
          , rec = recorded : interactions.rec
          }, Response
recordedResponse)
      [] | ReadWriteMode -> Bool
shouldRecord ReadWriteMode
mode -> do
        Response
response <- IO Response
makeRequest
        (InteractionSequence, Response)
-> IO (InteractionSequence, Response)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InteractionSequence
interactions {
            modified = Modified
          , rec = (request, response) : interactions.rec
          }, Response
response)
      [] -> do
        Request -> IO (InteractionSequence, Response)
forall a. HasCallStack => Request -> IO a
unexpectedRequest Request
request

unexpectedRequest :: HasCallStack => Request -> IO a
unexpectedRequest :: forall a. HasCallStack => Request -> IO a
unexpectedRequest Request
request = FilePath -> IO a
forall a. HasCallStack => FilePath -> IO a
assertFailure (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath
"Unexpected HTTP request: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Request -> FilePath
forall a. Show a => a -> FilePath
show Request
request

withRequestAction :: (Request -> Request) -> (IO Response -> Request -> IO Response) -> IO a -> IO a
withRequestAction :: forall a.
(Request -> Request)
-> (IO Response -> Request -> IO Response) -> IO a -> IO a
withRequestAction Request -> Request
redact IO Response -> Request -> IO Response
requestAction = (IO Response -> Request -> IO Response) -> IO a -> IO a
forall a. (IO Response -> Request -> IO Response) -> IO a -> IO a
WebMock.withRequestAction
  \ IO Response
makeRequest Request
request -> IO Response -> Request -> IO Response
requestAction IO Response
makeRequest (Request -> Request
redact Request
request)

openTape'AnyOrder :: Tape -> IO (OpenTape AnyOrder)
openTape'AnyOrder :: Tape -> IO (OpenTape 'AnyOrder)
openTape'AnyOrder Tape{FilePath
Mode
Request -> Request
$sel:file:Tape :: Tape -> FilePath
$sel:mode:Tape :: Tape -> Mode
$sel:redact:Tape :: Tape -> Request -> Request
file :: FilePath
mode :: Mode
redact :: Request -> Request
..} = do
  MVar Interactions
interactions <- FilePath -> IO [(Request, Response)]
Serialize.loadTape FilePath
file IO [(Request, Response)]
-> ([(Request, Response)] -> IO Interactions) -> IO Interactions
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(Request, Response)] -> IO Interactions
toInteractions IO Interactions
-> (Interactions -> IO (MVar Interactions))
-> IO (MVar Interactions)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Interactions -> IO (MVar Interactions)
forall a. a -> IO (MVar a)
newMVar
  OpenTape 'AnyOrder -> IO (OpenTape 'AnyOrder)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return OpenTape {
    FilePath
$sel:file:OpenTape :: FilePath
file :: FilePath
file
  , MVar Interactions
InteractionsFor 'AnyOrder
$sel:interactions:OpenTape :: InteractionsFor 'AnyOrder
interactions :: MVar Interactions
interactions
  , Request -> Request
$sel:redact:OpenTape :: Request -> Request
redact :: Request -> Request
redact
  }
  where
    toInteractions :: [(Request, Response)] -> IO Interactions
    toInteractions :: [(Request, Response)] -> IO Interactions
toInteractions [(Request, Response)]
recordedInteractions = do
      Map Request (WithIndex (Async Response))
interactions <- [(Request, WithIndex (Async Response))]
-> Map Request (WithIndex (Async Response))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Request, WithIndex (Async Response))]
 -> Map Request (WithIndex (Async Response)))
-> ([(Request, Async Response)]
    -> [(Request, WithIndex (Async Response))])
-> [(Request, Async Response)]
-> Map Request (WithIndex (Async Response))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Request, Async Response)]
-> [(Request, WithIndex (Async Response))]
forall a b. [(a, b)] -> [(a, WithIndex b)]
addIndices ([(Request, Async Response)]
 -> Map Request (WithIndex (Async Response)))
-> IO [(Request, Async Response)]
-> IO (Map Request (WithIndex (Async Response)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Request, Response) -> IO (Request, Async Response))
-> [(Request, Response)] -> IO [(Request, Async Response)]
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 (Request, Response) -> IO (Request, Async Response)
toAsyncResponse [(Request, Response)]
recordedInteractions
      Interactions -> IO Interactions
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Interactions {
        $sel:modified:Interactions :: Modified
modified = Modified
NotModified
      , Map Request (WithIndex (Async Response))
$sel:interactions:Interactions :: Map Request (WithIndex (Async Response))
interactions :: Map Request (WithIndex (Async Response))
interactions
      , $sel:nextIndex:Interactions :: Index
nextIndex = Int -> Index
Index (Map Request (WithIndex (Async Response)) -> Int
forall k a. Map k a -> Int
Map.size Map Request (WithIndex (Async Response))
interactions)
      }

    toAsyncResponse :: (Request, Response) -> IO (Request, Async Response)
    toAsyncResponse :: (Request, Response) -> IO (Request, Async Response)
toAsyncResponse = (Response -> IO (Async Response))
-> (Request, Response) -> IO (Request, Async Response)
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) -> (Request, a) -> f (Request, b)
traverse ((Response -> IO (Async Response))
 -> (Request, Response) -> IO (Request, Async Response))
-> (Response -> IO (Async Response))
-> (Request, Response)
-> IO (Request, Async Response)
forall a b. (a -> b) -> a -> b
$ Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response)
-> (IO Response -> IO (Async Response))
-> Response
-> IO (Async Response)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> IO Response -> IO (Async Response)
forall a. IO a -> IO (Async a)
async

    addIndices :: [(a, b)] -> [(a, WithIndex b)]
    addIndices :: forall a b. [(a, b)] -> [(a, WithIndex b)]
addIndices = (Index -> (a, b) -> (a, WithIndex b))
-> [Index] -> [(a, b)] -> [(a, WithIndex b)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ Index
n (a
request, b
response) -> (a
request, Index -> b -> WithIndex b
forall a. Index -> a -> WithIndex a
WithIndex Index
n b
response)) [Index
0 ..]

closeTape'AnyOrder :: OpenTape AnyOrder -> IO ()
closeTape'AnyOrder :: OpenTape 'AnyOrder -> IO ()
closeTape'AnyOrder OpenTape 'AnyOrder
tape = do
  MVar Interactions -> (Interactions -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar OpenTape 'AnyOrder
tape.interactions \ (Interactions Modified
modified Map Request (WithIndex (Async Response))
interactions Index
_) -> case Modified
modified of
    Modified
NotModified -> IO ()
forall (m :: * -> *). Applicative m => m ()
pass
    Modified
Modified -> [(Request, Async Response)] -> IO [(Request, Response)]
sequenceInteractions (Map Request (WithIndex (Async Response))
-> [(Request, Async Response)]
forall a b. Map a (WithIndex b) -> [(a, b)]
toSortedList Map Request (WithIndex (Async Response))
interactions) IO [(Request, Response)]
-> ([(Request, Response)] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> [(Request, Response)] -> IO ()
Serialize.saveTape OpenTape 'AnyOrder
tape.file
  where
    sequenceInteractions :: [(Request, Async Response)] -> IO [(Request, Response)]
    sequenceInteractions :: [(Request, Async Response)] -> IO [(Request, Response)]
sequenceInteractions = ([Either SomeException (Request, Response)]
 -> [(Request, Response)])
-> IO [Either SomeException (Request, Response)]
-> 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 [Either SomeException (Request, Response)] -> [(Request, Response)]
forall a b. [Either a b] -> [b]
rights (IO [Either SomeException (Request, Response)]
 -> IO [(Request, Response)])
-> ([(Request, Async Response)]
    -> IO [Either SomeException (Request, Response)])
-> [(Request, Async Response)]
-> IO [(Request, Response)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Request, Async Response)
 -> IO (Either SomeException (Request, Response)))
-> [(Request, Async Response)]
-> IO [Either SomeException (Request, Response)]
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 (Request, Async Response)
-> IO (Either SomeException (Request, Response))
waitCatchAll

    waitCatchAll :: (Request, Async Response) -> IO (Either SomeException (Request, Response))
    waitCatchAll :: (Request, Async Response)
-> IO (Either SomeException (Request, Response))
waitCatchAll = ((Request, Either SomeException Response)
 -> Either SomeException (Request, Response))
-> IO (Request, Either SomeException Response)
-> IO (Either SomeException (Request, Response))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Request, Either SomeException Response)
-> Either SomeException (Request, Response)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => (Request, m a) -> m (Request, a)
sequence (IO (Request, Either SomeException Response)
 -> IO (Either SomeException (Request, Response)))
-> ((Request, Async Response)
    -> IO (Request, Either SomeException Response))
-> (Request, Async Response)
-> IO (Either SomeException (Request, Response))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Async Response -> IO (Either SomeException Response))
-> (Request, Async Response)
-> IO (Request, Either SomeException Response)
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) -> (Request, a) -> f (Request, b)
traverse Async Response -> IO (Either SomeException Response)
forall a. Async a -> IO (Either SomeException a)
waitCatch

    toSortedList :: Map a (WithIndex b) -> [(a, b)]
    toSortedList :: forall a b. Map a (WithIndex b) -> [(a, b)]
toSortedList = ((a, WithIndex b) -> (a, b)) -> [(a, WithIndex b)] -> [(a, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((WithIndex b -> b) -> (a, WithIndex b) -> (a, b)
forall a b. (a -> b) -> (a, a) -> (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithIndex b -> b
forall a. WithIndex a -> a
value) ([(a, WithIndex b)] -> [(a, b)])
-> (Map a (WithIndex b) -> [(a, WithIndex b)])
-> Map a (WithIndex b)
-> [(a, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, WithIndex b)] -> [(a, WithIndex b)]
forall a b. [(a, WithIndex b)] -> [(a, WithIndex b)]
sortOnIndex ([(a, WithIndex b)] -> [(a, WithIndex b)])
-> (Map a (WithIndex b) -> [(a, WithIndex b)])
-> Map a (WithIndex b)
-> [(a, WithIndex b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a (WithIndex b) -> [(a, WithIndex b)]
forall k a. Map k a -> [(k, a)]
Map.toList

    sortOnIndex :: [(a, WithIndex b)] -> [(a, WithIndex b)]
    sortOnIndex :: forall a b. [(a, WithIndex b)] -> [(a, WithIndex b)]
sortOnIndex = ((a, WithIndex b) -> Index)
-> [(a, WithIndex b)] -> [(a, WithIndex b)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (WithIndex b -> Index
forall a. WithIndex a -> Index
index (WithIndex b -> Index)
-> ((a, WithIndex b) -> WithIndex b) -> (a, WithIndex b) -> Index
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, WithIndex b) -> WithIndex b
forall a b. (a, b) -> b
snd)

    index :: WithIndex a -> Index
    index :: forall a. WithIndex a -> Index
index (WithIndex Index
n a
_) = Index
n

    value :: WithIndex a -> a
    value :: forall a. WithIndex a -> a
value (WithIndex Index
_ a
a) = a
a

openTape'Sequential :: ReadWriteMode -> Tape -> IO (OpenTape Sequential)
openTape'Sequential :: ReadWriteMode -> Tape -> IO (OpenTape 'Sequential)
openTape'Sequential ReadWriteMode
mode Tape{FilePath
$sel:file:Tape :: Tape -> FilePath
file :: FilePath
file, Request -> Request
$sel:redact:Tape :: Tape -> Request -> Request
redact :: Request -> Request
redact} = do
  [(Request, Response)]
replay <- if ReadWriteMode -> Bool
shouldReplay ReadWriteMode
mode then FilePath -> IO [(Request, Response)]
Serialize.loadTape FilePath
file else [(Request, Response)] -> IO [(Request, Response)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  MVar InteractionSequence
interactions <- InteractionSequence -> IO (MVar InteractionSequence)
forall a. a -> IO (MVar a)
newMVar InteractionSequence {
    $sel:modified:InteractionSequence :: Modified
modified = Modified
NotModified
  , [(Request, Response)]
$sel:replay:InteractionSequence :: [(Request, Response)]
replay :: [(Request, Response)]
replay
  , $sel:rec:InteractionSequence :: [(Request, Response)]
rec = []
  }
  OpenTape 'Sequential -> IO (OpenTape 'Sequential)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return OpenTape {
    FilePath
$sel:file:OpenTape :: FilePath
file :: FilePath
file
  , MVar InteractionSequence
InteractionsFor 'Sequential
$sel:interactions:OpenTape :: InteractionsFor 'Sequential
interactions :: MVar InteractionSequence
interactions
  , Request -> Request
$sel:redact:OpenTape :: Request -> Request
redact :: Request -> Request
redact
  }

closeTape'Sequential :: OpenTape Sequential -> IO ()
closeTape'Sequential :: OpenTape 'Sequential -> IO ()
closeTape'Sequential OpenTape 'Sequential
tape = MVar InteractionSequence -> (InteractionSequence -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar OpenTape 'Sequential
tape.interactions \ InteractionSequence
interactions -> case InteractionSequence
interactions.modified of
  Modified
Modified -> FilePath -> [(Request, Response)] -> IO ()
Serialize.saveTape OpenTape 'Sequential
tape.file ([(Request, Response)] -> [(Request, Response)]
forall a. [a] -> [a]
reverse InteractionSequence
interactions.rec)
  Modified
_ -> IO ()
forall (m :: * -> *). Applicative m => m ()
pass

redactAuthorization :: Request -> Request
redactAuthorization :: Request -> Request
redactAuthorization request :: Request
request@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
..} = Request
request { requestHeaders = map redact requestHeaders }
  where
    redact :: Header -> Header
    redact :: Header -> Header
redact header :: Header
header@(HeaderName
name, ByteString
_)
      | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hAuthorization = (HeaderName
name, ByteString
"********")
      | Bool
otherwise = Header
header