{-# 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 {
  Request -> Method
requestMethod  :: Method
, Request -> String
requestUrl     :: String
, Request -> ResponseHeaders
requestHeaders :: RequestHeaders
, Request -> LazyByteString
requestBody    :: LazyByteString
} deriving (Request -> Request -> Bool
(Request -> Request -> Bool)
-> (Request -> Request -> Bool) -> Eq Request
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Request -> Request -> Bool
== :: Request -> Request -> Bool
$c/= :: Request -> Request -> Bool
/= :: Request -> Request -> Bool
Eq, Eq Request
Eq Request =>
(Request -> Request -> Ordering)
-> (Request -> Request -> Bool)
-> (Request -> Request -> Bool)
-> (Request -> Request -> Bool)
-> (Request -> Request -> Bool)
-> (Request -> Request -> Request)
-> (Request -> Request -> Request)
-> Ord Request
Request -> Request -> Bool
Request -> Request -> Ordering
Request -> Request -> Request
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 :: Request -> Request -> Ordering
compare :: Request -> Request -> Ordering
$c< :: Request -> Request -> Bool
< :: Request -> Request -> Bool
$c<= :: Request -> Request -> Bool
<= :: Request -> Request -> Bool
$c> :: Request -> Request -> Bool
> :: Request -> Request -> Bool
$c>= :: Request -> Request -> Bool
>= :: Request -> Request -> Bool
$cmax :: Request -> Request -> Request
max :: Request -> Request -> Request
$cmin :: Request -> Request -> Request
min :: Request -> Request -> Request
Ord)

instance IsString Request where
  fromString :: String -> Request
fromString String
url = Method -> String -> ResponseHeaders -> LazyByteString -> Request
Request Method
"GET" String
url [] LazyByteString
""

instance Show Request where
  show :: Request -> String
show Request{String
ResponseHeaders
LazyByteString
Method
requestMethod :: Request -> Method
requestUrl :: Request -> String
requestHeaders :: Request -> ResponseHeaders
requestBody :: Request -> LazyByteString
requestMethod :: Method
requestUrl :: String
requestHeaders :: ResponseHeaders
requestBody :: LazyByteString
..} = [String] -> String
unlines [
      String
"Request {"
    , String
"  requestMethod = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Method -> String
forall a. Show a => a -> String
show Method
requestMethod
    , String
", requestUrl = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
requestUrl
    , String
", requestHeaders = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ResponseHeaders -> String
forall a. Show a => a -> String
show ResponseHeaders
requestHeaders
    , String
", requestBody = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ LazyByteString -> String
forall a. Show a => a -> String
show LazyByteString
requestBody
    , String
"}"
    ]

data Response = Response {
  Response -> Status
responseStatus  :: Status
, Response -> ResponseHeaders
responseHeaders :: ResponseHeaders
, Response -> LazyByteString
responseBody    :: LazyByteString
} deriving (Response -> Response -> Bool
(Response -> Response -> Bool)
-> (Response -> Response -> Bool) -> Eq Response
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Response -> Response -> Bool
== :: Response -> Response -> Bool
$c/= :: Response -> Response -> Bool
/= :: Response -> Response -> Bool
Eq, Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
(Int -> Response -> ShowS)
-> (Response -> String) -> ([Response] -> ShowS) -> Show Response
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Response -> ShowS
showsPrec :: Int -> Response -> ShowS
$cshow :: Response -> String
show :: Response -> String
$cshowList :: [Response] -> ShowS
showList :: [Response] -> ShowS
Show)

instance IsString Response where
  fromString :: String -> Response
fromString String
body = Status -> ResponseHeaders -> LazyByteString -> Response
Response Status
status200 [] (Method -> LazyByteString
L.fromStrict (Method -> LazyByteString) -> Method -> LazyByteString
forall a b. (a -> b) -> a -> b
$ Text -> Method
encodeUtf8 (Text -> Method) -> Text -> Method
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
body)

unsafeMockRequest :: (Request -> IO Response) -> IO ()
unsafeMockRequest :: (Request -> IO Response) -> IO ()
unsafeMockRequest Request -> IO Response
f = IORef (Request -> Manager -> IO (Response BodyReader))
-> (Request -> Manager -> IO (Response BodyReader)) -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef (Request -> Manager -> IO (Response BodyReader))
Client.requestAction Request -> Manager -> IO (Response BodyReader)
requestAction
  where
    requestAction :: RequestAction
    requestAction :: Request -> Manager -> IO (Response BodyReader)
requestAction Request
request Manager
_manager = do
      Request -> IO Request
toSimpleRequest Request
request IO Request -> (Request -> IO Response) -> IO Response
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO Response
f IO Response
-> (Response -> IO (Response BodyReader))
-> IO (Response BodyReader)
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 (Response BodyReader)
fromSimpleResponse Request
request

mockRequest :: HasCallStack => Request -> Response -> IO a -> IO a
mockRequest :: forall a. HasCallStack => Request -> Response -> IO a -> IO a
mockRequest Request
expectedRequest Response
response IO a
action = IO a -> IO a
forall a. IO a -> IO a
protectRequestAction do
  (Request -> IO Response) -> IO ()
unsafeMockRequest \ Request
request -> do
    Request
request Request -> Request -> IO ()
forall a. (HasCallStack, Eq a, Show a) => a -> a -> IO ()
@?= Request
expectedRequest
    Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Response
response
  IO a
action

disableRequests :: HasCallStack => IO a -> IO a
disableRequests :: forall a. HasCallStack => IO a -> IO a
disableRequests IO a
action = do
  let
    requestAction :: IO Response -> Request -> IO Response
    requestAction :: IO Response -> Request -> IO Response
requestAction IO Response
_makeRequest Request
request = do
      Request -> IO Response
forall a. HasCallStack => Request -> IO a
unexpectedRequest Request
request
  (IO Response -> Request -> IO Response) -> IO a -> IO a
forall a. (IO Response -> Request -> IO Response) -> IO a -> IO a
withRequestAction IO Response -> Request -> IO Response
requestAction IO a
action

mockRequestChain :: HasCallStack => [Request -> IO Response] -> IO a -> IO a
mockRequestChain :: forall a. HasCallStack => [Request -> IO Response] -> IO a -> IO a
mockRequestChain [Request -> IO Response]
interactions IO a
action = do
  IORef [Request -> IO Response]
ref <- [Request -> IO Response] -> IO (IORef [Request -> IO Response])
forall a. a -> IO (IORef a)
newIORef [Request -> IO Response]
interactions

  let
    requestAction :: IO Response -> Request -> IO Response
    requestAction :: IO Response -> Request -> IO Response
requestAction IO Response
_makeRequest Request
request = do
      IORef [Request -> IO Response]
-> ([Request -> IO Response]
    -> ([Request -> IO Response], Maybe (Request -> IO Response)))
-> IO (Maybe (Request -> IO Response))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Request -> IO Response]
ref (Int -> [Request -> IO Response] -> [Request -> IO Response]
forall a. Int -> [a] -> [a]
drop Int
1 ([Request -> IO Response] -> [Request -> IO Response])
-> ([Request -> IO Response] -> Maybe (Request -> IO Response))
-> [Request -> IO Response]
-> ([Request -> IO Response], Maybe (Request -> IO Response))
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [Request -> IO Response] -> Maybe (Request -> IO Response)
forall a. [a] -> Maybe a
listToMaybe) IO (Maybe (Request -> IO Response))
-> (Maybe (Request -> IO Response) -> IO Response) -> IO Response
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
        Just Request -> IO Response
interaction -> Request -> IO Response
interaction Request
request
        Maybe (Request -> IO Response)
Nothing -> Request -> IO Response
forall a. HasCallStack => Request -> IO a
unexpectedRequest Request
request

    checkLeftover :: IO ()
    checkLeftover :: IO ()
checkLeftover = do
      Int
leftover <- [Request -> IO Response] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Request -> IO Response] -> Int)
-> IO [Request -> IO Response] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [Request -> IO Response] -> IO [Request -> IO Response]
forall a. IORef a -> IO a
atomicReadIORef IORef [Request -> IO Response]
ref
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
leftover Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) do
        let
          total :: Int
total = [Request -> IO Response] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Request -> IO Response]
interactions
          actual :: Int
actual = Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
leftover
        String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
total String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" requests, but only received " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
actual String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"!"

  (IO Response -> Request -> IO Response) -> IO a -> IO a
forall a. (IO Response -> Request -> IO Response) -> IO a -> IO a
withRequestAction IO Response -> Request -> IO Response
requestAction IO a
action IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* IO ()
checkLeftover

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

mkRequestActions :: HasCallStack => [(Request, Response)] -> [Request -> IO Response]
mkRequestActions :: HasCallStack => [(Request, Response)] -> [Request -> IO Response]
mkRequestActions = ((Request, Response) -> Request -> IO Response)
-> [(Request, Response)] -> [Request -> IO Response]
forall a b. (a -> b) -> [a] -> [b]
map ((Request -> Response -> Request -> IO Response)
-> (Request, Response) -> Request -> IO Response
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack => Request -> Response -> Request -> IO Response
Request -> Response -> Request -> IO Response
mkRequestAction)

mkRequestAction :: HasCallStack => Request -> Response -> Request -> IO Response
mkRequestAction :: HasCallStack => Request -> Response -> Request -> IO Response
mkRequestAction Request
expected Response
response Request
actual = do
  Request
actual Request -> Request -> IO ()
forall a. (HasCallStack, Eq a, Show a) => a -> a -> IO ()
@?= Request
expected
  Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Response
response

type RequestAction = Client.Request -> Manager -> IO (Client.Response BodyReader)

withRequestAction :: (IO Response -> Request -> IO Response) -> IO a -> IO a
withRequestAction :: forall a. (IO Response -> Request -> IO Response) -> IO a -> IO a
withRequestAction IO Response -> Request -> IO Response
action = IO (Request -> Manager -> IO (Response BodyReader))
-> ((Request -> Manager -> IO (Response BodyReader)) -> IO ())
-> ((Request -> Manager -> IO (Response BodyReader)) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Request -> Manager -> IO (Response BodyReader))
setup (Request -> Manager -> IO (Response BodyReader)) -> IO ()
restore (((Request -> Manager -> IO (Response BodyReader)) -> IO a)
 -> IO a)
-> (IO a
    -> (Request -> Manager -> IO (Response BodyReader)) -> IO a)
-> IO a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> (Request -> Manager -> IO (Response BodyReader)) -> IO a
forall a b. a -> b -> a
const
  where
    lift :: RequestAction -> RequestAction
    lift :: (Request -> Manager -> IO (Response BodyReader))
-> Request -> Manager -> IO (Response BodyReader)
lift Request -> Manager -> IO (Response BodyReader)
makeClientRequest Request
request Manager
manager = do
      Request -> IO Request
toSimpleRequest Request
request IO Request -> (Request -> IO Response) -> IO Response
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO Response
makeRequest IO Response
-> (Response -> IO (Response BodyReader))
-> IO (Response BodyReader)
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 (Response BodyReader)
fromSimpleResponse Request
request
      where
        makeRequest :: Request -> IO Response
        makeRequest :: Request -> IO Response
makeRequest = IO Response -> Request -> IO Response
action (IO Response -> Request -> IO Response)
-> IO Response -> Request -> IO Response
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response BodyReader)
makeClientRequest Request
request Manager
manager IO (Response BodyReader)
-> (Response BodyReader -> IO Response) -> IO Response
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response BodyReader -> IO Response
toSimpleResponse

    setup :: IO RequestAction
    setup :: IO (Request -> Manager -> IO (Response BodyReader))
setup = IORef (Request -> Manager -> IO (Response BodyReader))
-> ((Request -> Manager -> IO (Response BodyReader))
    -> (Request -> Manager -> IO (Response BodyReader),
        Request -> Manager -> IO (Response BodyReader)))
-> IO (Request -> Manager -> IO (Response BodyReader))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Request -> Manager -> IO (Response BodyReader))
Client.requestAction \ Request -> Manager -> IO (Response BodyReader)
old -> ((Request -> Manager -> IO (Response BodyReader))
-> Request -> Manager -> IO (Response BodyReader)
lift Request -> Manager -> IO (Response BodyReader)
old, Request -> Manager -> IO (Response BodyReader)
old)

    restore :: RequestAction -> IO ()
    restore :: (Request -> Manager -> IO (Response BodyReader)) -> IO ()
restore = IORef (Request -> Manager -> IO (Response BodyReader))
-> (Request -> Manager -> IO (Response BodyReader)) -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef (Request -> Manager -> IO (Response BodyReader))
Client.requestAction

protectRequestAction :: IO a -> IO a
protectRequestAction :: forall a. IO a -> IO a
protectRequestAction = IO (Request -> Manager -> IO (Response BodyReader))
-> ((Request -> Manager -> IO (Response BodyReader)) -> IO ())
-> ((Request -> Manager -> IO (Response BodyReader)) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Request -> Manager -> IO (Response BodyReader))
save (Request -> Manager -> IO (Response BodyReader)) -> IO ()
restore (((Request -> Manager -> IO (Response BodyReader)) -> IO a)
 -> IO a)
-> (IO a
    -> (Request -> Manager -> IO (Response BodyReader)) -> IO a)
-> IO a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> (Request -> Manager -> IO (Response BodyReader)) -> IO a
forall a b. a -> b -> a
const
  where
    save :: IO RequestAction
    save :: IO (Request -> Manager -> IO (Response BodyReader))
save = IORef (Request -> Manager -> IO (Response BodyReader))
-> IO (Request -> Manager -> IO (Response BodyReader))
forall a. IORef a -> IO a
atomicReadIORef IORef (Request -> Manager -> IO (Response BodyReader))
Client.requestAction

    restore :: RequestAction -> IO ()
    restore :: (Request -> Manager -> IO (Response BodyReader)) -> IO ()
restore = IORef (Request -> Manager -> IO (Response BodyReader))
-> (Request -> Manager -> IO (Response BodyReader)) -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef (Request -> Manager -> IO (Response BodyReader))
Client.requestAction

toSimpleRequest :: Client.Request -> IO Request
toSimpleRequest :: Request -> IO Request
toSimpleRequest Request
r = do
  LazyByteString
body <- RequestBody -> IO LazyByteString
requestBodyToByteString (Request -> RequestBody
Client.requestBody Request
r)
  Request -> IO Request
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ Request {
    requestMethod :: Method
requestMethod = Request -> Method
Client.method Request
r
  , requestUrl :: String
requestUrl = ShowS -> URI -> ShowS
uriToString ShowS
forall a. a -> a
id (Request -> URI
Client.getUri Request
r) String
""
  , requestHeaders :: ResponseHeaders
requestHeaders = Request -> ResponseHeaders
Client.requestHeaders Request
r
  , requestBody :: LazyByteString
requestBody = LazyByteString
body
  }

toSimpleResponse :: Client.Response BodyReader -> IO Response
toSimpleResponse :: Response BodyReader -> IO Response
toSimpleResponse Response BodyReader
r = do
  [Method]
c <- BodyReader -> IO [Method]
Client.brConsume (Response BodyReader -> BodyReader
forall body. Response body -> body
Client.responseBody Response BodyReader
r)
  Response BodyReader -> IO ()
forall a. Response a -> IO ()
Client.responseClose Response BodyReader
r
  Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Response {
    responseStatus :: Status
responseStatus = Response BodyReader -> Status
forall body. Response body -> Status
Client.responseStatus Response BodyReader
r
  , responseHeaders :: ResponseHeaders
responseHeaders = Response BodyReader -> ResponseHeaders
forall body. Response body -> ResponseHeaders
Client.responseHeaders Response BodyReader
r
  , responseBody :: LazyByteString
responseBody = [Method] -> LazyByteString
L.fromChunks [Method]
c
  }

fromSimpleResponse :: Client.Request -> Response -> IO (Client.Response BodyReader)
fromSimpleResponse :: Request -> Response -> IO (Response BodyReader)
fromSimpleResponse Request
request Response{ResponseHeaders
LazyByteString
Status
responseStatus :: Response -> Status
responseHeaders :: Response -> ResponseHeaders
responseBody :: Response -> LazyByteString
responseStatus :: Status
responseHeaders :: ResponseHeaders
responseBody :: LazyByteString
..} = do
  BodyReader
body <- [Method] -> IO BodyReader
Client.constBodyReader (LazyByteString -> [Method]
L.toChunks LazyByteString
responseBody)
  Response BodyReader -> IO (Response BodyReader)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response BodyReader -> IO (Response BodyReader))
-> Response BodyReader -> IO (Response BodyReader)
forall a b. (a -> b) -> a -> b
$ Client.Response {
    responseStatus :: Status
Client.responseStatus = Status
responseStatus
  , responseVersion :: HttpVersion
Client.responseVersion = HttpVersion
http11
  , responseHeaders :: ResponseHeaders
Client.responseHeaders = ResponseHeaders
responseHeaders
  , responseBody :: BodyReader
Client.responseBody = BodyReader
body
  , responseCookieJar :: CookieJar
Client.responseCookieJar = CookieJar
forall a. Monoid a => a
mempty
  , responseClose' :: ResponseClose
Client.responseClose' = IO () -> ResponseClose
Client.ResponseClose IO ()
forall (m :: * -> *). Applicative m => m ()
pass
  , responseOriginalRequest :: Request
Client.responseOriginalRequest = Request
request { Client.requestBody = mempty }
  , responseEarlyHints :: ResponseHeaders
Client.responseEarlyHints = ResponseHeaders
forall a. Monoid a => a
mempty
  }