packages feed

vcr (empty) → 0.0.0

raw patch · 10 files changed

+1215/−0 lines, 10 filesdep +HUnitdep +asyncdep +base

Dependencies added: HUnit, async, base, bytestring, case-insensitive, containers, directory, filepath, hspec, http-client, http-client-tls, http-conduit, http-types, mockery, network-uri, text, yaml

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2020 Assertible+Copyright (c) 2025 Simon Hengel++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ src/Imports.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP #-}+module Imports (module Imports) where++import Prelude as Imports+import Control.Arrow as Imports+import Control.Monad as Imports+import Data.Maybe as Imports+import Data.Functor as Imports+#if MIN_VERSION_base(4,19,0)+  hiding (unzip)+#endif+import Data.IORef as Imports (IORef, newIORef, atomicWriteIORef, atomicModifyIORef')+import Data.ByteString as Imports (ByteString)+import Data.ByteString.Lazy as Imports (LazyByteString)++atomicReadIORef :: IORef a -> IO a+atomicReadIORef ref = atomicModifyIORef' ref (id &&& id)++pass :: Applicative m => m ()+pass = pure ()
+ src/VCR.hs view
@@ -0,0 +1,302 @@+-- |+-- 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 {+  file :: FilePath -- ^ Path to the tape file.+, mode :: Mode -- ^ Mode of operation.+, 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 (Eq, Show)++instance IsString Tape where+  fromString file = Tape file AnyOrder 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 = runTape 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 = runTape 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 = runTape ReadMode++data OpenTape mode = OpenTape {+  file :: FilePath+, interactions :: InteractionsFor mode+, redact :: Request -> Request+}++type family InteractionsFor (mode :: Mode)++type instance InteractionsFor AnyOrder = MVar Interactions++data Interactions = Interactions {+  modified :: Modified+, interactions :: Map Request (WithIndex (Async Response))+, nextIndex :: Index+}++data Modified = NotModified | Modified++data WithIndex a = WithIndex Index a++newtype Index = Index Int+  deriving newtype (Eq, Show, Ord, Enum, Num)++type instance InteractionsFor Sequential = MVar InteractionSequence++data InteractionSequence = InteractionSequence {+  modified :: Modified+, replay :: [(Request, Response)]+, rec :: [(Request, Response)]+}++checkLeftover :: HasCallStack => OpenTape Sequential -> IO ()+checkLeftover tape = withMVar tape.interactions \ interactions -> case interactions.replay of+  [] -> pass+  _ -> assertFailure $ "Expected " ++ show total ++ " requests, but only received " ++ show actual ++ "!"+    where+      total = actual + length interactions.replay+      actual = length interactions.rec++data ReadWriteMode = ReadMode | WriteMode | ReadWriteMode++shouldRecord :: ReadWriteMode -> Bool+shouldRecord = \ case+  ReadMode -> False+  WriteMode -> True+  ReadWriteMode -> True++shouldReplay :: ReadWriteMode -> Bool+shouldReplay = \ case+  ReadMode -> True+  WriteMode -> False+  ReadWriteMode -> True++runTape :: HasCallStack => ReadWriteMode -> Tape -> IO a -> IO a+runTape mode tape = case tape.mode of+  AnyOrder -> runTape'AnyOrder mode tape+  Sequential -> runTape'Sequential mode tape++runTape'AnyOrder :: HasCallStack => ReadWriteMode -> Tape -> IO c -> IO c+runTape'AnyOrder mode tape action = bracket (openTape'AnyOrder tape) closeTape'AnyOrder \ t ->  do+  processTape'AnyOrder mode t action++processTape'AnyOrder :: HasCallStack => ReadWriteMode -> OpenTape AnyOrder -> IO a -> IO a+processTape'AnyOrder mode tape = withRequestAction tape.redact \ makeRequest request -> join do+  modifyMVar tape.interactions \ interactions -> do+    case guard (shouldReplay mode) >> Map.lookup request interactions.interactions of+      Just (WithIndex _ response) -> do+        return (interactions, wait response)+      Nothing | shouldRecord mode -> do+        response <- async makeRequest+        return (addInteraction request response interactions, wait response)+      Nothing -> do+        unexpectedRequest request++addInteraction :: Request -> Async Response -> Interactions -> Interactions+addInteraction request response (Interactions _ interactions nextIndex) =+  case Map.lookup request interactions of+    Nothing -> Interactions {+        modified = Modified+      , interactions = Map.insert request (WithIndex nextIndex response) interactions+      , nextIndex = succ nextIndex+      }+    Just (WithIndex n _) -> Interactions {+        modified = Modified+      , interactions = Map.insert request (WithIndex n response) interactions+      , nextIndex+      }++runTape'Sequential :: HasCallStack => ReadWriteMode -> Tape -> IO c -> IO c+runTape'Sequential mode tape action = do+  bracket (openTape'Sequential mode tape) closeTape'Sequential \ t -> do+    processTape'Sequential mode t action <* checkLeftover t++processTape'Sequential :: HasCallStack => ReadWriteMode -> OpenTape Sequential -> IO a -> IO a+processTape'Sequential mode tape = withRequestAction tape.redact \ makeRequest request -> do+  modifyMVar tape.interactions \ interactions -> do+    case interactions.replay of+      recorded@(recordedRequest, recordedResponse) : replay -> do+        request @?= recordedRequest+        return (interactions {+            replay+          , rec = recorded : interactions.rec+          }, recordedResponse)+      [] | shouldRecord mode -> do+        response <- makeRequest+        return (interactions {+            modified = Modified+          , rec = (request, response) : interactions.rec+          }, response)+      [] -> do+        unexpectedRequest request++unexpectedRequest :: HasCallStack => Request -> IO a+unexpectedRequest request = assertFailure $ "Unexpected HTTP request: " ++ show request++withRequestAction :: (Request -> Request) -> (IO Response -> Request -> IO Response) -> IO a -> IO a+withRequestAction redact requestAction = WebMock.withRequestAction+  \ makeRequest request -> requestAction makeRequest (redact request)++openTape'AnyOrder :: Tape -> IO (OpenTape AnyOrder)+openTape'AnyOrder Tape{..} = do+  interactions <- Serialize.loadTape file >>= toInteractions >>= newMVar+  return OpenTape {+    file+  , interactions+  , redact+  }+  where+    toInteractions :: [(Request, Response)] -> IO Interactions+    toInteractions recordedInteractions = do+      interactions <- Map.fromList . addIndices <$> traverse toAsyncResponse recordedInteractions+      return Interactions {+        modified = NotModified+      , interactions+      , nextIndex = Index (Map.size interactions)+      }++    toAsyncResponse :: (Request, Response) -> IO (Request, Async Response)+    toAsyncResponse = traverse $ return >>> async++    addIndices :: [(a, b)] -> [(a, WithIndex b)]+    addIndices = zipWith (\ n (request, response) -> (request, WithIndex n response)) [0 ..]++closeTape'AnyOrder :: OpenTape AnyOrder -> IO ()+closeTape'AnyOrder tape = do+  withMVar tape.interactions \ (Interactions modified interactions _) -> case modified of+    NotModified -> pass+    Modified -> sequenceInteractions (toSortedList interactions) >>= Serialize.saveTape tape.file+  where+    sequenceInteractions :: [(Request, Async Response)] -> IO [(Request, Response)]+    sequenceInteractions = fmap rights . traverse waitCatchAll++    waitCatchAll :: (Request, Async Response) -> IO (Either SomeException (Request, Response))+    waitCatchAll = fmap sequence . traverse waitCatch++    toSortedList :: Map a (WithIndex b) -> [(a, b)]+    toSortedList = map (fmap value) . sortOnIndex . Map.toList++    sortOnIndex :: [(a, WithIndex b)] -> [(a, WithIndex b)]+    sortOnIndex = sortOn (index . snd)++    index :: WithIndex a -> Index+    index (WithIndex n _) = n++    value :: WithIndex a -> a+    value (WithIndex _ a) = a++openTape'Sequential :: ReadWriteMode -> Tape -> IO (OpenTape Sequential)+openTape'Sequential mode Tape{file, redact} = do+  replay <- if shouldReplay mode then Serialize.loadTape file else return []+  interactions <- newMVar InteractionSequence {+    modified = NotModified+  , replay+  , rec = []+  }+  return OpenTape {+    file+  , interactions+  , redact+  }++closeTape'Sequential :: OpenTape Sequential -> IO ()+closeTape'Sequential tape = withMVar tape.interactions \ interactions -> case interactions.modified of+  Modified -> Serialize.saveTape tape.file (reverse interactions.rec)+  _ -> pass++redactAuthorization :: Request -> Request+redactAuthorization request@Request{..} = request { requestHeaders = map redact requestHeaders }+  where+    redact :: Header -> Header+    redact header@(name, _)+      | name == hAuthorization = (name, "********")+      | otherwise = header
+ src/VCR/Serialize.hs view
@@ -0,0 +1,138 @@+{-# 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 file interactions = do+  ensureDirectory file+  B.writeFile file $ Yaml.encodePretty conf (toInteractions interactions)+  where+    conf = Yaml.setConfCompare (comparing f) Yaml.defConfig++    f :: Text -> Int+    f name = fromMaybe maxBound (lookup name fieldOrder)++    toInteractions :: [(Request, Response)] -> [Interaction]+    toInteractions = map \ (request, response) -> (Interaction request response)++fieldOrder :: [(Text, Int)]+fieldOrder = flip zip [1..] [+    "request"+  , "response"++  , "method"+  , "url"++  , "status"+  , "headers"+  , "body"++  , "code"+  , "message"++  , "name"+  , "value"+  ]++ensureDirectory :: FilePath -> IO ()+ensureDirectory = createDirectoryIfMissing True . takeDirectory++loadTape :: FilePath -> IO [(Request, Response)]+loadTape file = fromRight [] <$> tryJust (guard . isDoesNotExistError) (unsafeLoadTape file)++unsafeLoadTape :: FilePath -> IO [(Request, Response)]+unsafeLoadTape file = B.readFile file >>= fmap fromInteractions . Yaml.decodeThrow+  where+    fromInteractions :: [Interaction] -> [(Request, Response)]+    fromInteractions = map \ (Interaction request response) -> (request, response)++data Interaction = Interaction Request Response++instance ToJSON Interaction where+  toJSON (Interaction request response) = object [+        "request" .= requestToJSON request+      , "response" .= responseToJSON response+      ]+    where+      requestToJSON :: Request -> Value+      requestToJSON Request{..} = object [+          "method" .= B.unpack requestMethod+        , "url" .= requestUrl+        , "headers" .= headersToJSON requestHeaders+        , "body" .= L.unpack requestBody+        ]++      responseToJSON :: Response -> Value+      responseToJSON Response{..} = object [+          "status" .= statusToJSON responseStatus+        , "headers" .= headersToJSON responseHeaders+        , "body" .= L.unpack responseBody+        ]+        where+          statusToJSON :: Status -> Value+          statusToJSON (Status code message) = object [+              "code" .= code+            , "message" .= B.unpack message+            ]++      headersToJSON :: RequestHeaders -> Value+      headersToJSON = toJSON . map headerToJSON+        where+          headerToJSON :: Header -> Value+          headerToJSON (name, value) = object [+              "name" .= B.unpack (CI.original name)+            , "value" .= B.unpack value+            ]++instance FromJSON Interaction where+  parseJSON = withObject "Interaction" \ o -> Interaction+    <$> (o .: "request" >>= requestFromJSON)+    <*> (o .: "response" >>= responseFromJSON)+    where+      requestFromJSON :: Value -> Parser Request+      requestFromJSON = withObject "Request" \ o ->+        Request+        <$> (B.pack <$> o .: "method")+        <*> o .: "url"+        <*> (o .: "headers" >>= headersFromJSON)+        <*> (L.pack <$> o .: "body")++      responseFromJSON :: Value -> Parser Response+      responseFromJSON = withObject "Response" \ o -> Response+        <$> (o .: "status" >>= statusFromJSON)+        <*> (o .: "headers" >>= headersFromJSON)+        <*> (L.pack <$> o .: "body")+        where+          statusFromJSON :: Object -> Parser Status+          statusFromJSON o = Status+            <$> (o .: "code")+            <*> (B.pack <$> o .: "message")++      headersFromJSON :: [Object] -> Parser RequestHeaders+      headersFromJSON = mapM headerFromJSON+        where+          headerFromJSON :: Object -> Parser Header+          headerFromJSON o = (,)+            <$> (CI.mk . B.pack <$> o .: "name")+            <*> (B.pack <$> o .: "value")
+ src/WebMock.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module WebMock (+  Request (..)+, Response (..)+, disableRequests+, unsafeMockRequest+, mockRequest+, mockRequestChain+, mkRequestActions+, mkRequestAction+, module Network.HTTP.Types++, withRequestAction+, protectRequestAction++, toSimpleRequest+, fromSimpleResponse+, toSimpleResponse+) where++import Imports++import Control.Exception+import Data.ByteString.Lazy qualified as L+import Data.String+import Data.Text qualified as T+import Data.Text.Encoding (encodeUtf8)+import GHC.Stack (HasCallStack)+import Network.HTTP.Client.Internal (Manager, BodyReader)+import Network.HTTP.Client.Internal qualified as Client+import Network.HTTP.Types+import Network.URI (uriToString)+import Test.HUnit++import WebMock.Util++data Request = Request {+  requestMethod  :: Method+, requestUrl     :: String+, requestHeaders :: RequestHeaders+, requestBody    :: LazyByteString+} deriving (Eq, Ord)++instance IsString Request where+  fromString url = Request "GET" url [] ""++instance Show Request where+  show Request{..} = unlines [+      "Request {"+    , "  requestMethod = " ++ show requestMethod+    , ", requestUrl = " ++ show requestUrl+    , ", requestHeaders = " ++ show requestHeaders+    , ", requestBody = " ++ show requestBody+    , "}"+    ]++data Response = Response {+  responseStatus  :: Status+, responseHeaders :: ResponseHeaders+, responseBody    :: LazyByteString+} deriving (Eq, Show)++instance IsString Response where+  fromString body = Response status200 [] (L.fromStrict $ encodeUtf8 $ T.pack body)++unsafeMockRequest :: (Request -> IO Response) -> IO ()+unsafeMockRequest f = atomicWriteIORef Client.requestAction requestAction+  where+    requestAction :: RequestAction+    requestAction request _manager = do+      toSimpleRequest request >>= f >>= fromSimpleResponse request++mockRequest :: HasCallStack => Request -> Response -> IO a -> IO a+mockRequest expectedRequest response action = protectRequestAction do+  unsafeMockRequest \ request -> do+    request @?= expectedRequest+    return response+  action++disableRequests :: HasCallStack => IO a -> IO a+disableRequests action = do+  let+    requestAction :: IO Response -> Request -> IO Response+    requestAction _makeRequest request = do+      unexpectedRequest request+  withRequestAction requestAction action++mockRequestChain :: HasCallStack => [Request -> IO Response] -> IO a -> IO a+mockRequestChain interactions action = do+  ref <- newIORef interactions++  let+    requestAction :: IO Response -> Request -> IO Response+    requestAction _makeRequest request = do+      atomicModifyIORef' ref (drop 1 &&& listToMaybe) >>= \ case+        Just interaction -> interaction request+        Nothing -> unexpectedRequest request++    checkLeftover :: IO ()+    checkLeftover = do+      leftover <- length <$> atomicReadIORef ref+      when (leftover /= 0) do+        let+          total = length interactions+          actual = total - leftover+        assertFailure $ "Expected " ++ show total ++ " requests, but only received " ++ show actual ++ "!"++  withRequestAction requestAction action <* checkLeftover++unexpectedRequest :: HasCallStack => Request -> IO a+unexpectedRequest request = assertFailure $ "Unexpected HTTP request: " ++ show request++mkRequestActions :: HasCallStack => [(Request, Response)] -> [Request -> IO Response]+mkRequestActions = map (uncurry mkRequestAction)++mkRequestAction :: HasCallStack => Request -> Response -> Request -> IO Response+mkRequestAction expected response actual = do+  actual @?= expected+  return response++type RequestAction = Client.Request -> Manager -> IO (Client.Response BodyReader)++withRequestAction :: (IO Response -> Request -> IO Response) -> IO a -> IO a+withRequestAction action = bracket setup restore . const+  where+    lift :: RequestAction -> RequestAction+    lift makeClientRequest request manager = do+      toSimpleRequest request >>= makeRequest >>= fromSimpleResponse request+      where+        makeRequest :: Request -> IO Response+        makeRequest = action $ makeClientRequest request manager >>= toSimpleResponse++    setup :: IO RequestAction+    setup = atomicModifyIORef' Client.requestAction \ old -> (lift old, old)++    restore :: RequestAction -> IO ()+    restore = atomicWriteIORef Client.requestAction++protectRequestAction :: IO a -> IO a+protectRequestAction = bracket save restore . const+  where+    save :: IO RequestAction+    save = atomicReadIORef Client.requestAction++    restore :: RequestAction -> IO ()+    restore = atomicWriteIORef Client.requestAction++toSimpleRequest :: Client.Request -> IO Request+toSimpleRequest r = do+  body <- requestBodyToByteString (Client.requestBody r)+  return $ Request {+    requestMethod = Client.method r+  , requestUrl = uriToString id (Client.getUri r) ""+  , requestHeaders = Client.requestHeaders r+  , requestBody = body+  }++toSimpleResponse :: Client.Response BodyReader -> IO Response+toSimpleResponse r = do+  c <- Client.brConsume (Client.responseBody r)+  Client.responseClose r+  return $ Response {+    responseStatus = Client.responseStatus r+  , responseHeaders = Client.responseHeaders r+  , responseBody = L.fromChunks c+  }++fromSimpleResponse :: Client.Request -> Response -> IO (Client.Response BodyReader)+fromSimpleResponse request Response{..} = do+  body <- Client.constBodyReader (L.toChunks responseBody)+  return $ Client.Response {+    Client.responseStatus = responseStatus+  , Client.responseVersion = http11+  , Client.responseHeaders = responseHeaders+  , Client.responseBody = body+  , Client.responseCookieJar = mempty+  , Client.responseClose' = Client.ResponseClose pass+  , Client.responseOriginalRequest = request { Client.requestBody = mempty }+  , Client.responseEarlyHints = mempty+  }
+ src/WebMock/Util.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+module WebMock.Util (requestBodyToByteString) where++import Imports++import Data.ByteString.Builder qualified as Builder+import Data.ByteString.Lazy qualified as L+import Data.Int+import Data.IORef+import Network.HTTP.Client.Internal++requestBodyToByteString :: RequestBody -> IO LazyByteString+requestBodyToByteString = \ case+  RequestBodyLBS body -> return body+  RequestBodyBS body -> return (L.fromStrict body)+  RequestBodyBuilder n builder -> checkLength n (Builder.toLazyByteString builder)+  RequestBodyStream n stream -> streamToByteString stream >>= checkLength n+  RequestBodyStreamChunked stream -> streamToByteString stream+  RequestBodyIO body -> body >>= requestBodyToByteString++streamToByteString :: GivesPopper () -> IO LazyByteString+streamToByteString givesPopper = do+  ref <- newIORef undefined+  givesPopper (go [] ref)+  readIORef ref+  where+    go :: [ByteString] -> IORef LazyByteString -> Popper -> IO ()+    go xs ref get = get >>= \ case+      "" -> writeIORef ref (L.fromChunks $ reverse xs)+      x -> go (x : xs) ref get++checkLength :: Int64 -> LazyByteString -> IO LazyByteString+checkLength n xs+  | n == len = return xs+  | otherwise = throwHttp $ WrongRequestBodyStreamSize (fromIntegral len) (fromIntegral n)+  where+    len = L.length xs
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-discover #-}
+ test/VCRSpec.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedRecordDot #-}+module VCRSpec (spec) where++import Imports++import Test.Hspec+import Test.HUnit.Lang+import Test.Mockery.Directory+import System.Timeout++import Control.Concurrent+import Control.Concurrent.Async+import Network.HTTP.Client qualified as Client+import Network.HTTP.Client.TLS (getGlobalManager)+import Network.HTTP.Types++import WebMock++import VCR+import VCR.Serialize (loadTape)++makeRequest :: String -> [Header] -> IO (Client.Response LazyByteString)+makeRequest url headers = do+  manager <- getGlobalManager+  request <- Client.parseUrlThrow url+  Client.httpLbs request { Client.requestHeaders = headers } manager++httpException :: Client.HttpException -> Bool+httpException _ = True++hUnitFailure :: FailureReason -> HUnitFailure -> Bool+hUnitFailure expectd (HUnitFailure _ actual) = expectd == actual++expectedButGot :: Request -> Request -> HUnitFailure -> Bool+expectedButGot expected actual= hUnitFailure (ExpectedButGot Nothing (show expected) (show actual))++unexpectedRequest :: Request -> HUnitFailure -> Bool+unexpectedRequest = hUnitFailure . Reason . mappend "Unexpected HTTP request: " . show++infix 1 `shouldReturnStatus`+infix 1 `shouldReturnBody`++shouldReturnStatus :: HasCallStack => String -> Status -> IO ()+shouldReturnStatus url expected = do+  Client.responseStatus <$> makeRequest url [] `shouldReturn` expected++shouldReturnBody :: HasCallStack => String -> LazyByteString -> IO ()+shouldReturnBody url expected = do+  Client.responseBody <$> makeRequest url [] `shouldReturn` expected++authRequest :: Request+authRequest = "http://httpbin.org/status/200" {+  requestHeaders = [(hAuthorization, "Bearer sk-RfAZfajzapKps4anC6ej8rhSnMxf5sLd")]+}++redactedAuthRequest :: Request+redactedAuthRequest = authRequest {+  requestHeaders = [(hAuthorization, "********")]+}++makeAuthRequest :: IO ()+makeAuthRequest = void $ makeRequest authRequest.requestUrl authRequest.requestHeaders++respondWith :: Status -> Request -> IO Response+respondWith responseStatus _ = return $ "" { responseStatus }++spec :: Spec+spec = around_ inTempDirectory do+  describe "with" do+    context "when mode is AnyOrder" do+      let tape = "tape.yaml"++      it "records requests in the order they were made" do+        mockRequestChain [respondWith status200, respondWith status202, respondWith status201] do+          VCR.with tape do+            "http://httpbin.org/status/200" `shouldReturnStatus` status200+            "http://httpbin.org/status/202" `shouldReturnStatus` status202+            "http://httpbin.org/status/201" `shouldReturnStatus` status201+        loadTape tape.file `shouldReturn` [+            ("http://httpbin.org/status/200", "" { responseStatus = status200 })+          , ("http://httpbin.org/status/202", "" { responseStatus = status202 })+          , ("http://httpbin.org/status/201", "" { responseStatus = status201 })+          ]++      context "with repeated requests to a resource" do+        it "records the first request, replays subsequent requests" do+          mockRequestChain [\ _ -> return ""] do+            VCR.with tape do+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+          length <$> loadTape tape.file `shouldReturn` 1++      context "with an existing tape" do+        it "replays existing requests from the tape" do+          mockRequest "http://httpbin.org/status/200" "" do+            VCR.with tape do+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+          disableRequests do+            VCR.with tape do+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+          length <$> loadTape tape.file `shouldReturn` 1++        it "records new requests to the tape" do+            mockRequest "http://httpbin.org/status/200" "" do+              VCR.with tape do+                "http://httpbin.org/status/200" `shouldReturnStatus` status200+            mockRequest "http://httpbin.org/status/201" "" { responseStatus = status201 } do+              VCR.with tape do+                "http://httpbin.org/status/201" `shouldReturnStatus` status201+            length <$> loadTape tape.file `shouldReturn` 2++      context "with concurrent requests" do+        it "records the requests concurrently, without blocking" do+          maybe (expectationFailure "<<timeout>>") return <=< timeout 100_000 . protectRequestAction $ do+            unsafeMockRequest (\ _ -> threadDelay 10_000 >> return "")+            VCR.with tape do+              forConcurrently_ [200 .. 299 :: Int] $ \ status -> do+                "http://httpbin.org/status/" <> show status `shouldReturnBody` ""+          length <$> loadTape tape.file `shouldReturn` 100++      context "on exception" do+        it "writes the tape to disk" do+          mockRequest "http://httpbin.org/status/500" "" { responseStatus = status500 } do+            VCR.with tape (makeRequest "http://httpbin.org/status/500" [])+              `shouldThrow` httpException+          length <$> loadTape tape.file `shouldReturn` 1++      context "with an Authorization header" do+        it "redacts the Authorization header" do+          mockRequest authRequest "" do+            VCR.with tape makeAuthRequest+          loadTape tape.file `shouldReturn` [(redactedAuthRequest, "")]++    context "when mode is Sequential" do+      let tape = "tape.yaml" { mode = Sequential }++      context "with repeated requests to a resource" do+        it "records all interactions" do+          mockRequest "http://httpbin.org/status/200" "" do+            VCR.with tape do+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+          length <$> loadTape tape.file `shouldReturn` 3++      context "with an existing tape" do+        it "replays request in order" do+          mockRequestChain [respondWith status200, respondWith status202, respondWith status201] do+            VCR.with tape do+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+              "http://httpbin.org/status/202" `shouldReturnStatus` status202+              "http://httpbin.org/status/201" `shouldReturnStatus` status201+          disableRequests $ do+            VCR.with tape do+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+              "http://httpbin.org/status/202" `shouldReturnStatus` status202+              "http://httpbin.org/status/201" `shouldReturnStatus` status201+          loadTape tape.file `shouldReturn` [+              ("http://httpbin.org/status/200", "" { responseStatus = status200 })+            , ("http://httpbin.org/status/202", "" { responseStatus = status202 })+            , ("http://httpbin.org/status/201", "" { responseStatus = status201 })+            ]++        context "with an out of order request" do+          it "fails" do+            mockRequestChain [respondWith status200, respondWith status201, respondWith status202] do+              VCR.with tape do+                "http://httpbin.org/status/200" `shouldReturnStatus` status200+                "http://httpbin.org/status/201" `shouldReturnStatus` status201+                "http://httpbin.org/status/202" `shouldReturnStatus` status202+            disableRequests $ do+              VCR.with tape do+                "http://httpbin.org/status/200" `shouldReturnStatus` status200+                "http://httpbin.org/status/202" `shouldReturnStatus` status200+              `shouldThrow`+                  expectedButGot+                    (Request "GET" "http://httpbin.org/status/201" [] "")+                    (Request "GET" "http://httpbin.org/status/202" [] "")++        context "with a missing request" do+          it "fails" do+            mockRequestChain [respondWith status200, respondWith status201, respondWith status202] do+              VCR.with tape do+                "http://httpbin.org/status/200" `shouldReturnStatus` status200+                "http://httpbin.org/status/201" `shouldReturnStatus` status201+                "http://httpbin.org/status/202" `shouldReturnStatus` status202+            disableRequests $ do+              VCR.with tape do+                "http://httpbin.org/status/200" `shouldReturnStatus` status200+                "http://httpbin.org/status/201" `shouldReturnStatus` status201+              `shouldThrow` hUnitFailure (Reason "Expected 3 requests, but only received 2!")++        context "with additional requests" do+          it "records additional requests" do+            mockRequestChain [respondWith status200, respondWith status201, respondWith status202] do+              VCR.with tape do+                "http://httpbin.org/status/200" `shouldReturnStatus` status200+                "http://httpbin.org/status/201" `shouldReturnStatus` status201+              VCR.with tape do+                "http://httpbin.org/status/200" `shouldReturnStatus` status200+                "http://httpbin.org/status/201" `shouldReturnStatus` status201+                "http://httpbin.org/status/202" `shouldReturnStatus` status202+              loadTape tape.file `shouldReturn` [+                  ("http://httpbin.org/status/200", "" { responseStatus = status200 })+                , ("http://httpbin.org/status/201", "" { responseStatus = status201 })+                , ("http://httpbin.org/status/202", "" { responseStatus = status202 })+                ]++      context "on exception" do+        it "writes the tape to disk" do+          mockRequest "http://httpbin.org/status/500" "" { responseStatus = status500 } do+            VCR.with tape (makeRequest "http://httpbin.org/status/500" [])+              `shouldThrow` httpException+          length <$> loadTape tape.file `shouldReturn` 1++      context "with an Authorization header" do+        it "redacts the Authorization header" do+          mockRequest authRequest "" do+            VCR.with tape makeAuthRequest+          loadTape tape.file `shouldReturn` [(redactedAuthRequest, "")]++  describe "record" do+    context "when mode is AnyOrder" do+      let tape = "tape.yaml"++      context "with repeated requests to a resource" do+        it "records only the last interaction" do+          mockRequestChain [\ _ -> return "foo", \ _ -> return "bar", \ _ -> return "baz"] do+            VCR.record tape do+              "http://httpbin.org/status/200" `shouldReturnBody` "foo"+              "http://httpbin.org/status/200" `shouldReturnBody` "bar"+              "http://httpbin.org/status/200" `shouldReturnBody` "baz"+          loadTape tape.file `shouldReturn` [("http://httpbin.org/status/200", "baz")]++      context "with an existing tape" do+        it "records new requests to the tape" do+            mockRequest "http://httpbin.org/status/200" "" do+              VCR.record tape do+                "http://httpbin.org/status/200" `shouldReturnStatus` status200+            mockRequest "http://httpbin.org/status/201" "" { responseStatus = status201 } do+              VCR.record tape do+                "http://httpbin.org/status/201" `shouldReturnStatus` status201+            length <$> loadTape tape.file `shouldReturn` 2++        it "updates existing requests, keeping the original order" do+          mockRequestChain (replicate 3 $ \ _ -> return "") do+            VCR.record tape do+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+              "http://httpbin.org/status/202" `shouldReturnStatus` status200+              "http://httpbin.org/status/201" `shouldReturnStatus` status200++          mockRequestChain [\ _ -> return "foo"] do+            VCR.record tape do+              "http://httpbin.org/status/202" `shouldReturnStatus` status200++          loadTape tape.file `shouldReturn` [+              ("http://httpbin.org/status/200", "")+            , ("http://httpbin.org/status/202", "foo")+            , ("http://httpbin.org/status/201", "")+            ]++    context "when mode is Sequential" do+      let tape = "tape.yaml" { mode = Sequential }++      context "with repeated requests to a resource" do+        it "records all interactions" do+          mockRequest "http://httpbin.org/status/200" "" do+            VCR.with tape do+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+          length <$> loadTape tape.file `shouldReturn` 3++      context "with an existing tape" do+        it "overwrites the existing tape" do+            mockRequest "http://httpbin.org/status/200" "" do+              VCR.record tape do+                "http://httpbin.org/status/200" `shouldReturnStatus` status200+              loadTape tape.file `shouldReturn` [+                  ("http://httpbin.org/status/200", "")+                ]+            mockRequest "http://httpbin.org/status/201" "" { responseStatus = status201 } do+              VCR.record tape do+                "http://httpbin.org/status/201" `shouldReturnStatus` status201+              loadTape tape.file `shouldReturn` [+                  ("http://httpbin.org/status/201", "" { responseStatus = status201 })+                ]++  describe "play" do+    context "when mode is AnyOrder" do+      let tape = "tape.yaml"++      it "replays existing requests from the tape" do+        mockRequest "http://httpbin.org/status/200" "" do+          VCR.record tape do+            "http://httpbin.org/status/200" `shouldReturnStatus` status200+        disableRequests do+          VCR.play tape do+            "http://httpbin.org/status/200" `shouldReturnStatus` status200+        length <$> loadTape tape.file `shouldReturn` 1++      it "fails on new requests" do+          mockRequest "http://httpbin.org/status/200" "" do+            VCR.record tape do+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+          mockRequest "http://httpbin.org/status/201" "" { responseStatus = status201 } do+            VCR.play tape do+              "http://httpbin.org/status/201" `shouldReturnStatus` status201+            `shouldThrow` unexpectedRequest "http://httpbin.org/status/201"++    context "when mode is Sequential" do+      let tape = "tape.yaml" { mode = Sequential }++      it "replays request in order" do+        mockRequestChain [respondWith status200, respondWith status202, respondWith status201] do+          VCR.record tape do+            "http://httpbin.org/status/200" `shouldReturnStatus` status200+            "http://httpbin.org/status/202" `shouldReturnStatus` status202+            "http://httpbin.org/status/201" `shouldReturnStatus` status201+        disableRequests $ do+          VCR.play tape do+            "http://httpbin.org/status/200" `shouldReturnStatus` status200+            "http://httpbin.org/status/202" `shouldReturnStatus` status202+            "http://httpbin.org/status/201" `shouldReturnStatus` status201++      context "when not all requests are used" do+          it "fails" do+            mockRequest "http://httpbin.org/status/200" "" do+              VCR.record tape do+                "http://httpbin.org/status/200" `shouldReturnStatus` status200+                "http://httpbin.org/status/200" `shouldReturnStatus` status200+            VCR.play tape do "http://httpbin.org/status/200" `shouldReturnStatus` status200+              `shouldThrow` hUnitFailure (Reason "Expected 2 requests, but only received 1!")++      context "with additional requests" do+        it "fails" do+          mockRequest "http://httpbin.org/status/200" "" do+            VCR.record tape do+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+          mockRequestChain [\ _ -> return ""] do+            VCR.play tape do+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+              "http://httpbin.org/status/200" `shouldReturnStatus` status200+            `shouldThrow` unexpectedRequest "http://httpbin.org/status/200"
+ test/WebMock/UtilSpec.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}+module WebMock.UtilSpec (spec) where++import Imports++import Test.Hspec+import Test.Mockery.Directory++import Data.ByteString.Lazy.Char8 qualified as L+import Data.ByteString.Lazy.Internal (defaultChunkSize)+import Network.HTTP.Client++import WebMock.Util++spec :: Spec+spec = around_ inTempDirectory do+  describe "requestBodyToByteString" do+    describe "with RequestBodyLBS" do+      it "converts it to a ByteString" do+        requestBodyToByteString (RequestBodyLBS "foo") `shouldReturn` "foo"++    describe "with RequestBodyBS" do+      it "converts it to a ByteString" do+        requestBodyToByteString (RequestBodyBS "foo") `shouldReturn` "foo"++    describe "with RequestBodyBuilder" do+      it "converts it to a ByteString" do+        requestBodyToByteString (RequestBodyBuilder 3 "foo") `shouldReturn` "foo"++      context "with wrong length" do+        it "throws an exception" do+          requestBodyToByteString (RequestBodyBuilder 5 "foo") `shouldThrow` anyException++    let file = "test.txt"+    let expected = L.fromChunks $ replicate defaultChunkSize $ "foobar"+    before_ (L.writeFile file expected) do+      context "with RequestBodyStream" do+        it "converts it to a ByteString" do+          body@(RequestBodyStream _ _) <- streamFile file+          requestBodyToByteString body `shouldReturn` expected++        context "with wrong length" do+          it "throws an exception" do+            RequestBodyStream n body <- streamFile file+            requestBodyToByteString (RequestBodyStream (pred n) body) `shouldThrow` anyException++      context "with RequestBodyStreamChunked" do+        it "converts it to a ByteString" do+          (RequestBodyStream _ body) <- streamFile file+          requestBodyToByteString (RequestBodyStreamChunked body) `shouldReturn` expected
+ vcr.cabal view
@@ -0,0 +1,120 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.0.+--+-- see: https://github.com/sol/hpack++name:           vcr+version:        0.0.0+synopsis:       Record and replay HTTP interactions+category:       Testing+homepage:       https://github.com/assertible/vcr#readme+bug-reports:    https://github.com/assertible/vcr/issues+maintainer:     Simon Hengel <sol@typeful.net>+license:        MIT+license-file:   LICENSE+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/assertible/vcr++library+  exposed-modules:+      Imports+      VCR+      VCR.Serialize+      WebMock+      WebMock.Util+  other-modules:+      Paths_vcr+  hs-source-dirs:+      src+  default-extensions:+      BlockArguments+      NoImplicitPrelude+  ghc-options: -Wall+  build-depends:+      HUnit+    , async+    , base ==4.*+    , bytestring+    , case-insensitive+    , containers+    , directory+    , filepath+    , http-client >=0.7.19+    , http-types+    , network-uri+    , text+    , yaml+  default-language: GHC2021+  if impl(ghc < 9.10)+    default-extensions:+        DataKinds+        DerivingStrategies+        DisambiguateRecordFields+        ExplicitNamespaces+        GADTs+        MonoLocalBinds+        LambdaCase+        RoleAnnotations+  else+    default-language: GHC2024+  if impl(ghc < 9.4)+    ghc-options: -Wno-unticked-promoted-constructors++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Imports+      VCR+      VCR.Serialize+      WebMock+      WebMock.Util+      VCRSpec+      WebMock.UtilSpec+      Paths_vcr+  hs-source-dirs:+      src+      test+  default-extensions:+      BlockArguments+      NoImplicitPrelude+  ghc-options: -Wall+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      HUnit+    , async+    , base ==4.*+    , bytestring+    , case-insensitive+    , containers+    , directory+    , filepath+    , hspec+    , http-client >=0.7.19+    , http-client-tls+    , http-conduit+    , http-types+    , mockery+    , network-uri+    , text+    , yaml+  default-language: GHC2021+  if impl(ghc < 9.10)+    default-extensions:+        DataKinds+        DerivingStrategies+        DisambiguateRecordFields+        ExplicitNamespaces+        GADTs+        MonoLocalBinds+        LambdaCase+        RoleAnnotations+  else+    default-language: GHC2024+  if impl(ghc < 9.4)+    ghc-options: -Wno-unticked-promoted-constructors