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

 There are a number of ways to extract a body from a request:

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

 The 'jsonRequestBody' middleware attempts to convert a JSON
 formatted body to a Haskell value or invoke an error handler if that
 fails. It uses the standard "application/json" media type.

 The 'jsonRequestBody'' middleware is similar but supports custom
 media types.

 Similarly, there are a number of ways to set a response body:

 The easiest option is to use one of 'respondA', 'respondJsonA', or
 'respondJsonA'' middlewares. These middlewares generate a response
 from an HTTP status and a response body.

 If you need finer control over setting the body, use one of
 'setBody', 'setBodyWithoutContentType', 'setJSONBody',
 'setJSONBodyWithoutContentType', or 'setJSONBody''. These arrows
 accept a linked 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 (..),
  JSONBody (..),

  -- * Middlewares
  requestBody,
  jsonRequestBody',
  jsonRequestBody,
  respondA,
  respondJsonA,
  respondJsonA',
  setBody,
  setBodyWithoutContentType,
  setJSONBody,
  setJSONBodyWithoutContentType,
  setJSONBody',
) where

import Control.Arrow (ArrowChoice)
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 (Middleware)
import WebGear.Core.Request (Request)
import WebGear.Core.Response (Response)
import WebGear.Core.Trait (Get, Linked, Set, Sets, Trait (..), TraitAbsence (..), plant, probe)
import WebGear.Core.Trait.Header (Header (..), RequiredHeader)
import WebGear.Core.Trait.Status (Status, mkResponse)

-- | Request or response body with a type @t@.
newtype Body (t :: Type) = Body (Maybe HTTP.MediaType)

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

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

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

-- | A 'Trait' for converting a JSON formatted body into a value.
newtype JSONBody (t :: Type) = JSONBody (Maybe HTTP.MediaType)

instance Trait (JSONBody t) Request where
  type Attribute (JSONBody t) Request = t

instance TraitAbsence (JSONBody t) Request where
  type Absence (JSONBody t) Request = Text

instance Trait (JSONBody t) Response where
  type Attribute (JSONBody t) Response = t

{- | 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 @t (Just "text/plain") errorHandler nextHandler
-}
requestBody ::
  forall t h req.
  (Get h (Body t) Request, ArrowChoice h) =>
  -- | Optional media type of the body
  Maybe HTTP.MediaType ->
  -- | Error handler in case body cannot be retrieved
  h (Linked req Request, Text) Response ->
  Middleware h req (Body t : req)
requestBody :: Maybe MediaType
-> h (Linked req Request, Text) Response
-> Middleware h req (Body t : req)
requestBody Maybe MediaType
mediaType h (Linked req Request, Text) Response
errorHandler RequestHandler h (Body t : req)
nextHandler = proc Linked req Request
request -> do
  Either Text (Linked (Body t : req) Request)
result <- Body t
-> h (Linked req Request)
     (Either (Absence (Body t) Request) (Linked (Body t : req) Request))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (Linked ts a) (Either (Absence t a) (Linked (t : ts) a))
probe (Maybe MediaType -> Body t
forall t. Maybe MediaType -> Body t
Body Maybe MediaType
mediaType) -< Linked req Request
request
  case Either Text (Linked (Body t : req) Request)
result of
    Left Text
err -> h (Linked req Request, Text) Response
errorHandler -< (Linked req Request
request, Text
err)
    Right Linked (Body t : req) Request
t -> RequestHandler h (Body t : req)
nextHandler -< Linked (Body t : req) Request
t

{- | Parse the request body as JSON and convert it to a value of type
   @t@.

 The @nextHandler@ is invoked when the body is parsed successfully and
 the @errorHandler@ is invoked when there is a parsing failure.

 Usage:

 > jsonRequestBody @t errorHandler nextHandler
-}
jsonRequestBody' ::
  forall t h req.
  (Get h (JSONBody t) Request, ArrowChoice h) =>
  -- | Optional media type of the body
  Maybe HTTP.MediaType ->
  -- | Error handler in case body cannot be retrieved
  h (Linked req Request, Text) Response ->
  Middleware h req (JSONBody t : req)
jsonRequestBody' :: Maybe MediaType
-> h (Linked req Request, Text) Response
-> Middleware h req (JSONBody t : req)
jsonRequestBody' Maybe MediaType
mediaType h (Linked req Request, Text) Response
errorHandler RequestHandler h (JSONBody t : req)
nextHandler = proc Linked req Request
request -> do
  Either Text (Linked (JSONBody t : req) Request)
result <- JSONBody t
-> h (Linked req Request)
     (Either
        (Absence (JSONBody t) Request) (Linked (JSONBody t : req) Request))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (Linked ts a) (Either (Absence t a) (Linked (t : ts) a))
probe (Maybe MediaType -> JSONBody t
forall t. Maybe MediaType -> JSONBody t
JSONBody Maybe MediaType
mediaType) -< Linked req Request
request
  case Either Text (Linked (JSONBody t : req) Request)
result of
    Left Text
err -> h (Linked req Request, Text) Response
errorHandler -< (Linked req Request
request, Text
err)
    Right Linked (JSONBody t : req) Request
t -> RequestHandler h (JSONBody t : req)
nextHandler -< Linked (JSONBody t : req) Request
t

-- | Same as 'jsonRequestBody'' but with a media type @application/json@.
jsonRequestBody ::
  forall t h req.
  (Get h (JSONBody t) Request, ArrowChoice h) =>
  -- | error handler
  h (Linked req Request, Text) Response ->
  Middleware h req (JSONBody t : req)
jsonRequestBody :: h (Linked req Request, Text) Response
-> Middleware h req (JSONBody t : req)
jsonRequestBody = Maybe MediaType
-> h (Linked req Request, Text) Response
-> Middleware h req (JSONBody t : req)
forall t (h :: * -> * -> *) (req :: [*]).
(Get h (JSONBody t) Request, ArrowChoice h) =>
Maybe MediaType
-> h (Linked req Request, Text) Response
-> Middleware h req (JSONBody t : req)
jsonRequestBody' (MediaType -> Maybe MediaType
forall a. a -> Maybe a
Just MediaType
"application/json")

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

  The media type value is used to set the "Content-Type" header in the response.
-}
setBody ::
  forall body a h ts.
  Sets h [Body body, RequiredHeader "Content-Type" Text] Response =>
  -- | The media type of the response body
  HTTP.MediaType ->
  h a (Linked ts Response) ->
  h (body, a) (Linked (RequiredHeader "Content-Type" Text : Body body : ts) Response)
setBody :: MediaType
-> h a (Linked ts Response)
-> h (body, a)
     (Linked
        (RequiredHeader "Content-Type" Text : Body body : ts) Response)
setBody MediaType
mediaType h a (Linked ts Response)
prevHandler = proc (body
body, a
a) -> do
  Linked ts Response
r <- h a (Linked ts Response)
prevHandler -< a
a
  Linked (Body body : ts) Response
r' <- Body body
-> h (Linked ts Response, Attribute (Body body) Response)
     (Linked (Body body : ts) Response)
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant (Maybe MediaType -> Body body
forall t. Maybe MediaType -> Body t
Body (MediaType -> Maybe MediaType
forall a. a -> Maybe a
Just MediaType
mediaType)) -< (Linked ts Response
r, body
body)
  let mt :: Text
mt = 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
mediaType
  RequiredHeader "Content-Type" Text
-> h (Linked (Body body : ts) Response,
      Attribute (RequiredHeader "Content-Type" Text) Response)
     (Linked
        (RequiredHeader "Content-Type" Text : Body body : ts) Response)
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant RequiredHeader "Content-Type" Text
forall (e :: Existence) (p :: ParseStyle) (name :: Symbol) val.
Header e p name val
Header -< (Linked (Body body : ts) Response
r', Text
mt)

-- | Set the response body without specifying any media type.
setBodyWithoutContentType ::
  forall body a h ts.
  Set h (Body body) Response =>
  h a (Linked ts Response) ->
  h (body, a) (Linked (Body body : ts) Response)
setBodyWithoutContentType :: h a (Linked ts Response)
-> h (body, a) (Linked (Body body : ts) Response)
setBodyWithoutContentType h a (Linked ts Response)
prevHandler = proc (body
body, a
a) -> do
  Linked ts Response
r <- h a (Linked ts Response)
prevHandler -< a
a
  Body body
-> h (Linked ts Response, Attribute (Body body) Response)
     (Linked (Body body : ts) Response)
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant (Maybe MediaType -> Body body
forall t. Maybe MediaType -> Body t
Body Maybe MediaType
forall a. Maybe a
Nothing) -< (Linked ts Response
r, body
body)

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

  The media type value is used to set the "Content-Type" header in the response.
-}
setJSONBody' ::
  forall body a h ts.
  Sets h [JSONBody body, RequiredHeader "Content-Type" Text] Response =>
  -- | The media type of the response body
  HTTP.MediaType ->
  h a (Linked ts Response) ->
  h (body, a) (Linked (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
setJSONBody' :: MediaType
-> h a (Linked ts Response)
-> h (body, a)
     (Linked
        (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
setJSONBody' MediaType
mediaType h a (Linked ts Response)
prevHandler = proc (body
body, a
a) -> do
  Linked ts Response
r <- h a (Linked ts Response)
prevHandler -< a
a
  Linked (JSONBody body : ts) Response
r' <- JSONBody body
-> h (Linked ts Response, Attribute (JSONBody body) Response)
     (Linked (JSONBody body : ts) Response)
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant (Maybe MediaType -> JSONBody body
forall t. Maybe MediaType -> JSONBody t
JSONBody (MediaType -> Maybe MediaType
forall a. a -> Maybe a
Just MediaType
mediaType)) -< (Linked ts Response
r, body
body)
  let mt :: Text
mt = 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
mediaType
  RequiredHeader "Content-Type" Text
-> h (Linked (JSONBody body : ts) Response,
      Attribute (RequiredHeader "Content-Type" Text) Response)
     (Linked
        (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant RequiredHeader "Content-Type" Text
forall (e :: Existence) (p :: ParseStyle) (name :: Symbol) val.
Header e p name val
Header -< (Linked (JSONBody body : ts) Response
r', Text
mt)

{- | Set the response body to a JSON value.

  The "Content-Type" header will be set to "application/json".
-}
setJSONBody ::
  forall body a h ts.
  Sets h [JSONBody body, RequiredHeader "Content-Type" Text] Response =>
  h a (Linked ts Response) ->
  h (body, a) (Linked (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
setJSONBody :: h a (Linked ts Response)
-> h (body, a)
     (Linked
        (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
setJSONBody = MediaType
-> h a (Linked ts Response)
-> h (body, a)
     (Linked
        (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
forall body a (h :: * -> * -> *) (ts :: [*]).
Sets
  h '[JSONBody body, RequiredHeader "Content-Type" Text] Response =>
MediaType
-> h a (Linked ts Response)
-> h (body, a)
     (Linked
        (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
setJSONBody' MediaType
"application/json"

{- | Set the response body to a JSON value without specifying any
 media type.
-}
setJSONBodyWithoutContentType ::
  forall body a h ts.
  Set h (JSONBody body) Response =>
  h a (Linked ts Response) ->
  h (body, a) (Linked (JSONBody body : ts) Response)
setJSONBodyWithoutContentType :: h a (Linked ts Response)
-> h (body, a) (Linked (JSONBody body : ts) Response)
setJSONBodyWithoutContentType h a (Linked ts Response)
prevHandler = proc (body
body, a
a) -> do
  Linked ts Response
r <- h a (Linked ts Response)
prevHandler -< a
a
  JSONBody body
-> h (Linked ts Response, Attribute (JSONBody body) Response)
     (Linked (JSONBody body : ts) Response)
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant (Maybe MediaType -> JSONBody body
forall t. Maybe MediaType -> JSONBody t
JSONBody Maybe MediaType
forall a. Maybe a
Nothing) -< (Linked ts Response
r, body
body)

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

 The "Content-Type" header will be set to the specified media type
 value.
-}
respondA ::
  forall body h.
  Sets h [Status, Body body, RequiredHeader "Content-Type" Text] Response =>
  -- | Response status
  HTTP.Status ->
  -- | Media type of the response body
  HTTP.MediaType ->
  h body (Linked [RequiredHeader "Content-Type" Text, Body body, Status] Response)
respondA :: Status
-> MediaType
-> h body
     (Linked
        '[RequiredHeader "Content-Type" Text, Body body, Status] Response)
respondA Status
status MediaType
mediaType = proc body
body ->
  MediaType
-> h () (Linked '[Status] Response)
-> h (body, ())
     (Linked
        '[RequiredHeader "Content-Type" Text, Body body, Status] Response)
forall body a (h :: * -> * -> *) (ts :: [*]).
Sets h '[Body body, RequiredHeader "Content-Type" Text] Response =>
MediaType
-> h a (Linked ts Response)
-> h (body, a)
     (Linked
        (RequiredHeader "Content-Type" Text : Body body : ts) Response)
setBody MediaType
mediaType (Status -> h () (Linked '[Status] Response)
forall (h :: * -> * -> *).
Set h Status Response =>
Status -> h () (Linked '[Status] Response)
mkResponse Status
status) -< (body
body, ())

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

 The "Content-Type" header will be set to "application/json".
-}
respondJsonA ::
  forall body h.
  Sets h [Status, JSONBody body, RequiredHeader "Content-Type" Text] Response =>
  -- | Response status
  HTTP.Status ->
  h body (Linked [RequiredHeader "Content-Type" Text, JSONBody body, Status] Response)
respondJsonA :: Status
-> h body
     (Linked
        '[RequiredHeader "Content-Type" Text, JSONBody body, Status]
        Response)
respondJsonA Status
status = Status
-> MediaType
-> h body
     (Linked
        '[RequiredHeader "Content-Type" Text, JSONBody body, Status]
        Response)
forall body (h :: * -> * -> *).
Sets
  h
  '[Status, JSONBody body, RequiredHeader "Content-Type" Text]
  Response =>
Status
-> MediaType
-> h body
     (Linked
        '[RequiredHeader "Content-Type" Text, JSONBody body, Status]
        Response)
respondJsonA' Status
status MediaType
"application/json"

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

 The "Content-Type" header will be set to the specified media type
 value.
-}
respondJsonA' ::
  forall body h.
  Sets h [Status, JSONBody body, RequiredHeader "Content-Type" Text] Response =>
  -- | Response status
  HTTP.Status ->
  -- | Media type of the response body
  HTTP.MediaType ->
  h body (Linked [RequiredHeader "Content-Type" Text, JSONBody body, Status] Response)
respondJsonA' :: Status
-> MediaType
-> h body
     (Linked
        '[RequiredHeader "Content-Type" Text, JSONBody body, Status]
        Response)
respondJsonA' Status
status MediaType
mediaType = proc body
body ->
  MediaType
-> h () (Linked '[Status] Response)
-> h (body, ())
     (Linked
        '[RequiredHeader "Content-Type" Text, JSONBody body, Status]
        Response)
forall body a (h :: * -> * -> *) (ts :: [*]).
Sets
  h '[JSONBody body, RequiredHeader "Content-Type" Text] Response =>
MediaType
-> h a (Linked ts Response)
-> h (body, a)
     (Linked
        (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
setJSONBody' MediaType
mediaType (Status -> h () (Linked '[Status] Response)
forall (h :: * -> * -> *).
Set h Status Response =>
Status -> h () (Linked '[Status] Response)
mkResponse Status
status) -< (body
body, ())