{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoFieldSelectors #-}

-- | Implements stubbing of an HTTP request function
module Freckle.App.Test.Http
  ( -- $docs
    httpStubbed

    -- * Defining stubs
  , HttpStub (..)
  , httpStub
  , httpStubUrl

    -- * Stub modifiers
  , labelL
  , MatchRequest (..)
  , matchL

    -- * Response modifiers
  , statusL
  , headersL
  , bodyL

    -- * Response helpers
  , json

    -- * FileSystem stubs
  , loadHttpStubsDirectory

    -- * 'MonadHttp' instances

    -- ** For use with @DerivingVia@
  , HasHttpStubs (..)
  , ReaderHttpStubs (..)

    -- ** Concrete transformer
  , HttpStubsT
  , runHttpStubsT
  ) where

import Freckle.App.Prelude

import Control.Lens (Lens', lens, view, (&), (.~), (<>~))
import Control.Monad (filterM)
import Control.Monad.Reader (runReaderT)
import Data.Aeson (ToJSON, encode)
import qualified Data.ByteString.Lazy as BSL
import Data.List (stripPrefix)
import Data.String (IsString (..))
import Freckle.App.Http (MonadHttp (..))
import Freckle.App.Test.Http.MatchRequest
import Network.HTTP.Client (Request, Response)
import qualified Network.HTTP.Client.Internal as HTTP
import Network.HTTP.Types.Header (ResponseHeaders, hAccept, hContentType)
import Network.HTTP.Types.Status (Status, status200)
import System.Directory (doesFileExist)
import System.FilePath (addTrailingPathSeparator)
import System.FilePath.Glob (globDir1)

-- | Respond to a 'Request' with the first 'HttpStub' to match
--
-- If no stubs match, 'error' is used. If you'd rather experience a 404, add
-- a final stub for any request that does that:
--
-- @
-- stubs :: ['HttpStub']
-- stubs =
--   [ -- ...
--   , -- ...
--   , 'httpStub' \"Anything\" 'MatchAnything'
--       & 'statusL' .~ 'status404'
--       & 'bodyL' .~ \"Not found\"
--   ]
-- @
httpStubbed
  :: HasCallStack
  => [HttpStub]
  -> Request
  -> Response BSL.ByteString
httpStubbed :: HasCallStack => [HttpStub] -> Request -> Response ByteString
httpStubbed [HttpStub]
stubs Request
req =
  Response ByteString
-> (HttpStubResponse -> Response ByteString)
-> Maybe HttpStubResponse
-> Response ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Response ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
errorMessage) (Request -> HttpStubResponse -> Response ByteString
toResponse Request
req) (Maybe HttpStubResponse -> Response ByteString)
-> Maybe HttpStubResponse -> Response ByteString
forall a b. (a -> b) -> a -> b
$ [HttpStubResponse] -> Maybe HttpStubResponse
forall a. [a] -> Maybe a
headMay [HttpStubResponse]
matched
 where
  ([(HttpStub, [Char])]
unmatched, [HttpStubResponse]
matched) =
    [Either (HttpStub, [Char]) HttpStubResponse]
-> ([(HttpStub, [Char])], [HttpStubResponse])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (HttpStub, [Char]) HttpStubResponse]
 -> ([(HttpStub, [Char])], [HttpStubResponse]))
-> [Either (HttpStub, [Char]) HttpStubResponse]
-> ([(HttpStub, [Char])], [HttpStubResponse])
forall a b. (a -> b) -> a -> b
$
      (HttpStub -> Either (HttpStub, [Char]) HttpStubResponse)
-> [HttpStub] -> [Either (HttpStub, [Char]) HttpStubResponse]
forall a b. (a -> b) -> [a] -> [b]
map
        ( \HttpStub
stub ->
            ([Char] -> (HttpStub, [Char]))
-> (() -> HttpStubResponse)
-> Either [Char] ()
-> Either (HttpStub, [Char]) HttpStubResponse
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (HttpStub
stub,) (HttpStubResponse -> () -> HttpStubResponse
forall a b. a -> b -> a
const HttpStub
stub.response) (Either [Char] () -> Either (HttpStub, [Char]) HttpStubResponse)
-> Either [Char] () -> Either (HttpStub, [Char]) HttpStubResponse
forall a b. (a -> b) -> a -> b
$
              Request -> MatchRequest -> Either [Char] ()
matchRequest Request
req HttpStub
stub.match
        )
        [HttpStub]
stubs

  errorMessage :: [Char]
errorMessage =
    [Char]
"No stubs were found that matched:\n"
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Request -> [Char]
forall a. Show a => a -> [Char]
show Request
req
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n"
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ((HttpStub, [Char]) -> [Char]) -> [(HttpStub, [Char])] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((HttpStub -> [Char] -> [Char]) -> (HttpStub, [Char]) -> [Char]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HttpStub -> [Char] -> [Char]
forall {a} {r}.
(Semigroup a, IsString a, HasField "label" r a) =>
r -> a -> a
unmatchedMessage) [(HttpStub, [Char])]
unmatched

  unmatchedMessage :: r -> a -> a
unmatchedMessage r
stub a
err = a
"\n== " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> r
stub.label a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" ==\n" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
err

-- | Fields that can be defined for a response
data HttpStubResponse = HttpStubResponse
  { HttpStubResponse -> Status
status :: Status
  , HttpStubResponse -> ResponseHeaders
headers :: ResponseHeaders
  , HttpStubResponse -> ByteString
body :: BSL.ByteString
  }

toResponse :: Request -> HttpStubResponse -> Response BSL.ByteString
toResponse :: Request -> HttpStubResponse -> Response ByteString
toResponse Request
req HttpStubResponse
stub =
  HTTP.Response
    { responseStatus :: Status
HTTP.responseStatus = HttpStubResponse
stub.status
    , responseVersion :: HttpVersion
HTTP.responseVersion = Request -> HttpVersion
HTTP.requestVersion Request
req
    , responseHeaders :: ResponseHeaders
HTTP.responseHeaders = HttpStubResponse
stub.headers
    , responseBody :: ByteString
HTTP.responseBody = HttpStubResponse
stub.body
    , responseCookieJar :: CookieJar
HTTP.responseCookieJar = CookieJar
forall a. Monoid a => a
mempty
    , responseClose' :: ResponseClose
HTTP.responseClose' = IO () -> ResponseClose
HTTP.ResponseClose (IO () -> ResponseClose) -> IO () -> ResponseClose
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , responseOriginalRequest :: Request
HTTP.responseOriginalRequest = Request
req
#if MIN_VERSION_http_client(0,7,16)
    , responseEarlyHints :: ResponseHeaders
HTTP.responseEarlyHints = []
#endif
    }

rstatusL :: Lens' HttpStubResponse Status
rstatusL :: Lens' HttpStubResponse Status
rstatusL = (HttpStubResponse -> Status)
-> (HttpStubResponse -> Status -> HttpStubResponse)
-> Lens' HttpStubResponse Status
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (.status) ((HttpStubResponse -> Status -> HttpStubResponse)
 -> Lens' HttpStubResponse Status)
-> (HttpStubResponse -> Status -> HttpStubResponse)
-> Lens' HttpStubResponse Status
forall a b. (a -> b) -> a -> b
$ \HttpStubResponse
x Status
y -> HttpStubResponse
x {status = y}

rheadersL :: Lens' HttpStubResponse ResponseHeaders
rheadersL :: Lens' HttpStubResponse ResponseHeaders
rheadersL = (HttpStubResponse -> ResponseHeaders)
-> (HttpStubResponse -> ResponseHeaders -> HttpStubResponse)
-> Lens' HttpStubResponse ResponseHeaders
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (.headers) ((HttpStubResponse -> ResponseHeaders -> HttpStubResponse)
 -> Lens' HttpStubResponse ResponseHeaders)
-> (HttpStubResponse -> ResponseHeaders -> HttpStubResponse)
-> Lens' HttpStubResponse ResponseHeaders
forall a b. (a -> b) -> a -> b
$ \HttpStubResponse
x ResponseHeaders
y -> HttpStubResponse
x {headers = y}

rbodyL :: Lens' HttpStubResponse BSL.ByteString
rbodyL :: Lens' HttpStubResponse ByteString
rbodyL = (HttpStubResponse -> ByteString)
-> (HttpStubResponse -> ByteString -> HttpStubResponse)
-> Lens' HttpStubResponse ByteString
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (.body) ((HttpStubResponse -> ByteString -> HttpStubResponse)
 -> Lens' HttpStubResponse ByteString)
-> (HttpStubResponse -> ByteString -> HttpStubResponse)
-> Lens' HttpStubResponse ByteString
forall a b. (a -> b) -> a -> b
$ \HttpStubResponse
x ByteString
y -> HttpStubResponse
x {body = y}

data HttpStub = HttpStub
  { HttpStub -> [Char]
label :: String
  , HttpStub -> MatchRequest
match :: MatchRequest
  , HttpStub -> HttpStubResponse
response :: HttpStubResponse
  }

instance IsString HttpStub where
  fromString :: [Char] -> HttpStub
fromString = [Char] -> HttpStub
httpStubUrl

labelL :: Lens' HttpStub String
labelL :: Lens' HttpStub [Char]
labelL = (HttpStub -> [Char])
-> (HttpStub -> [Char] -> HttpStub) -> Lens' HttpStub [Char]
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (.label) ((HttpStub -> [Char] -> HttpStub) -> Lens' HttpStub [Char])
-> (HttpStub -> [Char] -> HttpStub) -> Lens' HttpStub [Char]
forall a b. (a -> b) -> a -> b
$ \HttpStub
x [Char]
y -> HttpStub
x {label = y}

matchL :: Lens' HttpStub MatchRequest
matchL :: Lens' HttpStub MatchRequest
matchL = (HttpStub -> MatchRequest)
-> (HttpStub -> MatchRequest -> HttpStub)
-> Lens' HttpStub MatchRequest
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (.match) ((HttpStub -> MatchRequest -> HttpStub)
 -> Lens' HttpStub MatchRequest)
-> (HttpStub -> MatchRequest -> HttpStub)
-> Lens' HttpStub MatchRequest
forall a b. (a -> b) -> a -> b
$ \HttpStub
x MatchRequest
y -> HttpStub
x {match = y}

responseL :: Lens' HttpStub HttpStubResponse
responseL :: Lens' HttpStub HttpStubResponse
responseL = (HttpStub -> HttpStubResponse)
-> (HttpStub -> HttpStubResponse -> HttpStub)
-> Lens' HttpStub HttpStubResponse
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (.response) ((HttpStub -> HttpStubResponse -> HttpStub)
 -> Lens' HttpStub HttpStubResponse)
-> (HttpStub -> HttpStubResponse -> HttpStub)
-> Lens' HttpStub HttpStubResponse
forall a b. (a -> b) -> a -> b
$ \HttpStub
x HttpStubResponse
y -> HttpStub
x {response = y}

-- | Respond 200 with empty body for matching requests
httpStub :: String -> MatchRequest -> HttpStub
httpStub :: [Char] -> MatchRequest -> HttpStub
httpStub [Char]
label MatchRequest
match = HttpStub {[Char]
$sel:label:HttpStub :: [Char]
label :: [Char]
label, MatchRequest
$sel:match:HttpStub :: MatchRequest
match :: MatchRequest
match, HttpStubResponse
$sel:response:HttpStub :: HttpStubResponse
response :: HttpStubResponse
response}
 where
  response :: HttpStubResponse
response =
    HttpStubResponse
      { $sel:status:HttpStubResponse :: Status
status = Status
status200
      , $sel:headers:HttpStubResponse :: ResponseHeaders
headers = []
      , $sel:body:HttpStubResponse :: ByteString
body = ByteString
""
      }

-- | Respond 200 with empty body for requests parsed from the given URL
httpStubUrl :: String -> HttpStub
httpStubUrl :: [Char] -> HttpStub
httpStubUrl [Char]
url = [Char] -> MatchRequest -> HttpStub
httpStub [Char]
url (MatchRequest -> HttpStub) -> MatchRequest -> HttpStub
forall a b. (a -> b) -> a -> b
$ [Char] -> MatchRequest
matchRequestFromUrl [Char]
url

statusL :: Lens' HttpStub Status
statusL :: Lens' HttpStub Status
statusL = (HttpStubResponse -> f HttpStubResponse) -> HttpStub -> f HttpStub
Lens' HttpStub HttpStubResponse
responseL ((HttpStubResponse -> f HttpStubResponse)
 -> HttpStub -> f HttpStub)
-> ((Status -> f Status) -> HttpStubResponse -> f HttpStubResponse)
-> (Status -> f Status)
-> HttpStub
-> f HttpStub
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Status -> f Status) -> HttpStubResponse -> f HttpStubResponse
Lens' HttpStubResponse Status
rstatusL

headersL :: Lens' HttpStub ResponseHeaders
headersL :: Lens' HttpStub ResponseHeaders
headersL = (HttpStubResponse -> f HttpStubResponse) -> HttpStub -> f HttpStub
Lens' HttpStub HttpStubResponse
responseL ((HttpStubResponse -> f HttpStubResponse)
 -> HttpStub -> f HttpStub)
-> ((ResponseHeaders -> f ResponseHeaders)
    -> HttpStubResponse -> f HttpStubResponse)
-> (ResponseHeaders -> f ResponseHeaders)
-> HttpStub
-> f HttpStub
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResponseHeaders -> f ResponseHeaders)
-> HttpStubResponse -> f HttpStubResponse
Lens' HttpStubResponse ResponseHeaders
rheadersL

bodyL :: Lens' HttpStub BSL.ByteString
bodyL :: Lens' HttpStub ByteString
bodyL = (HttpStubResponse -> f HttpStubResponse) -> HttpStub -> f HttpStub
Lens' HttpStub HttpStubResponse
responseL ((HttpStubResponse -> f HttpStubResponse)
 -> HttpStub -> f HttpStub)
-> ((ByteString -> f ByteString)
    -> HttpStubResponse -> f HttpStubResponse)
-> (ByteString -> f ByteString)
-> HttpStub
-> f HttpStub
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> f ByteString)
-> HttpStubResponse -> f HttpStubResponse
Lens' HttpStubResponse ByteString
rbodyL

-- | Modify the stub to match JSON requests and respond with the given value
json :: ToJSON a => a -> HttpStub -> HttpStub
json :: forall a. ToJSON a => a -> HttpStub -> HttpStub
json a
a HttpStub
stub =
  HttpStub
stub
    HttpStub -> (HttpStub -> HttpStub) -> HttpStub
forall a b. a -> (a -> b) -> b
& (MatchRequest -> Identity MatchRequest)
-> HttpStub -> Identity HttpStub
Lens' HttpStub MatchRequest
matchL ((MatchRequest -> Identity MatchRequest)
 -> HttpStub -> Identity HttpStub)
-> MatchRequest -> HttpStub -> HttpStub
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ Header -> MatchRequest
MatchHeader (HeaderName
hAccept, ByteString
"application/json")
    HttpStub -> (HttpStub -> HttpStub) -> HttpStub
forall a b. a -> (a -> b) -> b
& (ResponseHeaders -> Identity ResponseHeaders)
-> HttpStub -> Identity HttpStub
Lens' HttpStub ResponseHeaders
headersL ((ResponseHeaders -> Identity ResponseHeaders)
 -> HttpStub -> Identity HttpStub)
-> ResponseHeaders -> HttpStub -> HttpStub
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [(HeaderName
hContentType, ByteString
"application/json")]
    HttpStub -> (HttpStub -> HttpStub) -> HttpStub
forall a b. a -> (a -> b) -> b
& (ByteString -> Identity ByteString)
-> HttpStub -> Identity HttpStub
Lens' HttpStub ByteString
bodyL ((ByteString -> Identity ByteString)
 -> HttpStub -> Identity HttpStub)
-> ByteString -> HttpStub -> HttpStub
forall s t a b. ASetter s t a b -> b -> s -> t
.~ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
a

-- | Load stubs from the filesystem
--
-- Within the given directory, files are expected to be named for scheme, then
-- host, then path/port/query.
--
-- Given,
--
-- @
-- files/
--   https/
--     www.example.com/
--       hello                  => "Hello"
--       world                  => "World"
--   http/
--     localhost:3000/
--       hello?world=1          => "Hello 2"
-- @
--
-- Then @'loadHttpStubsDirectory' "files"@ is equivalent to,
--
-- @
-- [ 'stubUrl' \"https:\/\/www.example.com\/hello\" & 'bodyL' .~ \"Hello\"
-- , 'stubUrl' \"https:\/\/www.example.com\/world\" & 'bodyL' .~ \"World\"
-- , 'stubUrl' \"http:\/\/localhost:3000\/hello?world=1\" & 'bodyL' .~ \"Hello 2\"
-- ]
-- @
--
-- NB. This function currently abuses the fact that @/@ within filenames is the
-- same for URLs, and so will not work on Windows. Patches welcome.
loadHttpStubsDirectory :: FilePath -> IO [HttpStub]
loadHttpStubsDirectory :: [Char] -> IO [HttpStub]
loadHttpStubsDirectory [Char]
dir = do
  [[Char]]
paths <- ([Char] -> IO Bool) -> [[Char]] -> IO [[Char]]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [Char] -> IO Bool
doesFileExist ([[Char]] -> IO [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pattern -> [Char] -> IO [[Char]]
globDir1 Pattern
"**/*" [Char]
dir

  let pathUrls :: [([Char], [Char])]
pathUrls = ([Char] -> Maybe ([Char], [Char]))
-> [[Char]] -> [([Char], [Char])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\[Char]
p -> (,) [Char]
p ([Char] -> ([Char], [Char]))
-> Maybe [Char] -> Maybe ([Char], [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Maybe [Char]
toUrl [Char]
p) [[Char]]
paths

  [([Char], [Char])]
-> (([Char], [Char]) -> IO HttpStub) -> IO [HttpStub]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [([Char], [Char])]
pathUrls ((([Char], [Char]) -> IO HttpStub) -> IO [HttpStub])
-> (([Char], [Char]) -> IO HttpStub) -> IO [HttpStub]
forall a b. (a -> b) -> a -> b
$ \([Char]
path, [Char]
url) -> do
    ByteString
bs <- [Char] -> IO ByteString
BSL.readFile [Char]
path
    HttpStub -> IO HttpStub
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HttpStub -> IO HttpStub) -> HttpStub -> IO HttpStub
forall a b. (a -> b) -> a -> b
$ [Char] -> HttpStub
httpStubUrl [Char]
url HttpStub -> (HttpStub -> HttpStub) -> HttpStub
forall a b. a -> (a -> b) -> b
& (ByteString -> Identity ByteString)
-> HttpStub -> Identity HttpStub
Lens' HttpStub ByteString
bodyL ((ByteString -> Identity ByteString)
 -> HttpStub -> Identity HttpStub)
-> ByteString -> HttpStub -> HttpStub
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ByteString
bs
 where
  toUrl :: [Char] -> Maybe [Char]
toUrl [Char]
p = do
    [Char]
relative <- [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix ([Char] -> [Char]
addTrailingPathSeparator [Char]
dir) [Char]
p
    [Maybe [Char]] -> Maybe [Char]
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ ([Char]
"https://" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>) ([Char] -> [Char]) -> Maybe [Char] -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"https/" [Char]
relative
      , ([Char]
"http://" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>) ([Char] -> [Char]) -> Maybe [Char] -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"http/" [Char]
relative
      ]

class HasHttpStubs env where
  httpStubsL :: Lens' env [HttpStub]

instance HasHttpStubs [HttpStub] where
  httpStubsL :: Lens' [HttpStub] [HttpStub]
httpStubsL = ([HttpStub] -> f [HttpStub]) -> [HttpStub] -> f [HttpStub]
forall a. a -> a
id

newtype ReaderHttpStubs m a = ReaderHttpStubs {forall (m :: * -> *) a. ReaderHttpStubs m a -> m a
unwrap :: m a}
  deriving newtype ((forall a b.
 (a -> b) -> ReaderHttpStubs m a -> ReaderHttpStubs m b)
-> (forall a b. a -> ReaderHttpStubs m b -> ReaderHttpStubs m a)
-> Functor (ReaderHttpStubs m)
forall a b. a -> ReaderHttpStubs m b -> ReaderHttpStubs m a
forall a b. (a -> b) -> ReaderHttpStubs m a -> ReaderHttpStubs m b
forall (m :: * -> *) a b.
Functor m =>
a -> ReaderHttpStubs m b -> ReaderHttpStubs m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ReaderHttpStubs m a -> ReaderHttpStubs m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ReaderHttpStubs m a -> ReaderHttpStubs m b
fmap :: forall a b. (a -> b) -> ReaderHttpStubs m a -> ReaderHttpStubs m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> ReaderHttpStubs m b -> ReaderHttpStubs m a
<$ :: forall a b. a -> ReaderHttpStubs m b -> ReaderHttpStubs m a
Functor, Functor (ReaderHttpStubs m)
Functor (ReaderHttpStubs m) =>
(forall a. a -> ReaderHttpStubs m a)
-> (forall a b.
    ReaderHttpStubs m (a -> b)
    -> ReaderHttpStubs m a -> ReaderHttpStubs m b)
-> (forall a b c.
    (a -> b -> c)
    -> ReaderHttpStubs m a
    -> ReaderHttpStubs m b
    -> ReaderHttpStubs m c)
-> (forall a b.
    ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m b)
-> (forall a b.
    ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m a)
-> Applicative (ReaderHttpStubs m)
forall a. a -> ReaderHttpStubs m a
forall a b.
ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m a
forall a b.
ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m b
forall a b.
ReaderHttpStubs m (a -> b)
-> ReaderHttpStubs m a -> ReaderHttpStubs m b
forall a b c.
(a -> b -> c)
-> ReaderHttpStubs m a
-> ReaderHttpStubs m b
-> ReaderHttpStubs m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (ReaderHttpStubs m)
forall (m :: * -> *) a. Applicative m => a -> ReaderHttpStubs m a
forall (m :: * -> *) a b.
Applicative m =>
ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m a
forall (m :: * -> *) a b.
Applicative m =>
ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m b
forall (m :: * -> *) a b.
Applicative m =>
ReaderHttpStubs m (a -> b)
-> ReaderHttpStubs m a -> ReaderHttpStubs m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> ReaderHttpStubs m a
-> ReaderHttpStubs m b
-> ReaderHttpStubs m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> ReaderHttpStubs m a
pure :: forall a. a -> ReaderHttpStubs m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
ReaderHttpStubs m (a -> b)
-> ReaderHttpStubs m a -> ReaderHttpStubs m b
<*> :: forall a b.
ReaderHttpStubs m (a -> b)
-> ReaderHttpStubs m a -> ReaderHttpStubs m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> ReaderHttpStubs m a
-> ReaderHttpStubs m b
-> ReaderHttpStubs m c
liftA2 :: forall a b c.
(a -> b -> c)
-> ReaderHttpStubs m a
-> ReaderHttpStubs m b
-> ReaderHttpStubs m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m b
*> :: forall a b.
ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m a
<* :: forall a b.
ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m a
Applicative, Applicative (ReaderHttpStubs m)
Applicative (ReaderHttpStubs m) =>
(forall a b.
 ReaderHttpStubs m a
 -> (a -> ReaderHttpStubs m b) -> ReaderHttpStubs m b)
-> (forall a b.
    ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m b)
-> (forall a. a -> ReaderHttpStubs m a)
-> Monad (ReaderHttpStubs m)
forall a. a -> ReaderHttpStubs m a
forall a b.
ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m b
forall a b.
ReaderHttpStubs m a
-> (a -> ReaderHttpStubs m b) -> ReaderHttpStubs m b
forall (m :: * -> *). Monad m => Applicative (ReaderHttpStubs m)
forall (m :: * -> *) a. Monad m => a -> ReaderHttpStubs m a
forall (m :: * -> *) a b.
Monad m =>
ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m b
forall (m :: * -> *) a b.
Monad m =>
ReaderHttpStubs m a
-> (a -> ReaderHttpStubs m b) -> ReaderHttpStubs m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
ReaderHttpStubs m a
-> (a -> ReaderHttpStubs m b) -> ReaderHttpStubs m b
>>= :: forall a b.
ReaderHttpStubs m a
-> (a -> ReaderHttpStubs m b) -> ReaderHttpStubs m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m b
>> :: forall a b.
ReaderHttpStubs m a -> ReaderHttpStubs m b -> ReaderHttpStubs m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> ReaderHttpStubs m a
return :: forall a. a -> ReaderHttpStubs m a
Monad, MonadReader env)

instance (MonadReader env m, HasHttpStubs env) => MonadHttp (ReaderHttpStubs m) where
  httpLbs :: Request -> ReaderHttpStubs m (Response ByteString)
httpLbs Request
req = do
    [HttpStub]
stubs <- Getting [HttpStub] env [HttpStub] -> ReaderHttpStubs m [HttpStub]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [HttpStub] env [HttpStub]
forall env. HasHttpStubs env => Lens' env [HttpStub]
Lens' env [HttpStub]
httpStubsL
    Response ByteString -> ReaderHttpStubs m (Response ByteString)
forall a. a -> ReaderHttpStubs m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response ByteString -> ReaderHttpStubs m (Response ByteString))
-> Response ByteString -> ReaderHttpStubs m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ HasCallStack => [HttpStub] -> Request -> Response ByteString
[HttpStub] -> Request -> Response ByteString
httpStubbed [HttpStub]
stubs Request
req

newtype HttpStubsT m a = HttpStubsT {forall (m :: * -> *) a. HttpStubsT m a -> ReaderT [HttpStub] m a
unwrap :: ReaderT [HttpStub] m a}
  deriving newtype ((forall a b. (a -> b) -> HttpStubsT m a -> HttpStubsT m b)
-> (forall a b. a -> HttpStubsT m b -> HttpStubsT m a)
-> Functor (HttpStubsT m)
forall a b. a -> HttpStubsT m b -> HttpStubsT m a
forall a b. (a -> b) -> HttpStubsT m a -> HttpStubsT m b
forall (m :: * -> *) a b.
Functor m =>
a -> HttpStubsT m b -> HttpStubsT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> HttpStubsT m a -> HttpStubsT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> HttpStubsT m a -> HttpStubsT m b
fmap :: forall a b. (a -> b) -> HttpStubsT m a -> HttpStubsT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> HttpStubsT m b -> HttpStubsT m a
<$ :: forall a b. a -> HttpStubsT m b -> HttpStubsT m a
Functor, Functor (HttpStubsT m)
Functor (HttpStubsT m) =>
(forall a. a -> HttpStubsT m a)
-> (forall a b.
    HttpStubsT m (a -> b) -> HttpStubsT m a -> HttpStubsT m b)
-> (forall a b c.
    (a -> b -> c)
    -> HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m c)
-> (forall a b. HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m b)
-> (forall a b. HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m a)
-> Applicative (HttpStubsT m)
forall a. a -> HttpStubsT m a
forall a b. HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m a
forall a b. HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m b
forall a b.
HttpStubsT m (a -> b) -> HttpStubsT m a -> HttpStubsT m b
forall a b c.
(a -> b -> c) -> HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (HttpStubsT m)
forall (m :: * -> *) a. Applicative m => a -> HttpStubsT m a
forall (m :: * -> *) a b.
Applicative m =>
HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m a
forall (m :: * -> *) a b.
Applicative m =>
HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m b
forall (m :: * -> *) a b.
Applicative m =>
HttpStubsT m (a -> b) -> HttpStubsT m a -> HttpStubsT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> HttpStubsT m a
pure :: forall a. a -> HttpStubsT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
HttpStubsT m (a -> b) -> HttpStubsT m a -> HttpStubsT m b
<*> :: forall a b.
HttpStubsT m (a -> b) -> HttpStubsT m a -> HttpStubsT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m c
liftA2 :: forall a b c.
(a -> b -> c) -> HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m b
*> :: forall a b. HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m a
<* :: forall a b. HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m a
Applicative, Applicative (HttpStubsT m)
Applicative (HttpStubsT m) =>
(forall a b.
 HttpStubsT m a -> (a -> HttpStubsT m b) -> HttpStubsT m b)
-> (forall a b. HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m b)
-> (forall a. a -> HttpStubsT m a)
-> Monad (HttpStubsT m)
forall a. a -> HttpStubsT m a
forall a b. HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m b
forall a b.
HttpStubsT m a -> (a -> HttpStubsT m b) -> HttpStubsT m b
forall (m :: * -> *). Monad m => Applicative (HttpStubsT m)
forall (m :: * -> *) a. Monad m => a -> HttpStubsT m a
forall (m :: * -> *) a b.
Monad m =>
HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m b
forall (m :: * -> *) a b.
Monad m =>
HttpStubsT m a -> (a -> HttpStubsT m b) -> HttpStubsT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
HttpStubsT m a -> (a -> HttpStubsT m b) -> HttpStubsT m b
>>= :: forall a b.
HttpStubsT m a -> (a -> HttpStubsT m b) -> HttpStubsT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m b
>> :: forall a b. HttpStubsT m a -> HttpStubsT m b -> HttpStubsT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> HttpStubsT m a
return :: forall a. a -> HttpStubsT m a
Monad, MonadReader [HttpStub])
  deriving (Monad (HttpStubsT m)
Monad (HttpStubsT m) =>
(Request -> HttpStubsT m (Response ByteString))
-> MonadHttp (HttpStubsT m)
Request -> HttpStubsT m (Response ByteString)
forall (m :: * -> *). Monad m => Monad (HttpStubsT m)
forall (m :: * -> *).
Monad m =>
Request -> HttpStubsT m (Response ByteString)
forall (m :: * -> *).
Monad m =>
(Request -> m (Response ByteString)) -> MonadHttp m
$chttpLbs :: forall (m :: * -> *).
Monad m =>
Request -> HttpStubsT m (Response ByteString)
httpLbs :: Request -> HttpStubsT m (Response ByteString)
MonadHttp) via ReaderHttpStubs (HttpStubsT m)

runHttpStubsT :: HttpStubsT m a -> [HttpStub] -> m a
runHttpStubsT :: forall (m :: * -> *) a. HttpStubsT m a -> [HttpStub] -> m a
runHttpStubsT HttpStubsT m a
f = ReaderT [HttpStub] m a -> [HttpStub] -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT HttpStubsT m a
f.unwrap

-- $docs
--
-- Stubbing is accomplished by holding a list of 'HttpStub' somewhere, which
-- defines how to respond to requests that match. The simplest way to do so
-- is to use the 'IsString' instance:
--
-- > stubs :: [HttpStub]
-- > stubs =
-- >   [ "https://example.com"
-- >   ]
--
-- You can now use,
--
-- @
-- 'httpStubbed' stubs :: Request -> Response ByteString
-- @
--
-- Anywhere you need an HTTP requesting function and it will respond 200 with an
-- empty body for any @GET@ requests made to this domain.
--
-- Stubbed responses can be modified through lenses:
--
-- > stubs :: [HttpStub]
-- > stubs =
-- >   [ "https://example.com"
-- >       & statusL .~ status400
-- >       & bodyL .~ "Let's test a Bad Request"
-- >   ]
--
-- The string is passed to 'parseRequest_', so anything valid there is valid
-- here, such as setting the method:
--
-- > data MyItem = MyItem
-- >   { -- ...
-- >   }
-- >   deriving stock Generic
-- >   deriving anyclass ToJSON
-- >
-- > stubs :: [HttpStub]
-- > stubs =
-- >   [ "POST https://example.com/items"
-- >       & json [MyItem]
-- >       -- ^ Now matches requests with JSON in the Accept Header only
-- >       --   Responds with Content-Type JSON
-- >       --   Responds with a body of the JSON-encoded items
-- >   ]
--
-- == 'MonadHttp'
--
-- Once we have the @stubs@, we can set up a 'MonadHttp' context that uses it:
--
-- > data TestApp = TestApp
-- >   { appHttpStubs :: [HttpStubs]
-- >   }
-- >
-- > -- Assume TestAppT is a ReaderT TestApp
-- > instance MonadHttp (TestAppT m a) where
-- >   httpLbs req = do
-- >     stubs <- asks appHttpStubs
-- >     pure $ httpStubbed stubs req
--
-- Additionally, there are tools for @DerivingVia@ or running things in a
-- concrete 'HttpStubsT' stack.
--
-- == Handling Un-stubbed Requests
--
-- When no stubs match a given request, we call 'error' -- this seems uncouth,
-- but is actually the best possible behavior for the intended use-case in
-- (e.g.) HSpec:
--
-- ![Error screenshot](https://files.pbrisbin.com/screenshots/screenshot.281851.png)
--
-- One other reasonable behavior would be to respond 404 to any un-matched
-- requests. This can be accomplished by adding a "match anything" stub at the
-- end:
--
-- > stubs :: [HttpStub]
-- > stubs =
-- >   [ -- ...
-- >   , -- ...
-- >   , httpStub "Anything" MatchAnything
-- >       & statusL .~ status404
-- >       & bodyL .~ "Not found"
-- >   ]