{- | Traits and middlewares to handle request and response body
   payloads.

 The 'requestBody' middleware attempts to convert the body to a
 Haskell value or invoke an error handler if that fails.

 The 'respondA' middleware generates a response from an HTTP status
 and a response body.

 If you need finer control over setting the body, use 'setBody' or
 'setBodyWithoutContentType'. These arrows accept a witnessed response
 and a body and sets the body in the response. You can generate an
 input response object using functions from
 "WebGear.Core.Trait.Status" module.
-}
module WebGear.Core.Trait.Body (
  -- * Traits
  Body (..),
  UnknownContentBody (..),

  -- * Middlewares
  requestBody,
  respondA,
  setBody,
  setBodyWithoutContentType,
) where

import Control.Arrow ((<<<))
import Data.Kind (Type)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import qualified Network.HTTP.Media as HTTP
import qualified Network.HTTP.Types as HTTP
import WebGear.Core.Handler (Handler (..), Middleware, unwitnessA)
import WebGear.Core.MIMETypes (MIMEType (..))
import WebGear.Core.Request (Request)
import WebGear.Core.Response (Response, ResponseBody)
import WebGear.Core.Trait (
  Get,
  Prerequisite,
  Set,
  Sets,
  Trait (..),
  TraitAbsence (..),
  With (..),
  plant,
  probe,
 )
import WebGear.Core.Trait.Header (RequiredResponseHeader, ResponseHeader (..))
import WebGear.Core.Trait.Status (Status, mkResponse)

-- | Request or response body with MIME types @mimeTypes@ and type @t@.
newtype Body (mimeType :: Type) (t :: Type) = Body mimeType

instance Trait (Body mt t) Request where
  type Attribute (Body mt t) Request = t

instance TraitAbsence (Body mt t) Request where
  type Absence (Body mt t) Request = Text

type instance Prerequisite (Body mt t) ts Request = ()

instance Trait (Body mt t) Response where
  type Attribute (Body mt t) Response = t

-- | Type representing responses without a statically known MIME type
data UnknownContentBody = UnknownContentBody

instance Trait UnknownContentBody Response where
  type Attribute UnknownContentBody Response = ResponseBody

{- | Middleware to extract a request body.

 The @nextHandler@ is invoked after successfully extracting the body
 and the @errorHandler@ is invoked when there is an error.

 Usage:

@
 requestBody \@'Text' 'WebGear.Core.MIMETypes.PlainText' errorHandler nextHandler
@
-}
requestBody ::
  forall t mt h m ts.
  ( Handler h m
  , Get h (Body mt t) Request
  ) =>
  mt ->
  -- | Error handler in case body cannot be retrieved
  h (Request `With` ts, Text) Response ->
  Middleware h ts (Body mt t : ts)
requestBody :: forall t mt (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Handler h m, Get h (Body mt t) Request) =>
mt
-> h (With Request ts, Text) Response
-> Middleware h ts (Body mt t : ts)
requestBody mt
mt h (With Request ts, Text) Response
errorHandler RequestHandler h (Body mt t : ts)
nextHandler = proc With Request ts
request -> do
  Either Text (With Request (Body mt t : ts))
result <- Body mt t
-> h (With Request ts)
     (Either
        (Absence (Body mt t) Request) (With Request (Body mt t : ts)))
forall t (ts :: [*]) (h :: * -> * -> *) a.
(Get h t a, Prerequisite t ts a) =>
t -> h (With a ts) (Either (Absence t a) (With a (t : ts)))
probe (mt -> Body mt t
forall mimeType t. mimeType -> Body mimeType t
Body mt
mt) -< With Request ts
request
  case Either Text (With Request (Body mt t : ts))
result of
    Left Text
err -> h (With Request ts, Text) Response
errorHandler -< (With Request ts
request, Text
err)
    Right With Request (Body mt t : ts)
t -> RequestHandler h (Body mt t : ts)
nextHandler -< With Request (Body mt t : ts)
t
{-# INLINE requestBody #-}

{- | Set the response body along with a media type.

 The MIME type @mt@ is used to set the "Content-Type" header in the
 response.

 Usage:

@
 let body :: SomeJSONType = ...
 response' <- setBody 'WebGear.Core.MIMETypes.JSON' -< (response, body)
@
-}
setBody ::
  forall body mt h ts.
  ( Sets h [Body mt body, RequiredResponseHeader "Content-Type" Text] Response
  , MIMEType mt
  ) =>
  mt ->
  h (Response `With` ts, body) (Response `With` (Body mt body : RequiredResponseHeader "Content-Type" Text : ts))
setBody :: forall body mt (h :: * -> * -> *) (ts :: [*]).
(Sets
   h
   '[Body mt body, RequiredResponseHeader "Content-Type" Text]
   Response,
 MIMEType mt) =>
mt
-> h (With Response ts, body)
     (With
        Response
        (Body mt body : RequiredResponseHeader "Content-Type" Text : ts))
setBody mt
mt = proc (With Response ts
response, body
body) -> do
  let ct :: MediaType
ct = mt -> MediaType
forall mt. MIMEType mt => mt -> MediaType
mimeType mt
mt
  With Response (RequiredResponseHeader "Content-Type" Text : ts)
response' <- RequiredResponseHeader "Content-Type" Text
-> h (With Response ts,
      Attribute (RequiredResponseHeader "Content-Type" Text) Response)
     (With Response (RequiredResponseHeader "Content-Type" Text : ts))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant RequiredResponseHeader "Content-Type" Text
forall (e :: Existence) (name :: Symbol) val.
ResponseHeader e name val
ResponseHeader -< (With Response ts
response, ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
HTTP.renderHeader MediaType
ct)
  Body mt body
-> h (With
        Response (RequiredResponseHeader "Content-Type" Text : ts),
      Attribute (Body mt body) Response)
     (With
        Response
        (Body mt body : RequiredResponseHeader "Content-Type" Text : ts))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant (mt -> Body mt body
forall mimeType t. mimeType -> Body mimeType t
Body mt
mt) -< (With Response (RequiredResponseHeader "Content-Type" Text : ts)
response', body
body)
{-# INLINE setBody #-}

{- | Set the response body without specifying any media type.

Usage:

@
 let body :: ResponseBody = ...
 response' <- setBodyWithoutContentType -< (response, body)
@
-}
setBodyWithoutContentType ::
  forall h ts.
  (Set h UnknownContentBody Response) =>
  h (Response `With` ts, ResponseBody) (Response `With` (UnknownContentBody : ts))
setBodyWithoutContentType :: forall (h :: * -> * -> *) (ts :: [*]).
Set h UnknownContentBody Response =>
h (With Response ts, ResponseBody)
  (With Response (UnknownContentBody : ts))
setBodyWithoutContentType = UnknownContentBody
-> h (With Response ts, Attribute UnknownContentBody Response)
     (With Response (UnknownContentBody : ts))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant UnknownContentBody
UnknownContentBody
{-# INLINE setBodyWithoutContentType #-}

{- | A convenience arrow to generate a response specifying a status and body.

 The "Content-Type" header will be set to the value specified by @mt@.

 Usage:

@
 let body :: SomeJSONType = ...
 respondA 'HTTP.ok200' 'WebGear.Core.MIMETypes.JSON' -< body
@
-}
respondA ::
  forall body mt h m.
  ( Handler h m
  , Sets h [Status, Body mt body, RequiredResponseHeader "Content-Type" Text] Response
  , MIMEType mt
  ) =>
  -- | Response status
  HTTP.Status ->
  mt ->
  h body Response
respondA :: forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body, RequiredResponseHeader "Content-Type" Text]
   Response,
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
status mt
mt = proc body
body -> do
  With Response '[Status]
response <- Status -> h () (With Response '[Status])
forall (h :: * -> * -> *).
Set h Status Response =>
Status -> h () (With Response '[Status])
mkResponse Status
status -< ()
  h (With
     Response
     '[Body mt body, RequiredResponseHeader "Content-Type" Text,
       Status])
  Response
forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (With Response ts) Response
unwitnessA h (With
     Response
     '[Body mt body, RequiredResponseHeader "Content-Type" Text,
       Status])
  Response
-> h (With Response '[Status], body)
     (With
        Response
        '[Body mt body, RequiredResponseHeader "Content-Type" Text,
          Status])
-> h (With Response '[Status], body) Response
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< mt
-> h (With Response '[Status], body)
     (With
        Response
        '[Body mt body, RequiredResponseHeader "Content-Type" Text,
          Status])
forall body mt (h :: * -> * -> *) (ts :: [*]).
(Sets
   h
   '[Body mt body, RequiredResponseHeader "Content-Type" Text]
   Response,
 MIMEType mt) =>
mt
-> h (With Response ts, body)
     (With
        Response
        (Body mt body : RequiredResponseHeader "Content-Type" Text : ts))
setBody mt
mt -< (With Response '[Status]
response, body
body)
{-# INLINE respondA #-}