{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

-- | 
-- This module is useful for testing by providing a concrete ByteString typed version of 'MonadDormouseClient' called `MonadDormouseTestClient`.  
--
-- The assumption is that, in most test cases, you probably want to verify the byte payload of the request (which you simply extract
-- from the request here as a @ByteString@) and provide a byte payload (also as a @ByteString@) in the response so that you can verify 
-- your repsonse payload can be decoded directly.
--
-- An implementation of `MonadDormouseTestClient` can be written in terms of either Strict or Lazy Bytestrings at your convenient and the other 
-- will be automatically provided for you.
--
-- The machinery in here uses orphan instances of 'MonadDormouseClient' so you should use this carefully and restrict this module to test 
-- cases only.
module Dormouse.Client.Test.Class
  ( MonadDormouseTestClient(..)
  ) where

import Control.Monad.IO.Class ( MonadIO(..) )
import qualified Data.ByteString  as SB
import qualified Data.ByteString.Lazy  as LB
import Data.Word ( Word8 )
import Dormouse.Client.Class ( MonadDormouseClient(..) )
import Dormouse.Client.Payload ( RawRequestPayload(..) )
import Dormouse.Client.Types ( HttpRequest(..), HttpResponse(..) )
import Streamly ( SerialT )
import qualified Streamly.Prelude as S
import qualified Streamly.External.ByteString as SEB
import qualified Streamly.External.ByteString.Lazy as SEBL

-- | MonadDormouseTestClient describes the capability to send and receive specifically ByteString typed HTTP Requests and Responses
class Monad m => MonadDormouseTestClient m where
  -- | Make the supplied HTTP request, expecting an HTTP response with a Lazy ByteString body to be delivered in some @MonadDormouseTest m@
  expectLbs :: HttpRequest scheme method LB.ByteString contentTag acceptTag -> m (HttpResponse LB.ByteString)
  expectLbs HttpRequest scheme method ByteString contentTag acceptTag
req = do
    HttpResponse ByteString
resp <- HttpRequest scheme method ByteString Any Any
-> m (HttpResponse ByteString)
forall (m :: * -> *) scheme (method :: Symbol) contentTag
       acceptTag.
MonadDormouseTestClient m =>
HttpRequest scheme method ByteString contentTag acceptTag
-> m (HttpResponse ByteString)
expectBs (HttpRequest scheme method ByteString Any Any
 -> m (HttpResponse ByteString))
-> HttpRequest scheme method ByteString Any Any
-> m (HttpResponse ByteString)
forall a b. (a -> b) -> a -> b
$ HttpRequest scheme method ByteString contentTag acceptTag
req {requestBody :: ByteString
requestBody = ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HttpRequest scheme method ByteString contentTag acceptTag
-> ByteString
forall url (method :: Symbol) body contentTag acceptTag.
HttpRequest url method body contentTag acceptTag -> body
requestBody HttpRequest scheme method ByteString contentTag acceptTag
req}
    HttpResponse ByteString -> m (HttpResponse ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpResponse ByteString -> m (HttpResponse ByteString))
-> HttpResponse ByteString -> m (HttpResponse ByteString)
forall a b. (a -> b) -> a -> b
$ HttpResponse ByteString
resp {responseBody :: ByteString
responseBody = ByteString -> ByteString
LB.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HttpResponse ByteString -> ByteString
forall body. HttpResponse body -> body
responseBody HttpResponse ByteString
resp}
  -- | Make the supplied HTTP request, expecting an HTTP response with a Strict ByteString body to be delivered in some @MonadDormouseTest m@
  expectBs :: HttpRequest scheme method SB.ByteString contentTag acceptTag -> m (HttpResponse SB.ByteString)
  expectBs HttpRequest scheme method ByteString contentTag acceptTag
req = do
    HttpResponse ByteString
resp <- HttpRequest scheme method ByteString Any Any
-> m (HttpResponse ByteString)
forall (m :: * -> *) scheme (method :: Symbol) contentTag
       acceptTag.
MonadDormouseTestClient m =>
HttpRequest scheme method ByteString contentTag acceptTag
-> m (HttpResponse ByteString)
expectLbs (HttpRequest scheme method ByteString Any Any
 -> m (HttpResponse ByteString))
-> HttpRequest scheme method ByteString Any Any
-> m (HttpResponse ByteString)
forall a b. (a -> b) -> a -> b
$ HttpRequest scheme method ByteString contentTag acceptTag
req {requestBody :: ByteString
requestBody = ByteString -> ByteString
LB.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HttpRequest scheme method ByteString contentTag acceptTag
-> ByteString
forall url (method :: Symbol) body contentTag acceptTag.
HttpRequest url method body contentTag acceptTag -> body
requestBody HttpRequest scheme method ByteString contentTag acceptTag
req}
    HttpResponse ByteString -> m (HttpResponse ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpResponse ByteString -> m (HttpResponse ByteString))
-> HttpResponse ByteString -> m (HttpResponse ByteString)
forall a b. (a -> b) -> a -> b
$ HttpResponse ByteString
resp {responseBody :: ByteString
responseBody = ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HttpResponse ByteString -> ByteString
forall body. HttpResponse body -> body
responseBody HttpResponse ByteString
resp}
  {-# MINIMAL expectLbs | expectBs #-}

instance (Monad m, MonadIO m, MonadDormouseTestClient m) => MonadDormouseClient m where
  send :: HttpRequest url method RawRequestPayload contentTag acceptTag
-> (HttpResponse (SerialT IO Word8) -> IO (HttpResponse b))
-> m (HttpResponse b)
send HttpRequest url method RawRequestPayload contentTag acceptTag
req HttpResponse (SerialT IO Word8) -> IO (HttpResponse b)
deserialiseResp = do
    ByteString
reqBody <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString)
-> (HttpRequest url method RawRequestPayload contentTag acceptTag
    -> IO ByteString)
-> HttpRequest url method RawRequestPayload contentTag acceptTag
-> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fold IO Word8 ByteString -> SerialT IO Word8 -> IO ByteString
forall (m :: * -> *) a b.
Monad m =>
Fold m a b -> SerialT m a -> m b
S.fold Fold IO Word8 ByteString
forall (m :: * -> *). MonadIO m => Fold m Word8 ByteString
SEB.write (SerialT IO Word8 -> IO ByteString)
-> (HttpRequest url method RawRequestPayload contentTag acceptTag
    -> SerialT IO Word8)
-> HttpRequest url method RawRequestPayload contentTag acceptTag
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawRequestPayload -> SerialT IO Word8
extricateRequestStream (RawRequestPayload -> SerialT IO Word8)
-> (HttpRequest url method RawRequestPayload contentTag acceptTag
    -> RawRequestPayload)
-> HttpRequest url method RawRequestPayload contentTag acceptTag
-> SerialT IO Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpRequest url method RawRequestPayload contentTag acceptTag
-> RawRequestPayload
forall url (method :: Symbol) body contentTag acceptTag.
HttpRequest url method body contentTag acceptTag -> body
requestBody (HttpRequest url method RawRequestPayload contentTag acceptTag
 -> m ByteString)
-> HttpRequest url method RawRequestPayload contentTag acceptTag
-> m ByteString
forall a b. (a -> b) -> a -> b
$ HttpRequest url method RawRequestPayload contentTag acceptTag
req
    let reqBs :: HttpRequest url method ByteString contentTag acceptTag
reqBs = HttpRequest url method RawRequestPayload contentTag acceptTag
req {requestBody :: ByteString
requestBody = ByteString
reqBody}
    HttpResponse ByteString
respBs <- HttpRequest url method ByteString Any Any
-> m (HttpResponse ByteString)
forall (m :: * -> *) scheme (method :: Symbol) contentTag
       acceptTag.
MonadDormouseTestClient m =>
HttpRequest scheme method ByteString contentTag acceptTag
-> m (HttpResponse ByteString)
expectBs HttpRequest url method ByteString Any Any
forall contentTag acceptTag.
HttpRequest url method ByteString contentTag acceptTag
reqBs
    let respStream :: SerialT IO Word8
respStream = Unfold IO ByteString Word8 -> ByteString -> SerialT IO Word8
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, Monad m) =>
Unfold m a b -> a -> t m b
S.unfold Unfold IO ByteString Word8
forall (m :: * -> *). Monad m => Unfold m ByteString Word8
SEBL.read (ByteString -> SerialT IO Word8)
-> (ByteString -> ByteString) -> ByteString -> SerialT IO Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LB.fromStrict (ByteString -> SerialT IO Word8) -> ByteString -> SerialT IO Word8
forall a b. (a -> b) -> a -> b
$ HttpResponse ByteString -> ByteString
forall body. HttpResponse body -> body
responseBody HttpResponse ByteString
respBs
    IO (HttpResponse b) -> m (HttpResponse b)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HttpResponse b) -> m (HttpResponse b))
-> IO (HttpResponse b) -> m (HttpResponse b)
forall a b. (a -> b) -> a -> b
$ HttpResponse (SerialT IO Word8) -> IO (HttpResponse b)
deserialiseResp (HttpResponse (SerialT IO Word8) -> IO (HttpResponse b))
-> HttpResponse (SerialT IO Word8) -> IO (HttpResponse b)
forall a b. (a -> b) -> a -> b
$ HttpResponse ByteString
respBs { responseBody :: SerialT IO Word8
responseBody = SerialT IO Word8
respStream }
    where 
      extricateRequestStream :: RawRequestPayload -> SerialT IO Word8
      extricateRequestStream :: RawRequestPayload -> SerialT IO Word8
extricateRequestStream (DefinedContentLength Word64
_ SerialT IO Word8
s) = SerialT IO Word8
s
      extricateRequestStream (ChunkedTransfer SerialT IO Word8
s) = SerialT IO Word8
s