module WebGear.Core.Trait.Body (
Body (..),
UnknownContentBody (..),
requestBody,
respondA,
setBody,
setBodyWithoutContentType,
) where
import Control.Arrow ((<<<))
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 (Handler (..), Middleware, unwitnessA)
import WebGear.Core.MIMETypes (MIMEType (..))
import WebGear.Core.Request (Request)
import WebGear.Core.Response (Response, ResponseBody)
import WebGear.Core.Trait (
Get,
Set,
Sets,
Trait (..),
TraitAbsence (..),
With (..),
plant,
probe,
)
import WebGear.Core.Trait.Header (RequiredResponseHeader, ResponseHeader (..))
import WebGear.Core.Trait.Status (Status, mkResponse)
newtype Body (mimeType :: Type) (t :: Type) = Body mimeType
instance Trait (Body mt t) Request where
type Attribute (Body mt t) Request = t
instance TraitAbsence (Body mt t) Request where
type Absence (Body mt t) Request = Text
instance Trait (Body mt t) Response where
type Attribute (Body mt t) Response = t
data UnknownContentBody = UnknownContentBody
instance Trait UnknownContentBody Response where
type Attribute UnknownContentBody Response = ResponseBody
requestBody ::
forall t mt h m ts.
( Handler h m
, Get h (Body mt t) Request
) =>
mt ->
h (Request `With` ts, Text) Response ->
Middleware h ts (Body mt t : ts)
requestBody :: forall t mt (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Handler h m, Get h (Body mt t) Request) =>
mt
-> h (With Request ts, Text) Response
-> Middleware h ts (Body mt t : ts)
requestBody mt
mt h (With Request ts, Text) Response
errorHandler RequestHandler h (Body mt t : ts)
nextHandler = proc With Request ts
request -> do
Either Text (With Request (Body mt t : ts))
result <- forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (With a ts) (Either (Absence t a) (With a (t : ts)))
probe (forall mimeType t. mimeType -> Body mimeType t
Body mt
mt) -< With Request ts
request
case Either Text (With Request (Body mt t : ts))
result of
Left Text
err -> h (With Request ts, Text) Response
errorHandler -< (With Request ts
request, Text
err)
Right With Request (Body mt t : ts)
t -> RequestHandler h (Body mt t : ts)
nextHandler -< With Request (Body mt t : ts)
t
{-# INLINE requestBody #-}
setBody ::
forall body mt h ts.
( Sets h [Body mt body, RequiredResponseHeader "Content-Type" Text] Response
, MIMEType mt
) =>
mt ->
h (Response `With` ts, body) (Response `With` (Body mt body : RequiredResponseHeader "Content-Type" Text : ts))
setBody :: forall body mt (h :: * -> * -> *) (ts :: [*]).
(Sets
h
'[Body mt body, RequiredResponseHeader "Content-Type" Text]
Response,
MIMEType mt) =>
mt
-> h (With Response ts, body)
(With
Response
(Body mt body : RequiredResponseHeader "Content-Type" Text : ts))
setBody mt
mt = proc (With Response ts
response, body
body) -> do
let ct :: MediaType
ct = forall mt. MIMEType mt => mt -> MediaType
mimeType mt
mt
With Response (RequiredResponseHeader "Content-Type" Text : ts)
response' <- forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant forall (e :: Existence) (name :: Symbol) val.
ResponseHeader e name val
ResponseHeader -< (With Response ts
response, ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ forall h. RenderHeader h => h -> ByteString
HTTP.renderHeader MediaType
ct)
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant (forall mimeType t. mimeType -> Body mimeType t
Body mt
mt) -< (With Response (RequiredResponseHeader "Content-Type" Text : ts)
response', body
body)
{-# INLINE setBody #-}
setBodyWithoutContentType ::
forall h ts.
(Set h UnknownContentBody Response) =>
h (Response `With` ts, ResponseBody) (Response `With` (UnknownContentBody : ts))
setBodyWithoutContentType :: forall (h :: * -> * -> *) (ts :: [*]).
Set h UnknownContentBody Response =>
h (With Response ts, ResponseBody)
(With Response (UnknownContentBody : ts))
setBodyWithoutContentType = forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant UnknownContentBody
UnknownContentBody
{-# INLINE setBodyWithoutContentType #-}
respondA ::
forall body mt h m.
( Handler h m
, Sets h [Status, Body mt body, RequiredResponseHeader "Content-Type" Text] Response
, MIMEType mt
) =>
HTTP.Status ->
mt ->
h body Response
respondA :: forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
Sets
h
'[Status, Body mt body, RequiredResponseHeader "Content-Type" Text]
Response,
MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
status mt
mt = proc body
body -> do
With Response '[Status]
response <- forall (h :: * -> * -> *).
Set h Status Response =>
Status -> h () (With Response '[Status])
mkResponse Status
status -< ()
forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (With Response ts) Response
unwitnessA forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< forall body mt (h :: * -> * -> *) (ts :: [*]).
(Sets
h
'[Body mt body, RequiredResponseHeader "Content-Type" Text]
Response,
MIMEType mt) =>
mt
-> h (With Response ts, body)
(With
Response
(Body mt body : RequiredResponseHeader "Content-Type" Text : ts))
setBody mt
mt -< (With Response '[Status]
response, body
body)
{-# INLINE respondA #-}