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,
Prerequisite,
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
type instance Prerequisite (Body mt t) ts Request = ()
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 <- Body mt t
-> h (With Request ts)
(Either
(Absence (Body mt t) Request) (With Request (Body mt t : ts)))
forall t (ts :: [*]) (h :: * -> * -> *) a.
(Get h t a, Prerequisite t ts a) =>
t -> h (With a ts) (Either (Absence t a) (With a (t : ts)))
probe (mt -> Body mt t
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 = mt -> MediaType
forall mt. MIMEType mt => mt -> MediaType
mimeType mt
mt
With Response (RequiredResponseHeader "Content-Type" Text : ts)
response' <- RequiredResponseHeader "Content-Type" Text
-> h (With Response ts,
Attribute (RequiredResponseHeader "Content-Type" Text) Response)
(With Response (RequiredResponseHeader "Content-Type" Text : ts))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant RequiredResponseHeader "Content-Type" Text
forall (e :: Existence) (name :: Symbol) val.
ResponseHeader e name val
ResponseHeader -< (With Response ts
response, ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
HTTP.renderHeader MediaType
ct)
Body mt body
-> h (With
Response (RequiredResponseHeader "Content-Type" Text : ts),
Attribute (Body mt body) Response)
(With
Response
(Body mt body : RequiredResponseHeader "Content-Type" Text : ts))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant (mt -> Body mt body
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 = UnknownContentBody
-> h (With Response ts, Attribute UnknownContentBody Response)
(With Response (UnknownContentBody : ts))
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 <- Status -> h () (With Response '[Status])
forall (h :: * -> * -> *).
Set h Status Response =>
Status -> h () (With Response '[Status])
mkResponse Status
status -< ()
h (With
Response
'[Body mt body, RequiredResponseHeader "Content-Type" Text,
Status])
Response
forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (With Response ts) Response
unwitnessA h (With
Response
'[Body mt body, RequiredResponseHeader "Content-Type" Text,
Status])
Response
-> h (With Response '[Status], body)
(With
Response
'[Body mt body, RequiredResponseHeader "Content-Type" Text,
Status])
-> h (With Response '[Status], body) Response
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< mt
-> h (With Response '[Status], body)
(With
Response
'[Body mt body, RequiredResponseHeader "Content-Type" Text,
Status])
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 #-}