module WebGear.Core.Trait.Body (
Body (..),
JSONBody (..),
requestBody,
jsonRequestBody',
jsonRequestBody,
respondA,
respondJsonA,
respondJsonA',
setBody,
setBodyWithoutContentType,
setJSONBody,
setJSONBodyWithoutContentType,
setJSONBody',
) where
import Control.Arrow (ArrowChoice)
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 (Middleware)
import WebGear.Core.Request (Request)
import WebGear.Core.Response (Response)
import WebGear.Core.Trait (Get, Linked, Set, Sets, Trait (..), TraitAbsence (..), plant, probe)
import WebGear.Core.Trait.Header (Header (..), RequiredHeader)
import WebGear.Core.Trait.Status (Status, mkResponse)
newtype Body (t :: Type) = Body (Maybe HTTP.MediaType)
instance Trait (Body t) Request where
type Attribute (Body t) Request = t
instance TraitAbsence (Body t) Request where
type Absence (Body t) Request = Text
instance Trait (Body t) Response where
type Attribute (Body t) Response = t
newtype JSONBody (t :: Type) = JSONBody (Maybe HTTP.MediaType)
instance Trait (JSONBody t) Request where
type Attribute (JSONBody t) Request = t
instance TraitAbsence (JSONBody t) Request where
type Absence (JSONBody t) Request = Text
instance Trait (JSONBody t) Response where
type Attribute (JSONBody t) Response = t
requestBody ::
forall t h req.
(Get h (Body t) Request, ArrowChoice h) =>
Maybe HTTP.MediaType ->
h (Linked req Request, Text) Response ->
Middleware h req (Body t : req)
requestBody :: forall t (h :: * -> * -> *) (req :: [*]).
(Get h (Body t) Request, ArrowChoice h) =>
Maybe MediaType
-> h (Linked req Request, Text) Response
-> Middleware h req (Body t : req)
requestBody Maybe MediaType
mediaType h (Linked req Request, Text) Response
errorHandler RequestHandler h (Body t : req)
nextHandler = proc Linked req Request
request -> do
Either Text (Linked (Body t : req) Request)
result <- forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (Linked ts a) (Either (Absence t a) (Linked (t : ts) a))
probe (forall t. Maybe MediaType -> Body t
Body Maybe MediaType
mediaType) -< Linked req Request
request
case Either Text (Linked (Body t : req) Request)
result of
Left Text
err -> h (Linked req Request, Text) Response
errorHandler -< (Linked req Request
request, Text
err)
Right Linked (Body t : req) Request
t -> RequestHandler h (Body t : req)
nextHandler -< Linked (Body t : req) Request
t
jsonRequestBody' ::
forall t h req.
(Get h (JSONBody t) Request, ArrowChoice h) =>
Maybe HTTP.MediaType ->
h (Linked req Request, Text) Response ->
Middleware h req (JSONBody t : req)
jsonRequestBody' :: forall t (h :: * -> * -> *) (req :: [*]).
(Get h (JSONBody t) Request, ArrowChoice h) =>
Maybe MediaType
-> h (Linked req Request, Text) Response
-> Middleware h req (JSONBody t : req)
jsonRequestBody' Maybe MediaType
mediaType h (Linked req Request, Text) Response
errorHandler RequestHandler h (JSONBody t : req)
nextHandler = proc Linked req Request
request -> do
Either Text (Linked (JSONBody t : req) Request)
result <- forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (Linked ts a) (Either (Absence t a) (Linked (t : ts) a))
probe (forall t. Maybe MediaType -> JSONBody t
JSONBody Maybe MediaType
mediaType) -< Linked req Request
request
case Either Text (Linked (JSONBody t : req) Request)
result of
Left Text
err -> h (Linked req Request, Text) Response
errorHandler -< (Linked req Request
request, Text
err)
Right Linked (JSONBody t : req) Request
t -> RequestHandler h (JSONBody t : req)
nextHandler -< Linked (JSONBody t : req) Request
t
jsonRequestBody ::
forall t h req.
(Get h (JSONBody t) Request, ArrowChoice h) =>
h (Linked req Request, Text) Response ->
Middleware h req (JSONBody t : req)
jsonRequestBody :: forall t (h :: * -> * -> *) (req :: [*]).
(Get h (JSONBody t) Request, ArrowChoice h) =>
h (Linked req Request, Text) Response
-> Middleware h req (JSONBody t : req)
jsonRequestBody = forall t (h :: * -> * -> *) (req :: [*]).
(Get h (JSONBody t) Request, ArrowChoice h) =>
Maybe MediaType
-> h (Linked req Request, Text) Response
-> Middleware h req (JSONBody t : req)
jsonRequestBody' (forall a. a -> Maybe a
Just MediaType
"application/json")
setBody ::
forall body a h ts.
Sets h [Body body, RequiredHeader "Content-Type" Text] Response =>
HTTP.MediaType ->
h a (Linked ts Response) ->
h (body, a) (Linked (RequiredHeader "Content-Type" Text : Body body : ts) Response)
setBody :: forall body a (h :: * -> * -> *) (ts :: [*]).
Sets h '[Body body, RequiredHeader "Content-Type" Text] Response =>
MediaType
-> h a (Linked ts Response)
-> h (body, a)
(Linked
(RequiredHeader "Content-Type" Text : Body body : ts) Response)
setBody MediaType
mediaType h a (Linked ts Response)
prevHandler = proc (body
body, a
a) -> do
Linked ts Response
r <- h a (Linked ts Response)
prevHandler -< a
a
Linked (Body body : ts) Response
r' <- forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant (forall t. Maybe MediaType -> Body t
Body (forall a. a -> Maybe a
Just MediaType
mediaType)) -< (Linked ts Response
r, body
body)
let mt :: Text
mt = ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ forall h. RenderHeader h => h -> ByteString
HTTP.renderHeader MediaType
mediaType
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant forall (e :: Existence) (p :: ParseStyle) (name :: Symbol) val.
Header e p name val
Header -< (Linked (Body body : ts) Response
r', Text
mt)
setBodyWithoutContentType ::
forall body a h ts.
Set h (Body body) Response =>
h a (Linked ts Response) ->
h (body, a) (Linked (Body body : ts) Response)
setBodyWithoutContentType :: forall body a (h :: * -> * -> *) (ts :: [*]).
Set h (Body body) Response =>
h a (Linked ts Response)
-> h (body, a) (Linked (Body body : ts) Response)
setBodyWithoutContentType h a (Linked ts Response)
prevHandler = proc (body
body, a
a) -> do
Linked ts Response
r <- h a (Linked ts Response)
prevHandler -< a
a
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant (forall t. Maybe MediaType -> Body t
Body forall a. Maybe a
Nothing) -< (Linked ts Response
r, body
body)
setJSONBody' ::
forall body a h ts.
Sets h [JSONBody body, RequiredHeader "Content-Type" Text] Response =>
HTTP.MediaType ->
h a (Linked ts Response) ->
h (body, a) (Linked (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
setJSONBody' :: forall body a (h :: * -> * -> *) (ts :: [*]).
Sets
h '[JSONBody body, RequiredHeader "Content-Type" Text] Response =>
MediaType
-> h a (Linked ts Response)
-> h (body, a)
(Linked
(RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
setJSONBody' MediaType
mediaType h a (Linked ts Response)
prevHandler = proc (body
body, a
a) -> do
Linked ts Response
r <- h a (Linked ts Response)
prevHandler -< a
a
Linked (JSONBody body : ts) Response
r' <- forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant (forall t. Maybe MediaType -> JSONBody t
JSONBody (forall a. a -> Maybe a
Just MediaType
mediaType)) -< (Linked ts Response
r, body
body)
let mt :: Text
mt = ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ forall h. RenderHeader h => h -> ByteString
HTTP.renderHeader MediaType
mediaType
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant forall (e :: Existence) (p :: ParseStyle) (name :: Symbol) val.
Header e p name val
Header -< (Linked (JSONBody body : ts) Response
r', Text
mt)
setJSONBody ::
forall body a h ts.
Sets h [JSONBody body, RequiredHeader "Content-Type" Text] Response =>
h a (Linked ts Response) ->
h (body, a) (Linked (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
setJSONBody :: forall body a (h :: * -> * -> *) (ts :: [*]).
Sets
h '[JSONBody body, RequiredHeader "Content-Type" Text] Response =>
h a (Linked ts Response)
-> h (body, a)
(Linked
(RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
setJSONBody = forall body a (h :: * -> * -> *) (ts :: [*]).
Sets
h '[JSONBody body, RequiredHeader "Content-Type" Text] Response =>
MediaType
-> h a (Linked ts Response)
-> h (body, a)
(Linked
(RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
setJSONBody' MediaType
"application/json"
setJSONBodyWithoutContentType ::
forall body a h ts.
Set h (JSONBody body) Response =>
h a (Linked ts Response) ->
h (body, a) (Linked (JSONBody body : ts) Response)
setJSONBodyWithoutContentType :: forall body a (h :: * -> * -> *) (ts :: [*]).
Set h (JSONBody body) Response =>
h a (Linked ts Response)
-> h (body, a) (Linked (JSONBody body : ts) Response)
setJSONBodyWithoutContentType h a (Linked ts Response)
prevHandler = proc (body
body, a
a) -> do
Linked ts Response
r <- h a (Linked ts Response)
prevHandler -< a
a
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant (forall t. Maybe MediaType -> JSONBody t
JSONBody forall a. Maybe a
Nothing) -< (Linked ts Response
r, body
body)
respondA ::
forall body h.
Sets h [Status, Body body, RequiredHeader "Content-Type" Text] Response =>
HTTP.Status ->
HTTP.MediaType ->
h body (Linked [RequiredHeader "Content-Type" Text, Body body, Status] Response)
respondA :: forall body (h :: * -> * -> *).
Sets
h
'[Status, Body body, RequiredHeader "Content-Type" Text]
Response =>
Status
-> MediaType
-> h body
(Linked
'[RequiredHeader "Content-Type" Text, Body body, Status] Response)
respondA Status
status MediaType
mediaType = proc body
body ->
forall body a (h :: * -> * -> *) (ts :: [*]).
Sets h '[Body body, RequiredHeader "Content-Type" Text] Response =>
MediaType
-> h a (Linked ts Response)
-> h (body, a)
(Linked
(RequiredHeader "Content-Type" Text : Body body : ts) Response)
setBody MediaType
mediaType (forall (h :: * -> * -> *).
Set h Status Response =>
Status -> h () (Linked '[Status] Response)
mkResponse Status
status) -< (body
body, ())
respondJsonA ::
forall body h.
Sets h [Status, JSONBody body, RequiredHeader "Content-Type" Text] Response =>
HTTP.Status ->
h body (Linked [RequiredHeader "Content-Type" Text, JSONBody body, Status] Response)
respondJsonA :: forall body (h :: * -> * -> *).
Sets
h
'[Status, JSONBody body, RequiredHeader "Content-Type" Text]
Response =>
Status
-> h body
(Linked
'[RequiredHeader "Content-Type" Text, JSONBody body, Status]
Response)
respondJsonA Status
status = forall body (h :: * -> * -> *).
Sets
h
'[Status, JSONBody body, RequiredHeader "Content-Type" Text]
Response =>
Status
-> MediaType
-> h body
(Linked
'[RequiredHeader "Content-Type" Text, JSONBody body, Status]
Response)
respondJsonA' Status
status MediaType
"application/json"
respondJsonA' ::
forall body h.
Sets h [Status, JSONBody body, RequiredHeader "Content-Type" Text] Response =>
HTTP.Status ->
HTTP.MediaType ->
h body (Linked [RequiredHeader "Content-Type" Text, JSONBody body, Status] Response)
respondJsonA' :: forall body (h :: * -> * -> *).
Sets
h
'[Status, JSONBody body, RequiredHeader "Content-Type" Text]
Response =>
Status
-> MediaType
-> h body
(Linked
'[RequiredHeader "Content-Type" Text, JSONBody body, Status]
Response)
respondJsonA' Status
status MediaType
mediaType = proc body
body ->
forall body a (h :: * -> * -> *) (ts :: [*]).
Sets
h '[JSONBody body, RequiredHeader "Content-Type" Text] Response =>
MediaType
-> h a (Linked ts Response)
-> h (body, a)
(Linked
(RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)
setJSONBody' MediaType
mediaType (forall (h :: * -> * -> *).
Set h Status Response =>
Status -> h () (Linked '[Status] Response)
mkResponse Status
status) -< (body
body, ())