-- |
-- Copyright        : (c) Raghu Kaippully, 2020
-- License          : MPL-2.0
-- Maintainer       : rkaippully@gmail.com
--
-- Middlewares related to HTTP body.
module WebGear.Middlewares.Body
  ( jsonRequestBody
  , jsonResponseBody
  ) where

import Control.Arrow (Kleisli (..))
import Control.Monad ((>=>))
import Control.Monad.IO.Class (MonadIO)
import Data.Aeson (FromJSON, ToJSON, encode)
import Data.ByteString.Lazy (ByteString, fromStrict)
import Data.HashMap.Strict (fromList, insert)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Types (badRequest400, hContentType)

import WebGear.Route (MonadRouter (..))
import WebGear.Trait (linkplus, linkzero, unlink)
import WebGear.Trait.Body (JSONRequestBody)
import WebGear.Types (Middleware, RequestMiddleware, Response (..))


-- | A middleware to parse the request body as JSON and convert it to
-- a value via a 'FromJSON' instance.
--
-- Usage for a type @t@ which has a 'FromJSON' instance:
--
-- > jsonRequestBody @t handler
--
jsonRequestBody :: forall t m req res a. (FromJSON t, MonadRouter m, MonadIO m)
                => RequestMiddleware m req (JSONRequestBody t:req) res a
jsonRequestBody :: RequestMiddleware m req (JSONRequestBody t : req) res a
jsonRequestBody handler :: Handler m (JSONRequestBody t : req) res a
handler = (Linked req Request -> m (Linked res (Response a)))
-> Kleisli m (Linked req Request) (Linked res (Response a))
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked req Request -> m (Linked res (Response a)))
 -> Kleisli m (Linked req Request) (Linked res (Response a)))
-> (Linked req Request -> m (Linked res (Response a)))
-> Kleisli m (Linked req Request) (Linked res (Response a))
forall a b. (a -> b) -> a -> b
$
  forall t a (m :: * -> *) (ts :: [*]).
Trait t a m =>
Linked ts a -> m (Either (Fail t a) (Linked (t : ts) a))
forall a (m :: * -> *) (ts :: [*]).
Trait (JSONRequestBody t) a m =>
Linked ts a
-> m (Either
        (Fail (JSONRequestBody t) a) (Linked (JSONRequestBody t : ts) a))
linkplus @(JSONRequestBody t) (Linked req Request
 -> m (Either Text (Linked (JSONRequestBody t : req) Request)))
-> (Either Text (Linked (JSONRequestBody t : req) Request)
    -> m (Linked res (Response a)))
-> Linked req Request
-> m (Linked res (Response a))
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Text -> m (Linked res (Response a)))
-> (Linked (JSONRequestBody t : req) Request
    -> m (Linked res (Response a)))
-> Either Text (Linked (JSONRequestBody t : req) Request)
-> m (Linked res (Response a))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Response ByteString -> m (Linked res (Response a))
forall (m :: * -> *) a. MonadRouter m => Response ByteString -> m a
failHandler (Response ByteString -> m (Linked res (Response a)))
-> (Text -> Response ByteString)
-> Text
-> m (Linked res (Response a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Response ByteString
mkError) (Handler m (JSONRequestBody t : req) res a
-> Linked (JSONRequestBody t : req) Request
-> m (Linked res (Response a))
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler m (JSONRequestBody t : req) res a
handler)
  where
    mkError :: Text -> Response ByteString
    mkError :: Text -> Response ByteString
mkError e :: Text
e = Response :: forall a.
Status -> HashMap HeaderName ByteString -> Maybe a -> Response a
Response
          { respStatus :: Status
respStatus  = Status
badRequest400
          , respHeaders :: HashMap HeaderName ByteString
respHeaders = [(HeaderName, ByteString)] -> HashMap HeaderName ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
fromList []
          , respBody :: Maybe ByteString
respBody    = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ "Error parsing request body: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e
          }

-- | A middleware that converts the response that has a 'ToJSON'
-- instance to a 'ByteString' response.
--
-- This will also set the "Content-Type" header of the response to
-- "application/json".
--
-- Usage for a type @t@ which has a 'ToJSON' instance:
--
-- > jsonResponseBody @t handler
--
jsonResponseBody :: (ToJSON t, Monad m) => Middleware m req req res '[] t ByteString
jsonResponseBody :: Middleware m req req res '[] t ByteString
jsonResponseBody handler :: Handler m req res t
handler = (Linked req Request -> m (Linked '[] (Response ByteString)))
-> Kleisli
     m (Linked req Request) (Linked '[] (Response ByteString))
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked req Request -> m (Linked '[] (Response ByteString)))
 -> Kleisli
      m (Linked req Request) (Linked '[] (Response ByteString)))
-> (Linked req Request -> m (Linked '[] (Response ByteString)))
-> Kleisli
     m (Linked req Request) (Linked '[] (Response ByteString))
forall a b. (a -> b) -> a -> b
$ \req :: Linked req Request
req -> do
  Response t
x <- Linked res (Response t) -> Response t
forall (ts :: [*]) a. Linked ts a -> a
unlink (Linked res (Response t) -> Response t)
-> m (Linked res (Response t)) -> m (Response t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler m req res t
-> Linked req Request -> m (Linked res (Response t))
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler m req res t
handler Linked req Request
req
  pure $ Response ByteString -> Linked '[] (Response ByteString)
forall a. a -> Linked '[] a
linkzero (Response ByteString -> Linked '[] (Response ByteString))
-> Response ByteString -> Linked '[] (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Response :: forall a.
Status -> HashMap HeaderName ByteString -> Maybe a -> Response a
Response
    { respStatus :: Status
respStatus  = Response t -> Status
forall a. Response a -> Status
respStatus Response t
x
    , respHeaders :: HashMap HeaderName ByteString
respHeaders = HeaderName
-> ByteString
-> HashMap HeaderName ByteString
-> HashMap HeaderName ByteString
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert HeaderName
hContentType "application/json" (HashMap HeaderName ByteString -> HashMap HeaderName ByteString)
-> HashMap HeaderName ByteString -> HashMap HeaderName ByteString
forall a b. (a -> b) -> a -> b
$ Response t -> HashMap HeaderName ByteString
forall a. Response a -> HashMap HeaderName ByteString
respHeaders Response t
x
    , respBody :: Maybe ByteString
respBody    = t -> ByteString
forall a. ToJSON a => a -> ByteString
encode (t -> ByteString) -> Maybe t -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response t -> Maybe t
forall a. Response a -> Maybe a
respBody Response t
x
    }