{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
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