{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}

-- | Stub out Http requests in tests.
module Http.Mock
  ( stub,
    Stub,
    mkStub,

    -- * Read request data
    getHeader,
    getTextBody,
    getJsonBody,
    getBytesBody,
  )
where

import qualified Data.Aeson as Aeson
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy
import qualified Data.Dynamic as Dynamic
import qualified Data.IORef
import Data.String (fromString)
import qualified Data.Text.Encoding
import qualified Debug
import qualified Expect
import qualified GHC.Stack as Stack
import qualified Http.Internal as Internal
import qualified Platform
import qualified Task
import qualified Type.Reflection
import qualified Prelude

-- | A stub for a single request type. If your test body can perform multiple
-- different kinds of http requests, you'll want one of these per request type.
data Stub a where
  Stub ::
    (Dynamic.Typeable e, Dynamic.Typeable expect) =>
    (Internal.Request' e expect -> Task e (a, expect)) ->
    Stub a

-- | Create a 'Stub'.
mkStub ::
  (Dynamic.Typeable e, Dynamic.Typeable expect) =>
  (Internal.Request' e expect -> Task e (a, expect)) ->
  Stub a
mkStub :: (Request' e expect -> Task e (a, expect)) -> Stub a
mkStub = (Request' e expect -> Task e (a, expect)) -> Stub a
forall e expect a.
(Typeable e, Typeable expect) =>
(Request' e expect -> Task e (a, expect)) -> Stub a
Stub

-- | Stub out http requests in a bit of code. You can use this if you don't
-- want your tests to make real http requests, and to listen in on the http
-- requests it is attempting to make.
--
-- 'stub' takes a function that it calls instead of making a real http request.
-- That function should return the response string and a optionally some
-- information about the http request. You'll get back the information collected
-- for each outgoing http request so you can run assertions against it.
--
-- > test "Stubbed HTTP requests" <| \_ -> do
-- >   urlsAccessed <-
-- >     Http.Mock.stub
-- >       [mkStub (\req -> Task.succeed (Http.url req, "Response!" :: Text))]
-- >       ( \http ->
-- >           Expect.succeeds <| do
-- >             _ <- Http.get http "example.com/one" Http.expectText
-- >             _ <- Http.get http "example.com/two" Http.expectText
-- >             Task.succeed ()
-- >       )
-- >   urlsAccessed
-- >     |> Expect.equal ["example.com/one", "example.com/two"]
stub ::
  ( Stack.HasCallStack,
    Dynamic.Typeable a
  ) =>
  (List (Stub a)) ->
  (Internal.Handler -> Expect.Expectation) ->
  Expect.Expectation' (List a)
stub :: List (Stub a) -> (Handler -> Expectation) -> Expectation' (List a)
stub List (Stub a)
responders Handler -> Expectation
stubbedTestBody = do
  IORef (List a)
logRef <- IO (IORef (List a)) -> Expectation' (IORef (List a))
forall a. IO a -> Expectation' a
Expect.fromIO (List a -> IO (IORef (List a))
forall a. a -> IO (IORef a)
Data.IORef.newIORef [])
  Handler
doAnything <- IO Handler -> Expectation' Handler
forall a. IO a -> Expectation' a
Expect.fromIO IO Handler
Platform.doAnythingHandler
  let mockHandler :: Handler
mockHandler =
        (forall e expect.
 (Typeable expect, Typeable e) =>
 Request' e expect -> Task e expect)
-> (forall e a. (Manager -> Task e a) -> Task e a)
-> (forall a. LogHandler -> (Manager -> IO a) -> IO a)
-> Handler
Internal.Handler
          ( \Request' e expect
req -> do
              (a
log, expect
res) <- List (Stub a) -> Request' e expect -> Task e (a, expect)
forall expect e a.
(Typeable expect, Typeable e, Typeable a) =>
List (Stub a) -> Request' e expect -> Task e (a, expect)
tryRespond List (Stub a)
responders Request' e expect
req
              IORef (List a) -> (List a -> List a) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
Data.IORef.modifyIORef' IORef (List a)
logRef (\List a
prev -> a
log a -> List a -> List a
forall a. a -> [a] -> [a]
: List a
prev)
                IO () -> (IO () -> IO (Result e ())) -> IO (Result e ())
forall a b. a -> (a -> b) -> b
|> (() -> Result e ()) -> IO () -> IO (Result e ())
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map () -> Result e ()
forall error value. value -> Result error value
Ok
                IO (Result e ()) -> (IO (Result e ()) -> Task e ()) -> Task e ()
forall a b. a -> (a -> b) -> b
|> Handler -> IO (Result e ()) -> Task e ()
forall e a. Handler -> IO (Result e a) -> Task e a
Platform.doAnything Handler
doAnything
              expect -> Task e expect
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure expect
res
          )
          (\Manager -> Task e a
_ -> Text -> Task e a
forall a. HasCallStack => Text -> a
Debug.todo Text
"We don't mock third party HTTP calls yet")
          (\LogHandler
_ -> Text -> (Manager -> IO a) -> IO a
forall a. HasCallStack => Text -> a
Debug.todo Text
"We don't mock third party HTTP calls yet")
  (forall e a. (Handler -> Task e a) -> Task e a)
-> (Handler -> Expectation) -> Expectation
forall arg.
(forall e a. (arg -> Task e a) -> Task e a)
-> (arg -> Expectation) -> Expectation
Expect.around (\Handler -> Task e a
f -> Handler -> Task e a
f Handler
mockHandler) ((HasCallStack => Handler -> Expectation) -> Handler -> Expectation
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => Handler -> Expectation
Handler -> Expectation
stubbedTestBody)
  IO (List a) -> Expectation' (List a)
forall a. IO a -> Expectation' a
Expect.fromIO (IORef (List a) -> IO (List a)
forall a. IORef a -> IO a
Data.IORef.readIORef IORef (List a)
logRef)
    Expectation' (List a)
-> (Expectation' (List a) -> Expectation' (List a))
-> Expectation' (List a)
forall a b. a -> (a -> b) -> b
|> (List a -> List a)
-> Expectation' (List a) -> Expectation' (List a)
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map List a -> List a
forall a. List a -> List a
List.reverse

-- | Read the body of the request as text. Useful to check what data got
-- submitted inside a 'stub' function.
--
-- This will return 'Nothing' if the body cannot be parsed as UTF8 text.
getTextBody :: Internal.Request expect -> Maybe Text
getTextBody :: Request expect -> Maybe Text
getTextBody Request expect
req =
  ByteString -> Either UnicodeException Text
Data.Text.Encoding.decodeUtf8' (Request expect -> ByteString
forall expect. Request expect -> ByteString
getBytesBody Request expect
req)
    Either UnicodeException Text
-> (Either UnicodeException Text -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
|> Either UnicodeException Text -> Maybe Text
forall a b. Either a b -> Maybe b
eitherToMaybe

-- | Read the body of the request as json. Useful to check what data got
-- submitted inside a 'stub' function.
--
-- This will return an error if parsing the JSON body fails.
getJsonBody :: Aeson.FromJSON a => Internal.Request expect -> Result Text a
getJsonBody :: Request expect -> Result Text a
getJsonBody Request expect
req =
  case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict (Request expect -> ByteString
forall expect. Request expect -> ByteString
getBytesBody Request expect
req) of
    Prelude.Left String
err -> Text -> Result Text a
forall error value. error -> Result error value
Err (String -> Text
Text.fromList String
err)
    Prelude.Right a
decoded -> a -> Result Text a
forall error value. value -> Result error value
Ok a
decoded

-- | Read the body of the request as bytes. Useful to check what data got
-- submitted inside a 'stub' function.
getBytesBody :: Internal.Request expect -> ByteString
getBytesBody :: Request expect -> ByteString
getBytesBody Request expect
req =
  Request expect -> Body
forall x a. Request' x a -> Body
Internal.body Request expect
req
    Body -> (Body -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> Body -> ByteString
Internal.bodyContents
    ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> ByteString -> ByteString
Data.ByteString.Lazy.toStrict

-- | Read a header of the request. Useful to check what data got submitted
-- inside a 'stub' function.
--
-- This will return 'Nothing' if no header with that name was set on the
-- request.
getHeader :: Text -> Internal.Request expect -> Maybe Text
getHeader :: Text -> Request expect -> Maybe Text
getHeader Text
name Request expect
req =
  Request expect -> [Header]
forall x a. Request' x a -> [Header]
Internal.headers Request expect
req
    [Header] -> ([Header] -> List Header) -> List Header
forall a b. a -> (a -> b) -> b
|> (Header -> Header) -> [Header] -> List Header
forall a b. (a -> b) -> List a -> List b
List.map Header -> Header
Internal.unHeader
    List Header
-> (List Header -> Maybe ByteString) -> Maybe ByteString
forall a b. a -> (a -> b) -> b
|> HeaderName -> List Header -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup (String -> HeaderName
forall a. IsString a => String -> a
fromString (Text -> String
Text.toList Text
name))
    Maybe ByteString -> (Maybe ByteString -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
|> (ByteString -> Maybe Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> Maybe b) -> Maybe a -> Maybe b
Maybe.andThen (Either UnicodeException Text -> Maybe Text
forall a b. Either a b -> Maybe b
eitherToMaybe (Either UnicodeException Text -> Maybe Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< ByteString -> Either UnicodeException Text
Data.Text.Encoding.decodeUtf8')

eitherToMaybe :: Prelude.Either a b -> Maybe b
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe Either a b
either =
  case Either a b
either of
    Prelude.Left a
_ -> Maybe b
forall a. Maybe a
Nothing
    Prelude.Right b
x -> b -> Maybe b
forall a. a -> Maybe a
Just b
x

tryRespond ::
  ( Dynamic.Typeable expect,
    Dynamic.Typeable e,
    Dynamic.Typeable a
  ) =>
  List (Stub a) ->
  Internal.Request' e expect ->
  Task e (a, expect)
tryRespond :: List (Stub a) -> Request' e expect -> Task e (a, expect)
tryRespond [] Request' e expect
req =
  let msg :: Text
msg =
        Text
"Http request was made with expected return type "
          Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Request' e expect -> Text
forall expect (proxy :: * -> *).
Typeable expect =>
proxy expect -> Text
printType Request' e expect
req
          Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
", but I don't how to create a mock response of this type. Please add a `mkStub` entry for this type in the test."
      handleCustomResponse :: (Internal.Response s -> Result e expect) -> Task e (a, expect)
      handleCustomResponse :: (Response s -> Result e expect) -> Task e (a, expect)
handleCustomResponse Response s -> Result e expect
f = case Response s -> Result e expect
f (Text -> Response s
forall body. Text -> Response body
Internal.NetworkError_ Text
msg) of
        Err e
err -> e -> Task e (a, expect)
forall x a. x -> Task x a
Task.fail e
err
        Ok expect
_ -> Text -> Task e (a, expect)
forall a. HasCallStack => Text -> a
Debug.todo Text
"Since we manually craft the Response as an Error, this case will not run."
   in case Request' e expect -> Expect' e expect
forall x a. Request' x a -> Expect' x a
Internal.expect Request' e expect
req of
        Expect' e expect
Internal.ExpectJson ->
          Error -> Task Error (a, expect)
forall x a. x -> Task x a
Task.fail (Text -> Error
Internal.NetworkError Text
msg)
        Expect' e expect
Internal.ExpectText ->
          Error -> Task Error (a, expect)
forall x a. x -> Task x a
Task.fail (Text -> Error
Internal.NetworkError Text
msg)
        Expect' e expect
Internal.ExpectWhatever ->
          Error -> Task Error (a, expect)
forall x a. x -> Task x a
Task.fail (Text -> Error
Internal.NetworkError Text
msg)
        Internal.ExpectTextResponse Response Text -> Result e expect
f ->
          (Response Text -> Result e expect) -> Task e (a, expect)
forall s e expect a.
(Response s -> Result e expect) -> Task e (a, expect)
handleCustomResponse Response Text -> Result e expect
f
        Internal.ExpectBytesResponse Response ByteString -> Result e expect
f ->
          (Response ByteString -> Result e expect) -> Task e (a, expect)
forall s e expect a.
(Response s -> Result e expect) -> Task e (a, expect)
handleCustomResponse Response ByteString -> Result e expect
f
tryRespond (Stub Request' e expect -> Task e (a, expect)
respond : List (Stub a)
rest) Request' e expect
req =
  Dynamic -> Dynamic -> Maybe Dynamic
Dynamic.dynApply ((Request' e expect -> Task e (a, expect)) -> Dynamic
forall a. Typeable a => a -> Dynamic
Dynamic.toDyn Request' e expect -> Task e (a, expect)
respond) (Request' e expect -> Dynamic
forall a. Typeable a => a -> Dynamic
Dynamic.toDyn Request' e expect
req)
    Maybe Dynamic
-> (Maybe Dynamic -> Maybe (Task e (a, expect)))
-> Maybe (Task e (a, expect))
forall a b. a -> (a -> b) -> b
|> (Dynamic -> Maybe (Task e (a, expect)))
-> Maybe Dynamic -> Maybe (Task e (a, expect))
forall a b. (a -> Maybe b) -> Maybe a -> Maybe b
Maybe.andThen Dynamic -> Maybe (Task e (a, expect))
forall a. Typeable a => Dynamic -> Maybe a
Dynamic.fromDynamic
    Maybe (Task e (a, expect))
-> (Maybe (Task e (a, expect)) -> Task e (a, expect))
-> Task e (a, expect)
forall a b. a -> (a -> b) -> b
|> Task e (a, expect)
-> Maybe (Task e (a, expect)) -> Task e (a, expect)
forall a. a -> Maybe a -> a
Maybe.withDefault (List (Stub a) -> Request' e expect -> Task e (a, expect)
forall expect e a.
(Typeable expect, Typeable e, Typeable a) =>
List (Stub a) -> Request' e expect -> Task e (a, expect)
tryRespond List (Stub a)
rest Request' e expect
req)

printType :: Dynamic.Typeable expect => proxy expect -> Text
printType :: proxy expect -> Text
printType proxy expect
expect =
  proxy expect -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
Type.Reflection.someTypeRep proxy expect
expect
    SomeTypeRep -> (SomeTypeRep -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> SomeTypeRep -> Text
forall a. Show a => a -> Text
Debug.toString