{-# LANGUAGE FlexibleInstances #-}

module Dormouse.Client.Payload
  ( HasMediaType(..)
  , EmptyPayload
  , RequestPayload(..)
  , ResponsePayload(..)
  , JsonPayload
  , UrlFormPayload
  , HtmlPayload
  , RawRequestPayload(..)
  , json
  , urlForm
  , noPayload
  , html
  ) where

import Control.Exception.Safe (MonadThrow, throw)
import Control.Monad.IO.Class
import Data.Aeson (FromJSON, ToJSON, encode, eitherDecodeStrict)
import qualified Data.CaseInsensitive as CI
import Data.Proxy
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Word (Word8, Word64)
import Dormouse.Client.Data
import Dormouse.Client.Types
import Dormouse.Client.Exception (DecodingException(..))
import Dormouse.Client.Headers
import Dormouse.Client.Headers.MediaType
import qualified Dormouse.Client.Headers.MediaType as MTH
import qualified Data.ByteString.Lazy as LB
import qualified Data.Map.Strict as Map
import qualified Web.FormUrlEncoded as W
import Streamly
import qualified Streamly.Prelude as S
import qualified Streamly.External.ByteString as SEB
import qualified Streamly.External.ByteString.Lazy as SEBL

-- | Describes an association between a type @tag@ and a specific Media Type
class HasMediaType tag where
  mediaType :: Proxy tag -> Maybe MediaType

-- | A raw HTTP Request payload consisting of a stream of bytes with either a defined Content Length or using Chunked Transfer Encoding
data RawRequestPayload
  -- | DefinedContentLength represents a payload where the size of the message is known in advance and the content length header can be computed
  = DefinedContentLength Word64 (SerialT IO Word8)
  -- | ChunkedTransfer represents a payload with indertiminate length, to be sent using chunked transfer encoding
  | ChunkedTransfer (SerialT IO Word8)

-- | RequestPayload relates a type of content and a payload tag used to describe that type to its byte stream representation and the constraints required to encode it
class HasMediaType contentTag => RequestPayload body contentTag where
  -- | Generates a the byte stream representation from the supplied content
  serialiseRequest :: Proxy contentTag -> HttpRequest url method body contentTag acceptTag  -> HttpRequest url method RawRequestPayload contentTag acceptTag 

-- | ResponsePayload relates a type of content and a payload tag used to describe that type  to its byte stream representation and the constraints required to decode it
class HasMediaType tag => ResponsePayload body tag where
  -- | Decodes the high level representation from the supplied byte stream
  deserialiseRequest :: Proxy tag -> HttpResponse (SerialT IO Word8) -> IO (HttpResponse body)

data JsonPayload = JsonPayload

instance HasMediaType JsonPayload where
  mediaType :: Proxy JsonPayload -> Maybe MediaType
mediaType Proxy JsonPayload
_ = MediaType -> Maybe MediaType
forall a. a -> Maybe a
Just MediaType
applicationJson

instance (ToJSON body) => RequestPayload body JsonPayload where
  serialiseRequest :: Proxy JsonPayload
-> HttpRequest url method body JsonPayload acceptTag
-> HttpRequest url method RawRequestPayload JsonPayload acceptTag
serialiseRequest Proxy JsonPayload
_ HttpRequest url method body JsonPayload acceptTag
r = 
    let b :: body
b = HttpRequest url method body JsonPayload acceptTag -> body
forall url (method :: Symbol) body contentTag acceptTag.
HttpRequest url method body contentTag acceptTag -> body
requestBody HttpRequest url method body JsonPayload acceptTag
r
        lbs :: ByteString
lbs = body -> ByteString
forall a. ToJSON a => a -> ByteString
encode body
b
    in HttpRequest url method body JsonPayload acceptTag
r { requestBody :: RawRequestPayload
requestBody = Word64 -> SerialT IO Word8 -> RawRequestPayload
DefinedContentLength (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word64) -> (ByteString -> Int64) -> ByteString -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
LB.length (ByteString -> Word64) -> ByteString -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString
lbs) (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
lbs) }

instance (FromJSON body) => ResponsePayload body JsonPayload where
  deserialiseRequest :: Proxy JsonPayload
-> HttpResponse (SerialT IO Word8) -> IO (HttpResponse body)
deserialiseRequest Proxy JsonPayload
_ HttpResponse (SerialT IO Word8)
resp = do
    let stream :: SerialT IO Word8
stream = HttpResponse (SerialT IO Word8) -> SerialT IO Word8
forall body. HttpResponse body -> body
responseBody HttpResponse (SerialT IO Word8)
resp
    ByteString
bs <- 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
stream
    body
body <- (String -> IO body)
-> (body -> IO body) -> Either String body -> IO body
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (DecodingException -> IO body
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (DecodingException -> IO body)
-> (String -> DecodingException) -> String -> IO body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DecodingException
DecodingException (Text -> DecodingException)
-> (String -> Text) -> String -> DecodingException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) body -> IO body
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String body -> IO body)
-> (ByteString -> Either String body) -> ByteString -> IO body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String body
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict (ByteString -> IO body) -> ByteString -> IO body
forall a b. (a -> b) -> a -> b
$ ByteString
bs
    HttpResponse body -> IO (HttpResponse body)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpResponse body -> IO (HttpResponse body))
-> HttpResponse body -> IO (HttpResponse body)
forall a b. (a -> b) -> a -> b
$ HttpResponse (SerialT IO Word8)
resp { responseBody :: body
responseBody = body
body }

-- | A type tag used to indicate that a request\/response should be encoded\/decoded as @application/json@ data
json :: Proxy JsonPayload
json :: Proxy JsonPayload
json = Proxy JsonPayload
forall k (t :: k). Proxy t
Proxy :: Proxy JsonPayload

data UrlFormPayload = UrlFormPayload

instance HasMediaType UrlFormPayload where
  mediaType :: Proxy UrlFormPayload -> Maybe MediaType
mediaType Proxy UrlFormPayload
_ = MediaType -> Maybe MediaType
forall a. a -> Maybe a
Just MediaType
applicationXWWWFormUrlEncoded

instance (W.ToForm body) => RequestPayload body UrlFormPayload where
  serialiseRequest :: Proxy UrlFormPayload
-> HttpRequest url method body UrlFormPayload acceptTag
-> HttpRequest
     url method RawRequestPayload UrlFormPayload acceptTag
serialiseRequest Proxy UrlFormPayload
_ HttpRequest url method body UrlFormPayload acceptTag
r =
    let b :: body
b = HttpRequest url method body UrlFormPayload acceptTag -> body
forall url (method :: Symbol) body contentTag acceptTag.
HttpRequest url method body contentTag acceptTag -> body
requestBody HttpRequest url method body UrlFormPayload acceptTag
r
        lbs :: ByteString
lbs = body -> ByteString
forall a. ToForm a => a -> ByteString
W.urlEncodeAsForm body
b
    in HttpRequest url method body UrlFormPayload acceptTag
r { requestBody :: RawRequestPayload
requestBody = Word64 -> SerialT IO Word8 -> RawRequestPayload
DefinedContentLength (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word64) -> (ByteString -> Int64) -> ByteString -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
LB.length (ByteString -> Word64) -> ByteString -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString
lbs) (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
lbs) }

instance (W.FromForm body) => ResponsePayload body UrlFormPayload where
  deserialiseRequest :: Proxy UrlFormPayload
-> HttpResponse (SerialT IO Word8) -> IO (HttpResponse body)
deserialiseRequest Proxy UrlFormPayload
_ HttpResponse (SerialT IO Word8)
resp = do
    let stream :: SerialT IO Word8
stream = HttpResponse (SerialT IO Word8) -> SerialT IO Word8
forall body. HttpResponse body -> body
responseBody HttpResponse (SerialT IO Word8)
resp
    ByteString
bs <- 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)
-> SerialT IO Word8 -> IO ByteString
forall a b. (a -> b) -> a -> b
$ SerialT IO Word8
stream
    body
body <- (Text -> IO body)
-> (body -> IO body) -> Either Text body -> IO body
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (DecodingException -> IO body
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (DecodingException -> IO body)
-> (Text -> DecodingException) -> Text -> IO body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DecodingException
DecodingException) body -> IO body
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text body -> IO body)
-> (ByteString -> Either Text body) -> ByteString -> IO body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text body
forall a. FromForm a => ByteString -> Either Text a
W.urlDecodeAsForm (ByteString -> IO body) -> ByteString -> IO body
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.fromStrict ByteString
bs
    HttpResponse body -> IO (HttpResponse body)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpResponse body -> IO (HttpResponse body))
-> HttpResponse body -> IO (HttpResponse body)
forall a b. (a -> b) -> a -> b
$ HttpResponse (SerialT IO Word8)
resp { responseBody :: body
responseBody = body
body }

-- | A type tag used to indicate that a request\/response should be encoded\/decoded as @application/x-www-form-urlencoded@ data
urlForm :: Proxy UrlFormPayload
urlForm :: Proxy UrlFormPayload
urlForm = Proxy UrlFormPayload
forall k (t :: k). Proxy t
Proxy :: Proxy UrlFormPayload

data EmptyPayload = EmptyPayload

instance HasMediaType EmptyPayload where
  mediaType :: Proxy EmptyPayload -> Maybe MediaType
mediaType Proxy EmptyPayload
_ = Maybe MediaType
forall a. Maybe a
Nothing

instance RequestPayload Empty EmptyPayload where
  serialiseRequest :: Proxy EmptyPayload
-> HttpRequest url method Empty EmptyPayload acceptTag
-> HttpRequest url method RawRequestPayload EmptyPayload acceptTag
serialiseRequest Proxy EmptyPayload
_ HttpRequest url method Empty EmptyPayload acceptTag
r = HttpRequest url method Empty EmptyPayload acceptTag
r { requestBody :: RawRequestPayload
requestBody = Word64 -> SerialT IO Word8 -> RawRequestPayload
DefinedContentLength Word64
0 SerialT IO Word8
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
IsStream t =>
t m a
S.nil }

instance ResponsePayload Empty EmptyPayload where
  deserialiseRequest :: Proxy EmptyPayload
-> HttpResponse (SerialT IO Word8) -> IO (HttpResponse Empty)
deserialiseRequest Proxy EmptyPayload
_ HttpResponse (SerialT IO Word8)
resp = do
    let stream :: SerialT IO Word8
stream = HttpResponse (SerialT IO Word8) -> SerialT IO Word8
forall body. HttpResponse body -> body
responseBody HttpResponse (SerialT IO Word8)
resp
    Empty
body <- Empty
Empty Empty -> IO () -> IO Empty
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SerialT IO Word8 -> IO ()
forall (m :: * -> *) a. Monad m => SerialT m a -> m ()
S.drain SerialT IO Word8
stream
    HttpResponse Empty -> IO (HttpResponse Empty)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpResponse Empty -> IO (HttpResponse Empty))
-> HttpResponse Empty -> IO (HttpResponse Empty)
forall a b. (a -> b) -> a -> b
$ HttpResponse (SerialT IO Word8)
resp { responseBody :: Empty
responseBody = Empty
body }

-- | A type tag used to indicate that a request\/response has no payload
noPayload :: Proxy EmptyPayload
noPayload :: Proxy EmptyPayload
noPayload = Proxy EmptyPayload
forall k (t :: k). Proxy t
Proxy :: Proxy EmptyPayload

decodeTextContent :: (MonadThrow m, MonadIO m) => HttpResponse (SerialT m Word8) -> m (HttpResponse T.Text)
decodeTextContent :: HttpResponse (SerialT m Word8) -> m (HttpResponse Text)
decodeTextContent HttpResponse (SerialT m Word8)
resp = do
  let contentTypeHV :: Maybe ByteString
contentTypeHV = HeaderName -> HttpResponse (SerialT m Word8) -> Maybe ByteString
forall a. HasHeaders a => HeaderName -> a -> Maybe ByteString
getHeaderValue HeaderName
"Content-Type" HttpResponse (SerialT m Word8)
resp
  Maybe MediaType
mediaType' <- (ByteString -> m MediaType)
-> Maybe ByteString -> m (Maybe MediaType)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ByteString -> m MediaType
forall (m :: * -> *). MonadThrow m => ByteString -> m MediaType
MTH.parseMediaType Maybe ByteString
contentTypeHV
  let maybeCharset :: Maybe ByteString
maybeCharset = Maybe MediaType
mediaType' Maybe MediaType
-> (MediaType -> Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HeaderName -> Map HeaderName ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup HeaderName
"charset" (Map HeaderName ByteString -> Maybe ByteString)
-> (MediaType -> Map HeaderName ByteString)
-> MediaType
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MediaType -> Map HeaderName ByteString
MTH.parameters
  let stream :: SerialT m Word8
stream = HttpResponse (SerialT m Word8) -> SerialT m Word8
forall body. HttpResponse body -> body
responseBody HttpResponse (SerialT m Word8)
resp
  ByteString
bs <- Fold m Word8 ByteString -> SerialT m Word8 -> m ByteString
forall (m :: * -> *) a b.
Monad m =>
Fold m a b -> SerialT m a -> m b
S.fold Fold m Word8 ByteString
forall (m :: * -> *). MonadIO m => Fold m Word8 ByteString
SEB.write (SerialT m Word8 -> m ByteString)
-> SerialT m Word8 -> m ByteString
forall a b. (a -> b) -> a -> b
$ SerialT m Word8
stream
  HttpResponse Text -> m (HttpResponse Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpResponse Text -> m (HttpResponse Text))
-> HttpResponse Text -> m (HttpResponse Text)
forall a b. (a -> b) -> a -> b
$ HttpResponse (SerialT m Word8)
resp { responseBody :: Text
responseBody = Maybe ByteString -> ByteString -> Text
forall s.
(FoldCase s, Eq s, IsString s) =>
Maybe s -> ByteString -> Text
decodeContent Maybe ByteString
maybeCharset ByteString
bs }
    where
      decodeContent :: Maybe s -> ByteString -> Text
decodeContent Maybe s
maybeCharset ByteString
bs' = 
        case (s -> CI s) -> Maybe s -> Maybe (CI s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s -> CI s
forall s. FoldCase s => s -> CI s
CI.mk Maybe s
maybeCharset of
          Just(CI s
"utf8")       -> ByteString -> Text
TE.decodeUtf8 ByteString
bs'
          Just(CI s
"iso-8859-1") -> ByteString -> Text
TE.decodeLatin1 ByteString
bs'
          Maybe (CI s)
_                  -> ByteString -> Text
TE.decodeUtf8 ByteString
bs'

data HtmlPayload = HtmlPayload

instance HasMediaType HtmlPayload where
  mediaType :: Proxy HtmlPayload -> Maybe MediaType
mediaType Proxy HtmlPayload
_ = MediaType -> Maybe MediaType
forall a. a -> Maybe a
Just MediaType
textHtml

instance RequestPayload T.Text HtmlPayload where
  serialiseRequest :: Proxy HtmlPayload
-> HttpRequest url method Text HtmlPayload acceptTag
-> HttpRequest url method RawRequestPayload HtmlPayload acceptTag
serialiseRequest Proxy HtmlPayload
_ HttpRequest url method Text HtmlPayload acceptTag
r =
    let b :: Text
b = HttpRequest url method Text HtmlPayload acceptTag -> Text
forall url (method :: Symbol) body contentTag acceptTag.
HttpRequest url method body contentTag acceptTag -> body
requestBody HttpRequest url method Text HtmlPayload acceptTag
r
        lbs :: ByteString
lbs = ByteString -> ByteString
LB.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
b 
    in HttpRequest url method Text HtmlPayload acceptTag
r { requestBody :: RawRequestPayload
requestBody = Word64 -> SerialT IO Word8 -> RawRequestPayload
DefinedContentLength (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word64) -> (ByteString -> Int64) -> ByteString -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
LB.length (ByteString -> Word64) -> ByteString -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString
lbs) (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
lbs) }

instance ResponsePayload T.Text HtmlPayload where
  deserialiseRequest :: Proxy HtmlPayload
-> HttpResponse (SerialT IO Word8) -> IO (HttpResponse Text)
deserialiseRequest Proxy HtmlPayload
_ HttpResponse (SerialT IO Word8)
resp = HttpResponse (SerialT IO Word8) -> IO (HttpResponse Text)
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
HttpResponse (SerialT m Word8) -> m (HttpResponse Text)
decodeTextContent HttpResponse (SerialT IO Word8)
resp

-- | A type tag used to indicate that a request\/response should be encoded\/decoded as @text/html@ data
html :: Proxy HtmlPayload
html :: Proxy HtmlPayload
html = Proxy HtmlPayload
forall k (t :: k). Proxy t
Proxy :: Proxy HtmlPayload