serv-wai-0.2.0.0: src/Serv/Wai.hs
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- | Build an "implementation" of a given 'Api'-kinded type (e.g. @'Impl'
-- api@) which describes all of the logic for your server and then convert
-- it into a 'Server' value and then an 'Application'.
module Serv.Wai (
-- * Implement a 'Server'
server
, Server
-- ** Server transformation
-- | Typically you use 'server' to construct a value @'Server' M@ for
-- some @M@ specific to your application, either a transformer stack or
-- an abstract monad constrained by @mtl@-like typeclasses. If @M@ is not
-- 'IO' then 'serverApplication' cannot be used to build an
-- 'Application', so instead we must first transform @M@ using a "run"
-- function applied to 'mapServer'.
--
-- For instance, if @M@ is @StateT St IO@ then
--
-- @
-- flip evalStateT s0 :: StateT St IO a -> IO a
-- @
--
-- is a suitable "run" function we could apply
-- using 'mapServer' to transform @'Server' M@ into @'Server' 'IO'@.
, mapServer
-- ** Execute it as an 'Application'
, serverApplication
, serverApplication'
, serverApplication''
-- * Constraints and Implementations
-- | In order to call 'server' we must ensure that our @api :: 'Api'@
-- type is decorated with the appropriate constraints and that the
-- @'Impl' api@ type properly matches the 'Api'. This is achieved by
-- analyzing the types with type-level functions, e.g. the closed type
-- families 'Impl' and 'Constrain'.
--
-- NOTE: Closed type families are rather finnicky as to when they
-- actually evaluate, so the factoring of these type families into
-- smaller pieces is done by some trial an error.
, Impl
, Constrain
-- ** Detailed constraints and implementations
, AllImpl
, AllHandlers
, ImplHandler
, ConstrainEndpoint
, ConstrainHandler
, ConstrainOutputs
, ConstrainRespond
, ConstrainBody
) where
import Control.Monad.Trans
import qualified Data.ByteString.Lazy as Sl
import qualified Data.ByteString as S
import Data.CaseInsensitive (CI)
import Data.Maybe (catMaybes)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Singletons
import Data.Singletons.Prelude.List
import Data.Singletons.Prelude.Tuple
import Data.Singletons.TypeLits
import Data.Text (Text)
import GHC.Exts
import Network.HTTP.Kinder.Header (AllHeaderDecodes,
AllHeaderEncodes,
HeaderDecode (..), HeaderName, Sing (SAccept, SAllow, SContentType),
headerEncodePair)
import Network.HTTP.Kinder.MediaType (AllMimeEncode,
negotiatedMimeEncode)
import Network.HTTP.Kinder.Query (AllQueryDecodes)
import Network.HTTP.Kinder.Status (Status)
import qualified Network.HTTP.Kinder.Status as St
import Network.HTTP.Kinder.URI (URIDecode (..))
import Network.HTTP.Kinder.Verb (Verb (..))
import Network.Wai
import Serv.Api
import Serv.Api.Analysis
import Serv.Wai.Corec
import Serv.Wai.Rec
import Serv.Wai.Response
import Serv.Wai.Type
type family Impl (m :: * -> *) api where
Impl m Abstract = m (Context -> Application)
Impl m (OneOf apis) = HList (AllImpl m apis)
Impl m (Endpoint ann hs) = FieldRec (AllHandlers m hs)
Impl m (Const s :> api) = Impl m api
Impl m (HeaderAs s v :> api) = Impl m api
Impl m (Seg s a :> api) = a -> Impl m api
Impl m (Header n a :> api) = a -> Impl m api
Impl m (Wildcard :> api) = [Text] -> Impl m api
type family AllImpl m apis where
AllImpl m '[] = '[]
AllImpl m (api ': apis) = Impl m api ': AllImpl m apis
type family AllHandlers m hs where
AllHandlers m '[] = '[]
AllHandlers m (h ': hs) =
'(VerbOf h, ImplHandler m h) ': AllHandlers m hs
type family VerbOf h where
VerbOf (CaptureBody ts a h) = VerbOf h
VerbOf (CaptureHeaders hs h) = VerbOf h
VerbOf (CaptureQuery qs h) = VerbOf h
VerbOf (Method v os) = v
type family ImplHandler m h where
ImplHandler m (CaptureBody ts a h) = a -> ImplHandler m h
ImplHandler m (CaptureHeaders hs h) = FieldRec hs -> ImplHandler m h
ImplHandler m (CaptureQuery qs h) = FieldRec qs -> ImplHandler m h
ImplHandler m (Method v os) = m (SomeResponse os)
type family Constrain a :: Constraint where
Constrain Abstract = ()
Constrain (Endpoint ann hs) = ConstrainEndpoint hs
Constrain (OneOf '[]) = ()
Constrain (OneOf (api ': apis)) =
(Constrain api, Constrain (OneOf apis))
Constrain (Const s :> api) = Constrain api
Constrain (HeaderAs s v :> api) = Constrain api
Constrain (Seg s a :> api) = (Constrain api, URIDecode a)
Constrain (Header n a :> api) = (Constrain api, HeaderDecode n a)
Constrain (Wildcard :> api) = Constrain api
type family ConstrainEndpoint hs :: Constraint where
ConstrainEndpoint '[] = ()
ConstrainEndpoint (h ': hs) =
(ConstrainHandler h, ConstrainEndpoint hs)
type family ConstrainHandler h :: Constraint where
ConstrainHandler (Method verb os) =
ConstrainOutputs os
ConstrainHandler (CaptureBody ctypes a h) =
ConstrainHandler h -- TODO
ConstrainHandler (CaptureHeaders hs h) =
(AllHeaderDecodes hs, ConstrainHandler h)
ConstrainHandler (CaptureQuery qs h) =
(AllQueryDecodes qs, ConstrainHandler h)
type family ConstrainOutputs (os :: [(Status, Output *)]) :: Constraint where
ConstrainOutputs '[] = ()
ConstrainOutputs ((s ::: r) ': os) = (ConstrainRespond r, ConstrainOutputs os)
type family ConstrainRespond r :: Constraint where
ConstrainRespond (Respond hs b) = (AllHeaderEncodes hs, ConstrainBody b)
type family ConstrainBody b :: Constraint where
ConstrainBody Empty = ()
ConstrainBody (HasBody ts a) = AllMimeEncode a ts
-- | Construct a 'Server' value from an @'Impl' api@ implementation
-- matching the @'Sing' api@ singleton. This is the primary function for
-- the entire package.
server :: (Constrain api, Monad m) => Sing api -> Impl m api -> Server m
server SAbstract mApp = returnServer (fmap Application mApp)
server (SOneOf SNil) RNil = notFound
server (SOneOf (SCons api apis)) (Identity impl :& impls) =
server api impl `orElse` server (SOneOf apis) impls
server (path :%> api) impl =
Server $ case path of
SConst sym -> withKnownSymbol sym $ do
maySeg <- popSegment
runServer $ case maySeg of
Nothing -> notFound
Just seg
| seg /= fromString (symbolVal sym) -> notFound
| otherwise -> server api impl
SWildcard -> do
segs <- popAllSegments
runServer (server api (impl segs))
SHeaderAs h sExp -> do
let expected = fromString (withKnownSymbol sExp (symbolVal sExp))
ok <- expectHeader h expected
runServer $ if ok
then server api impl
else notFound
SSeg _name _ty -> do
trySeg <- popSegment
runServer $ case trySeg of
Nothing -> notFound
Just seg ->
case uriDecode seg of
Left err -> badRequest (Just err)
Right val -> server api (impl val)
SHeader hdr _ty -> do
tryVal <- getHeader hdr
runServer $ case tryVal of
Left err -> badRequest (Just err)
Right val -> server api (impl val)
server (SEndpoint _ann handlers) impls = Server $ do
let verbs = augmentVerbs (inspectVerbs handlers)
isTerminal <- endOfPath
if not isTerminal
then runServer notFound
else do
mayVerb <- getVerb
case mayVerb of
Nothing -> runServer (methodNotAllowed verbs)
Just verb
| verb == OPTIONS -> do
return $
WaiResponse
$ responseLBS
(St.httpStatus St.SOk)
(catMaybes [headerEncodePair SAllow verbs])
""
| verb `Set.member` verbs -> do
runServer (handles verbs handlers impls)
| otherwise -> runServer (methodNotAllowed verbs)
handles
:: (ConstrainEndpoint hs, Monad m)
=> Set Verb -> Sing hs -> FieldRec (AllHandlers m hs) -> Server m
handles verbs SNil RNil = methodNotAllowed verbs
handles verbs (SCons sHandler sRest) (ElField _verb handler :& implRest) =
handle sHandler handler
`orElse`
handles verbs sRest implRest
handles _ _ _ = bugInGHC
handle :: (ConstrainHandler h, Monad m) => Sing h -> ImplHandler m h -> Server m
handle sH impl = Server $
case sH of
SMethod sVerb sAlts -> do
mayVerb <- getVerb
let verbProvided = fromSing sVerb
case mayVerb of
Nothing -> runServer notFound
Just verbRequested
| verbRequested == HEAD -> do
someResponse <- lift impl
handleResponse False sAlts someResponse
| verbRequested == verbProvided -> do
someResponse <- lift impl
handleResponse True sAlts someResponse
| otherwise ->
runServer notFound -- not methodNotAllowedS because we can't
-- make that judgement locally.
SCaptureHeaders sHdrs sH' -> do
tryHdrs <- extractHeaders sHdrs
case tryHdrs of
Left errors ->
runServer (badRequest (Just (unlines ("invalid headers:" : errors))))
Right rec ->
runServer (handle sH' (impl rec))
SCaptureQuery sQ sH' -> do
tryQ <- extractQueries sQ
case tryQ of
Left errors ->
runServer (badRequest (Just (unlines ("invalid query:" : errors))))
Right rec ->
runServer (handle sH' (impl rec))
-- TODO: These...
SCaptureBody _sCTypes _sTy _sH' ->
undefined -- runServer (handle sH' (impl _))
extractHeaders
:: forall m (hs :: [(HeaderName, *)])
. (AllHeaderDecodes hs, Monad m, Contextual m)
=> Sing hs -> m (Either [String] (FieldRec hs))
extractHeaders SNil = return (Right RNil)
extractHeaders (SCons (STuple2 hdr (_ty :: Sing a)) rest) = do
tryRec <- extractHeaders rest
tryHeader <- getHeader hdr
return $ case (tryRec, tryHeader :: Either String a) of
(Left errs, Left err) -> Left (err : errs)
(Left errs, Right _) -> Left errs
(Right _, Left err) -> Left [err]
(Right rec, Right val) -> Right (ElField hdr val :& rec)
extractQueries
:: forall m (qs :: [(Symbol, *)])
. (AllQueryDecodes qs, Monad m, Contextual m)
=> Sing qs -> m (Either [String] (FieldRec qs))
extractQueries SNil = return (Right RNil)
extractQueries (SCons (STuple2 qsym (_ty :: Sing a)) rest) = do
tryRec <- extractQueries rest
tryQuery <- getQuery qsym
return $ case (tryRec, tryQuery :: Either String a) of
(Left errs, Left err) -> Left (err : errs)
(Left errs, Right _) -> Left errs
(Right _, Left err) -> Left [err]
(Right rec, Right val) -> Right (ElField qsym val :& rec)
handleResponse
:: (ConstrainOutputs alts, Monad m, Contextual m)
=> Bool -> Sing alts -> SomeResponse alts -> m ServerResult
handleResponse includeBody (SCons _ sRest) (Skip someResponse) =
handleResponse includeBody sRest someResponse
handleResponse
includeBody
(SCons (STuple2 sStatus (SRespond _sHeaders sBody)) _)
(Stop resp) =
case (sBody, resp) of
(SEmpty, EmptyResponse secretHeaders headers) ->
return
$ WaiResponse
$ responseLBS
(St.httpStatus sStatus)
(secretHeaders ++ encodeHeaders headers)
""
(SHasBody sCtypes _sTy, ContentResponse secretHeaders headers a)
| not includeBody -> do
return
$ WaiResponse
$ responseLBS
(St.httpStatus sStatus)
(secretHeaders ++ encodeHeaders headers)
""
| otherwise -> do
eitAccept <- getHeader SAccept
let accepts = either (const []) id eitAccept
case negotiatedMimeEncode sCtypes of
Nothing ->
return
$ WaiResponse
$ responseLBS (St.httpStatus St.SNotAcceptable) [] ""
Just nego -> do
let (mt, body) = nego accepts a
newHeaders = catMaybes [ headerEncodePair SContentType mt ]
return
$ WaiResponse
$ responseLBS
(St.httpStatus sStatus)
( newHeaders
++ secretHeaders
++ encodeHeaders headers
)
(Sl.fromStrict body)
_ -> bugInGHC
handleResponse _ _ _ = bugInGHC
-- | Augment the Set of allowed verbs by adding OPTIONS and, as necessary,
-- HEAD.
augmentVerbs :: Set Verb -> Set Verb
augmentVerbs = augHead . augOptions where
augHead s
| Set.member GET s = Set.insert HEAD s
| otherwise = s
augOptions = Set.insert OPTIONS
encodeHeaders :: AllHeaderEncodes rs => FieldRec rs -> [(CI S.ByteString, S.ByteString)]
encodeHeaders = catMaybes . encodeHeaders'
-- | Convert a record of headers into a raw bytes format
encodeHeaders' :: AllHeaderEncodes rs => FieldRec rs -> [Maybe (CI S.ByteString, S.ByteString)]
encodeHeaders' rec =
case rec of
RNil -> []
ElField s val :& rest ->
headerEncodePair s val : encodeHeaders' rest