{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Server implementation of the `Body` trait.
module WebGear.Server.Trait.Body () where

import Control.Monad.Trans (lift)
import Data.Text (Text)
import qualified Network.HTTP.Media as HTTP
import qualified Network.HTTP.Types as HTTP
import WebGear.Core.Handler (Handler (..))
import WebGear.Core.Request (Request (..))
import WebGear.Core.Response (Response (..), ResponseBody)
import WebGear.Core.Trait (Get (..), Set (..), With, unwitness)
import WebGear.Core.Trait.Body (Body (..), UnknownContentBody (..))
import WebGear.Server.Handler (ServerHandler (..))
import WebGear.Server.MIMETypes (BodyRender (..), BodyUnrender (..))

instance (Monad m, BodyUnrender m mt val) => Get (ServerHandler m) (Body mt val) Request where
  {-# INLINE getTrait #-}
  getTrait :: Body mt val -> ServerHandler m (Request `With` ts) (Either Text val)
  getTrait :: forall (ts :: [*]).
Body mt val -> ServerHandler m (With Request ts) (Either Text val)
getTrait (Body mt
mt) = forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) mt a.
BodyUnrender m mt a =>
mt -> Request -> m (Either Text a)
bodyUnrender mt
mt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (ts :: [*]). With a ts -> a
unwitness

instance (Monad m, BodyRender m mt val) => Set (ServerHandler m) (Body mt val) Response where
  {-# INLINE setTrait #-}
  setTrait ::
    Body mt val ->
    (Response `With` ts -> Response -> val -> Response `With` (Body mt val : ts)) ->
    ServerHandler m (Response `With` ts, val) (Response `With` (Body mt val : ts))
  setTrait :: forall (ts :: [*]).
Body mt val
-> (With Response ts
    -> Response -> val -> With Response (Body mt val : ts))
-> ServerHandler
     m (With Response ts, val) (With Response (Body mt val : ts))
setTrait (Body mt
mt) With Response ts
-> Response -> val -> With Response (Body mt val : ts)
f = forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \(With Response ts
wResponse, val
val) -> do
    let response :: Response
response = forall a (ts :: [*]). With a ts -> a
unwitness With Response ts
wResponse
    (MediaType
mediaType, ResponseBody
responseBody) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) mt a.
BodyRender m mt a =>
mt -> Response -> a -> m (MediaType, ResponseBody)
bodyRender mt
mt Response
response val
val

    let response' :: Response
response' =
          Response
response
            { ResponseBody
responseBody :: ResponseBody
responseBody :: ResponseBody
responseBody
            , responseHeaders :: [(HeaderName, ByteString)]
responseHeaders = MediaType
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
alterContentType MediaType
mediaType (Response -> [(HeaderName, ByteString)]
responseHeaders Response
response)
            }

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ With Response ts
-> Response -> val -> With Response (Body mt val : ts)
f With Response ts
wResponse Response
response' val
val

alterContentType :: HTTP.MediaType -> HTTP.ResponseHeaders -> HTTP.ResponseHeaders
alterContentType :: MediaType
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
alterContentType MediaType
mt = [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
go
  where
    mtStr :: ByteString
mtStr = forall h. RenderHeader h => h -> ByteString
HTTP.renderHeader MediaType
mt
    go :: [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
go [] = [(HeaderName
HTTP.hContentType, ByteString
mtStr)]
    go ((HeaderName
n, ByteString
v) : [(HeaderName, ByteString)]
hdrs)
      | HeaderName
n forall a. Eq a => a -> a -> Bool
== HeaderName
HTTP.hContentType = (HeaderName
HTTP.hContentType, ByteString
mtStr) forall a. a -> [a] -> [a]
: [(HeaderName, ByteString)]
hdrs
      | Bool
otherwise = (HeaderName
n, ByteString
v) forall a. a -> [a] -> [a]
: [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
go [(HeaderName, ByteString)]
hdrs

instance (Monad m) => Set (ServerHandler m) UnknownContentBody Response where
  {-# INLINE setTrait #-}
  setTrait ::
    UnknownContentBody ->
    (Response `With` ts -> Response -> ResponseBody -> Response `With` (UnknownContentBody : ts)) ->
    ServerHandler m (Response `With` ts, ResponseBody) (Response `With` (UnknownContentBody : ts))
  setTrait :: forall (ts :: [*]).
UnknownContentBody
-> (With Response ts
    -> Response
    -> ResponseBody
    -> With Response (UnknownContentBody : ts))
-> ServerHandler
     m
     (With Response ts, ResponseBody)
     (With Response (UnknownContentBody : ts))
setTrait UnknownContentBody
UnknownContentBody With Response ts
-> Response
-> ResponseBody
-> With Response (UnknownContentBody : ts)
f = forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \(With Response ts
wResponse, ResponseBody
responseBody) -> do
    let response' :: Response
response' = (forall a (ts :: [*]). With a ts -> a
unwitness With Response ts
wResponse){ResponseBody
responseBody :: ResponseBody
responseBody :: ResponseBody
responseBody}
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ With Response ts
-> Response
-> ResponseBody
-> With Response (UnknownContentBody : ts)
f With Response ts
wResponse Response
response' ResponseBody
responseBody