diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/src/Imports.hs b/src/Imports.hs new file mode 100644 --- /dev/null +++ b/src/Imports.hs @@ -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 () diff --git a/src/VCR.hs b/src/VCR.hs new file mode 100644 --- /dev/null +++ b/src/VCR.hs @@ -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 diff --git a/src/VCR/Serialize.hs b/src/VCR/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/VCR/Serialize.hs @@ -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") diff --git a/src/WebMock.hs b/src/WebMock.hs new file mode 100644 --- /dev/null +++ b/src/WebMock.hs @@ -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 + } diff --git a/src/WebMock/Util.hs b/src/WebMock/Util.hs new file mode 100644 --- /dev/null +++ b/src/WebMock/Util.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-discover #-} diff --git a/test/VCRSpec.hs b/test/VCRSpec.hs new file mode 100644 --- /dev/null +++ b/test/VCRSpec.hs @@ -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 "<>") 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" diff --git a/test/WebMock/UtilSpec.hs b/test/WebMock/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/WebMock/UtilSpec.hs @@ -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 diff --git a/vcr.cabal b/vcr.cabal new file mode 100644 --- /dev/null +++ b/vcr.cabal @@ -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 +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