{-# 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) = (With Request ts -> m (Either Text val))
-> ServerHandler m (With Request ts) (Either Text val)
forall a b. (a -> m b) -> ServerHandler m a b
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM ((With Request ts -> m (Either Text val))
 -> ServerHandler m (With Request ts) (Either Text val))
-> (With Request ts -> m (Either Text val))
-> ServerHandler m (With Request ts) (Either Text val)
forall a b. (a -> b) -> a -> b
$ mt -> Request -> m (Either Text val)
forall (m :: * -> *) mt a.
BodyUnrender m mt a =>
mt -> Request -> m (Either Text a)
bodyUnrender mt
mt (Request -> m (Either Text val))
-> (With Request ts -> Request)
-> With Request ts
-> m (Either Text val)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. With Request ts -> Request
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 = ((With Response ts, val)
 -> StateT
      RoutePath
      (ExceptT RouteMismatch m)
      (With Response (Body mt val : ts)))
-> ServerHandler
     m (With Response ts, val) (With Response (Body mt val : ts))
forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler (((With Response ts, val)
  -> StateT
       RoutePath
       (ExceptT RouteMismatch m)
       (With Response (Body mt val : ts)))
 -> ServerHandler
      m (With Response ts, val) (With Response (Body mt val : ts)))
-> ((With Response ts, val)
    -> StateT
         RoutePath
         (ExceptT RouteMismatch m)
         (With Response (Body mt val : ts)))
-> ServerHandler
     m (With Response ts, val) (With Response (Body mt val : ts))
forall a b. (a -> b) -> a -> b
$ \(With Response ts
wResponse, val
val) -> do
    let response :: Response
response = With Response ts -> Response
forall a (ts :: [*]). With a ts -> a
unwitness With Response ts
wResponse
    case Response
response of
      Response Status
status [(HeaderName, ByteString)]
hdrs ResponseBody
_ -> do
        (MediaType
mediaType, ResponseBody
body') <- ExceptT RouteMismatch m (MediaType, ResponseBody)
-> StateT
     RoutePath (ExceptT RouteMismatch m) (MediaType, ResponseBody)
forall (m :: * -> *) a. Monad m => m a -> StateT RoutePath m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RouteMismatch m (MediaType, ResponseBody)
 -> StateT
      RoutePath (ExceptT RouteMismatch m) (MediaType, ResponseBody))
-> ExceptT RouteMismatch m (MediaType, ResponseBody)
-> StateT
     RoutePath (ExceptT RouteMismatch m) (MediaType, ResponseBody)
forall a b. (a -> b) -> a -> b
$ m (MediaType, ResponseBody)
-> ExceptT RouteMismatch m (MediaType, ResponseBody)
forall (m :: * -> *) a. Monad m => m a -> ExceptT RouteMismatch m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (MediaType, ResponseBody)
 -> ExceptT RouteMismatch m (MediaType, ResponseBody))
-> m (MediaType, ResponseBody)
-> ExceptT RouteMismatch m (MediaType, ResponseBody)
forall a b. (a -> b) -> a -> b
$ mt -> Response -> val -> m (MediaType, ResponseBody)
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' = Status -> [(HeaderName, ByteString)] -> ResponseBody -> Response
Response Status
status (MediaType
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
alterContentType MediaType
mediaType [(HeaderName, ByteString)]
hdrs) ResponseBody
body'
        With Response (Body mt val : ts)
-> StateT
     RoutePath
     (ExceptT RouteMismatch m)
     (With Response (Body mt val : ts))
forall a. a -> StateT RoutePath (ExceptT RouteMismatch m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (With Response (Body mt val : ts)
 -> StateT
      RoutePath
      (ExceptT RouteMismatch m)
      (With Response (Body mt val : ts)))
-> With Response (Body mt val : ts)
-> StateT
     RoutePath
     (ExceptT RouteMismatch m)
     (With Response (Body mt val : ts))
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
      Response
_ -> With Response (Body mt val : ts)
-> StateT
     RoutePath
     (ExceptT RouteMismatch m)
     (With Response (Body mt val : ts))
forall a. a -> StateT RoutePath (ExceptT RouteMismatch m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (With Response (Body mt val : ts)
 -> StateT
      RoutePath
      (ExceptT RouteMismatch m)
      (With Response (Body mt val : ts)))
-> With Response (Body mt val : ts)
-> StateT
     RoutePath
     (ExceptT RouteMismatch m)
     (With Response (Body mt val : ts))
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 = MediaType -> ByteString
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 HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
HTTP.hContentType = (HeaderName
HTTP.hContentType, ByteString
mtStr) (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: [(HeaderName, ByteString)]
hdrs
      | Bool
otherwise = (HeaderName
n, ByteString
v) (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
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 = ((With Response ts, ResponseBody)
 -> StateT
      RoutePath
      (ExceptT RouteMismatch m)
      (With Response (UnknownContentBody : ts)))
-> ServerHandler
     m
     (With Response ts, ResponseBody)
     (With Response (UnknownContentBody : ts))
forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler (((With Response ts, ResponseBody)
  -> StateT
       RoutePath
       (ExceptT RouteMismatch m)
       (With Response (UnknownContentBody : ts)))
 -> ServerHandler
      m
      (With Response ts, ResponseBody)
      (With Response (UnknownContentBody : ts)))
-> ((With Response ts, ResponseBody)
    -> StateT
         RoutePath
         (ExceptT RouteMismatch m)
         (With Response (UnknownContentBody : ts)))
-> ServerHandler
     m
     (With Response ts, ResponseBody)
     (With Response (UnknownContentBody : ts))
forall a b. (a -> b) -> a -> b
$ \(With Response ts
wResponse, ResponseBody
body') ->
    case With Response ts -> Response
forall a (ts :: [*]). With a ts -> a
unwitness With Response ts
wResponse of
      Response Status
status [(HeaderName, ByteString)]
hdrs ResponseBody
_ -> With Response (UnknownContentBody : ts)
-> StateT
     RoutePath
     (ExceptT RouteMismatch m)
     (With Response (UnknownContentBody : ts))
forall a. a -> StateT RoutePath (ExceptT RouteMismatch m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (With Response (UnknownContentBody : ts)
 -> StateT
      RoutePath
      (ExceptT RouteMismatch m)
      (With Response (UnknownContentBody : ts)))
-> With Response (UnknownContentBody : ts)
-> StateT
     RoutePath
     (ExceptT RouteMismatch m)
     (With Response (UnknownContentBody : ts))
forall a b. (a -> b) -> a -> b
$ With Response ts
-> Response
-> ResponseBody
-> With Response (UnknownContentBody : ts)
f With Response ts
wResponse (Status -> [(HeaderName, ByteString)] -> ResponseBody -> Response
Response Status
status [(HeaderName, ByteString)]
hdrs ResponseBody
body') ResponseBody
body'
      Response
response -> With Response (UnknownContentBody : ts)
-> StateT
     RoutePath
     (ExceptT RouteMismatch m)
     (With Response (UnknownContentBody : ts))
forall a. a -> StateT RoutePath (ExceptT RouteMismatch m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (With Response (UnknownContentBody : ts)
 -> StateT
      RoutePath
      (ExceptT RouteMismatch m)
      (With Response (UnknownContentBody : ts)))
-> With Response (UnknownContentBody : ts)
-> StateT
     RoutePath
     (ExceptT RouteMismatch m)
     (With Response (UnknownContentBody : ts))
forall a b. (a -> b) -> a -> b
$ With Response ts
-> Response
-> ResponseBody
-> With Response (UnknownContentBody : ts)
f With Response ts
wResponse Response
response ResponseBody
body'