module Serv.Wai.Response (
Response (..)
, SomeResponse
, emptyResponse
, withBody
, withoutBody
, withHeader
, withHeaderQuiet
, respond
) where
import Data.Singletons
import Network.HTTP.Kinder.Header (HeaderEncode, headerEncodePair)
import Network.HTTP.Kinder.Status (Status)
import qualified Network.HTTP.Types as HTTP
import qualified Serv.Api as Api
import Serv.Wai.Corec
import Serv.Wai.Rec
data Response (x :: (Status, Api.Output *)) where
ContentResponse
:: [HTTP.Header] -> FieldRec hs -> a
-> Response '(s, Api.Respond hs (Api.HasBody ts a))
EmptyResponse
:: [HTTP.Header] -> FieldRec hs
-> Response '(s, Api.Respond hs Api.Empty)
type SomeResponse rs = Corec Response rs
respond :: ElemOf rs '(s, r) => Response '(s, r) -> SomeResponse rs
respond = inject
emptyResponse :: sing s -> Response '(s, Api.Respond '[] Api.Empty)
emptyResponse _ = EmptyResponse [] RNil
withBody
:: a -> Response '(s, Api.Respond hs Api.Empty)
-> Response '(s, Api.Respond hs (Api.HasBody ts a))
withBody a (EmptyResponse secretHeaders headers) =
ContentResponse secretHeaders headers a
withoutBody
:: Response '(s, Api.Respond hs (Api.HasBody ts a))
-> Response '(s, Api.Respond hs Api.Empty)
withoutBody (ContentResponse secretHeaders headers _) =
EmptyResponse secretHeaders headers
withHeader
:: Sing name -> value
-> Response '(s, Api.Respond headers body)
-> Response '(s, Api.Respond ( '(name, value) ': headers) body)
withHeader s val r = case r of
ContentResponse secretHeaders headers body ->
ContentResponse secretHeaders (s =: val <+> headers) body
EmptyResponse secretHeaders headers ->
EmptyResponse secretHeaders (s =: val <+> headers)
withHeaderQuiet
:: HeaderEncode name value
=> Sing name -> value
-> Response '(s, Api.Respond headers body)
-> Response '(s, Api.Respond headers body)
withHeaderQuiet s value r =
case headerEncodePair s value of
Nothing -> r
Just newHeader ->
case r of
ContentResponse secretHeaders headers body ->
ContentResponse (newHeader : secretHeaders) headers body
EmptyResponse secretHeaders headers ->
EmptyResponse (newHeader : secretHeaders) headers