servant-snap-0.8.4: src/Servant/Server/Internal.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif
module Servant.Server.Internal
( module Servant.Server.Internal
, module Servant.Server.Internal.PathInfo
, module Servant.Server.Internal.Router
, module Servant.Server.Internal.RoutingApplication
, module Servant.Server.Internal.ServantErr
) where
-------------------------------------------------------------------------------
import Control.Applicative ((<$>))
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad (join, when)
import Data.Bool (bool)
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Builder.Extra as BB
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as BL
import Data.Either (partitionEithers)
import Data.List (foldl')
import Data.Maybe (fromMaybe, isNothing, mapMaybe,
maybeToList)
import Data.Proxy
import Data.String (IsString, fromString)
import Data.String.Conversions (cs, (<>))
import Data.Tagged (Tagged(..), retag)
import qualified Data.Text as T
import Data.Text (Text)
import Data.Typeable (Typeable)
import GHC.Generics
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
symbolVal)
import Network.HTTP.Types (HeaderName, Method,
Status(..), parseQueryText,
methodGet, methodHead,
hContentType, hAccept)
import qualified Network.HTTP.Media as NHM
import Web.HttpApiData (FromHttpApiData,
parseHeader,
parseQueryParam,
parseUrlPieceMaybe,
parseUrlPieces)
import Snap.Core hiding (Headers, Method,
getResponse, route,
method, withRequest)
import Servant.API ((:<|>) (..), (:>), BasicAuth,
Capture',
CaptureAll, Description, FramingRender (..), EmptyAPI,
Header', IsSecure(..), If, QueryFlag, IsSecure(..),
QueryParam', QueryParams, Raw,
RemoteHost, ReqBody',
ReflectMethod(..), SBool(..), SBoolI, Stream, Summary,
Verb, sbool
)
import Servant.API.Stream (ToSourceIO(..))
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
AllCTUnrender (..), AllMime(..),
MimeRender (..),
canHandleAcceptH, contentType)
import Servant.API.Modifiers (FoldLenient, FoldRequired,
RequestArgument, unfoldRequestArgument)
import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
getHeaders)
import qualified Servant.Types.SourceT as S
import qualified System.IO.Streams as IOS
import Servant.Server.Internal.BasicAuth
import Servant.Server.Internal.Context
import Servant.Server.Internal.PathInfo
import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
import Servant.Server.Internal.SnapShims
class HasServer api context (m :: * -> *) where
type ServerT api context m :: *
route :: MonadSnap m
=> Proxy api
-> Context context
-> Delayed m env (Server api context m)
-> Router m env
hoistServerWithContext
:: proxy api
-> proxy' context
-> (forall x. m x -> n x)
-> ServerT api context m
-> ServerT api context n
type Server api context m = ServerT api context m
-- * Instances
-- | A server for @a ':<|>' b@ first tries to match the request against the route
-- represented by @a@ and if it fails tries @b@. You must provide a request
-- handler for each route.
--
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
-- >
-- > server :: Server MyApi
-- > server = listAllBooks :<|> postBook
-- > where listAllBooks = ...
-- > postBook book = ...
instance (HasServer a ctx m, HasServer b ctx m) => HasServer (a :<|> b) ctx m where
type ServerT (a :<|> b) ctx m = ServerT a ctx m :<|> ServerT b ctx m
route Proxy ctx server = choice (route pa ctx ((\ (a :<|> _) -> a) <$> server))
(route pb ctx ((\ (_ :<|> b) -> b) <$> server))
where pa = Proxy :: Proxy a
pb = Proxy :: Proxy b
hoistServerWithContext _ pc nt (a :<|> b) =
hoistServerWithContext (Proxy :: Proxy a) pc nt a :<|>
hoistServerWithContext (Proxy :: Proxy b) pc nt b
captured :: FromHttpApiData a => proxy (Capture' mods sym a) -> Text -> Maybe a
captured _ = parseUrlPieceMaybe
-- | If you use 'Capture' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of the type specified by the 'Capture'.
-- This lets servant worry about getting it from the URL and turning
-- it into a value of the type you specify.
--
-- You can control how it'll be converted from 'Text' to your type
-- by simply providing an instance of 'FromHttpApiData' for your type.
--
-- Example:
--
-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
-- >
-- > server :: Server MyApi
-- > server = getBook
-- > where getBook :: Text -> EitherT ServantErr IO Book
-- > getBook isbn = ...
instance (FromHttpApiData a, HasServer api context m)
=> HasServer (Capture' mods capture a :> api) context m where
type ServerT (Capture' mods capture a :> api) context m =
a -> ServerT api context m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy ctx d =
CaptureRouter $
route (Proxy :: Proxy api) ctx
(addCapture d $ \ txt -> case parseUrlPieceMaybe txt of
Nothing -> delayedFail err400
Just v -> return v
)
instance (FromHttpApiData a, HasServer api context m)
=> HasServer (CaptureAll capture a :> api) context m where
type ServerT (CaptureAll capture a :> api) context m =
[a] -> ServerT api context m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy ctx d =
CaptureAllRouter $
route (Proxy :: Proxy api) ctx
(addCapture d $ \ txts -> case parseUrlPieces txts of
Left _ -> delayedFail err400
Right v -> return v
)
allowedMethodHead :: Method -> Request -> Bool
allowedMethodHead method request =
method == methodGet && unSnapMethod (rqMethod request) == methodHead
allowedMethod :: Method -> Request -> Bool
allowedMethod method request =
allowedMethodHead method request || unSnapMethod (rqMethod request) == method
processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method
-> Maybe [(HeaderName, B.ByteString)]
-> Request -> RouteResult Response
processMethodRouter handleA status method rHeaders request = case handleA of
Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
Just (contentT, body) -> Route $ responseLBS status hdrs bdy
where
bdy = if allowedMethodHead method request then "" else body
hdrs = (hContentType, cs contentT) : fromMaybe [] rHeaders
methodCheck :: MonadSnap m => Method -> Request -> DelayedM m ()
methodCheck method request
| allowedMethod method request = return ()
| otherwise = delayedFail err405
-- This has switched between using 'Fail' and 'FailFatal' a number of
-- times. If the 'acceptCheck' is run after the body check (which would
-- be morally right), then we have to set this to 'FailFatal', because
-- the body check is not reversible, and therefore backtracking after the
-- body check is no longer an option. However, we now run the accept
-- check before the body check and can therefore afford to make it
-- recoverable.
acceptCheck :: (AllMime list, MonadSnap m) => Proxy list -> B.ByteString -> DelayedM m ()
acceptCheck proxy accH
| canHandleAcceptH proxy (AcceptHeader accH) = return ()
| otherwise = delayedFail err406
methodRouter :: (AllCTRender ctypes a, MonadSnap m)
=> Method -> Proxy ctypes -> Status
-> Delayed m env (m a)
-> Router m env -- Request (RoutingApplication m) m
methodRouter method proxy status action = leafRouter route'
where
route' env request respond =
let accH = fromMaybe ct_wildcard $ getHeader hAccept request -- lookup hAccept $ requestHeaders request
in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH
) env request respond $ \ output -> do
let handleA = handleAcceptH proxy (AcceptHeader accH) output
processMethodRouter handleA status method Nothing request
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v, MonadSnap m)
=> Method -> Proxy ctypes -> Status
-> Delayed m env (m (Headers h v))
-> Router m env -- Request (RoutingApplication m) m
methodRouterHeaders method proxy status action = leafRouter route'
where
route' env request respond =
let accH = fromMaybe ct_wildcard $ getHeader hAccept request -- lookup hAccept $ requestHeaders request
in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH
) env request respond $ \ output -> do
let hdrs = getHeaders output
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
processMethodRouter handleA status method (Just hdrs) request
instance {-# OVERLAPPABLE #-} (AllCTRender ctypes a,
ReflectMethod method,
KnownNat status)
=> HasServer (Verb method status ctypes a) context m where
type ServerT (Verb method status ctypes a) context m = m a
hoistServerWithContext _ _ nt s = nt s
route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance {-# OVERLAPPABLE #-} (AllCTRender ctypes a,
ReflectMethod method,
KnownNat status,
GetHeaders (Headers h a))
=> HasServer (Verb method status ctypes (Headers h a)) context m where
type ServerT (Verb method status ctypes (Headers h a)) context m = m (Headers h a)
hoistServerWithContext _ _ nt s = nt s
route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
-- | If you use 'Header' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of the type specified by 'Header'.
-- This lets servant worry about extracting it from the request and turning
-- it into a value of the type you specify.
--
-- All it asks is for a 'FromHttpApiData' instance.
--
-- Example:
--
-- > newtype Referer = Referer Text
-- > deriving (Eq, Show, FromText, ToText)
-- >
-- > -- GET /view-my-referer
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
-- >
-- > server :: Server MyApi
-- > server = viewReferer
-- > where viewReferer :: Referer -> EitherT ServantErr IO referer
-- > viewReferer referer = return referer
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context m
, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
)
=> HasServer (Header' mods sym a :> api) context m where
type ServerT (Header' mods sym a :> api) context m =
RequestArgument mods a -> ServerT api context m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy ctx subserver = route (Proxy :: Proxy api) ctx $
subserver `addHeaderCheck` withRequest headerCheck
where
headerName :: IsString n => n
headerName = fromString $ symbolVal (Proxy :: Proxy sym)
headerCheck :: Request -> DelayedM m (RequestArgument mods a)
headerCheck req =
unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
where
mev :: Maybe (Either Text a)
mev = fmap parseHeader $ getHeader headerName req
errReq = delayedFailFatal err400
{ errBody = "Header " <> headerName <> " is required"
}
errSt e = delayedFailFatal err400
{ errBody = cs $ "Error parsing header "
<> headerName
<> " failed: " <> e
}
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of type @'Maybe' 'Text'@.
--
-- This lets servant worry about looking it up in the query string
-- and turning it into a value of the type you specify, enclosed
-- in 'Maybe', because it may not be there and servant would then
-- hand you 'Nothing'.
--
-- You can control how it'll be converted from 'Text' to your type
-- by simply providing an instance of 'FromHttpApiData' for your type.
--
-- Example:
--
-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
-- > where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book]
-- > getBooksBy Nothing = ...return all books...
-- > getBooksBy (Just author) = ...return books by the given author...
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context m
, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
)
=> HasServer (QueryParam' mods sym a :> api) context m where
type ServerT (QueryParam' mods sym a :> api) context m =
RequestArgument mods a -> ServerT api context m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy ctx subserver =
let querytext r = parseQueryText $ rqQueryString r
paramname = cs $ symbolVal (Proxy :: Proxy sym)
parseParam :: Request -> DelayedM m (RequestArgument mods a)
parseParam req =
unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
where
mev :: Maybe (Either T.Text a)
mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
errReq = delayedFailFatal err400
{ errBody = cs $ "Query parameter " <> paramname <> " is required"
}
errSt e = delayedFailFatal err400
{ errBody = cs $ "Error parsing query parameter "
<> paramname <> " failed: " <> e
}
delayed = addParameterCheck subserver . withRequest $ parseParam
in route (Proxy :: Proxy api) ctx delayed
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of type @['Text']@.
--
-- This lets servant worry about looking up 0 or more values in the query string
-- associated to @authors@ and turning each of them into a value of
-- the type you specify.
--
-- You can control how the individual values are converted from 'Text' to your type
-- by simply providing an instance of 'FromHttpApiData' for your type.
--
-- Example:
--
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
-- > where getBooksBy :: [Text] -> EitherT ServantErr IO [Book]
-- > getBooksBy authors = ...return all books by these authors...
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context m)
=> HasServer (QueryParams sym a :> api) context m where
type ServerT (QueryParams sym a :> api) context m =
[a] -> ServerT api context m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy ctx subserver = route (Proxy :: Proxy api) ctx $
subserver `addParameterCheck` withRequest paramsCheck
where
paramname = cs $ symbolVal (Proxy :: Proxy sym)
paramsCheck req =
case partitionEithers $ fmap parseQueryParam params of
([], parsed) -> return parsed
(errs, _) -> delayedFailFatal err400
{ errBody = cs $ "Error parsing query parameter(s) "
<> paramname <> " failed: "
<> T.intercalate ", " errs
}
where
params :: [T.Text]
params = mapMaybe snd
. filter (looksLikeParam . fst)
. parseQueryText
. rqQueryString
$ req
looksLikeParam name = name == paramname || name == (paramname <> "[]")
-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of type 'Bool'.
--
-- Example:
--
-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooks
-- > where getBooks :: Bool -> EitherT ServantErr IO [Book]
-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
instance (KnownSymbol sym, HasServer api context m)
=> HasServer (QueryFlag sym :> api) context m where
type ServerT (QueryFlag sym :> api) context m =
Bool -> ServerT api context m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context subserver =
let querytext r = parseQueryText $ rqQueryString r
param r = case lookup paramname (querytext r) of
Just Nothing -> True -- param is there, with no value
Just (Just v) -> examine v -- param with a value
Nothing -> False -- param not in the query string
in route (Proxy :: Proxy api) context (passToServer subserver param)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False
-- | Just pass the request to the underlying application and serve its response.
--
-- Example:
--
-- > type MyApi = "images" :> Raw
-- >
-- > server :: Server MyApi
-- > server = serveDirectory "/var/www/images"
instance HasServer Raw context m where
type ServerT Raw context m = m ()
hoistServerWithContext _ _ nt = nt
route Proxy _ rawApplication = RawRouter $ \ env request respond -> do
r <- runDelayed rawApplication env request
case r of
Route app -> (snapToApplication' app) request (respond . Route)
Fail a -> respond $ Fail a
FailFatal e -> respond $ FailFatal e
-- | If you use 'ReqBody' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of the type specified by 'ReqBody'.
-- The @Content-Type@ header is inspected, and the list provided is used to
-- attempt deserialization. If the request does not have a @Content-Type@
-- header, it is treated as @application/octet-stream@ (as specified in
-- <https://tools.ietf.org/html/rfc7231#section-3.1.1.4 RFC7231>.
-- This lets servant worry about extracting it from the request and turning
-- it into a value of the type you specify.
--
--
-- All it asks is for a 'FromJSON' instance.
--
-- Example:
--
-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
-- >
-- > server :: Server MyApi
-- > server = postBook
-- > where postBook :: Book -> EitherT ServantErr IO Book
-- > postBook book = ...insert into your db...
instance ( AllCTUnrender list a, HasServer api context m, SBoolI (FoldLenient mods), MonadSnap m
) => HasServer (ReqBody' mods list a :> api) context m where
type ServerT (ReqBody' mods list a :> api) context m =
If (FoldLenient mods) (Either String a) a -> ServerT api context m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context subserver
= route (Proxy :: Proxy api) context $
addBodyCheck subserver ctCheck bodyCheck
where
-- Content-Type check, we only lookup we can try to parse the request body
ctCheck = withRequest $ \ request -> do
-- See HTTP RFC 2616, section 7.2.1
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
-- See also "W3C Internet Media Type registration, consistency of use"
-- http://www.w3.org/2001/tag/2002/0129-mime
let contentTypeH = fromMaybe "application/octet-stream"
$ getHeader hContentType request
case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of
Nothing -> delayedFail err415
Just f -> return f
-- Body check, we get a body parsing functions as the first argument.
bodyCheck f = do
mrqbody <- lift $ runRequestBody $ \ stream -> f <$> BL.fromChunks <$> IOS.toList {- IOS.toLazyByteString -} stream
case sbool :: SBool (FoldLenient mods) of
STrue -> return mrqbody
SFalse -> case mrqbody of
Left e -> delayedFailFatal err400 { errBody = cs e }
Right v -> return v
-- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @api@.
instance (KnownSymbol path, HasServer api context m) => HasServer (path :> api) context m where
type ServerT (path :> api) context m = ServerT api context m
route Proxy context subserver =
pathRouter
(cs (symbolVal proxyPath))
(route (Proxy :: Proxy api) context subserver)
where proxyPath = Proxy :: Proxy path
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s
instance HasServer api context m => HasServer (RemoteHost :> api) context m where
type ServerT (RemoteHost :> api) context m = B.ByteString -> ServerT api context m
route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver rqHostName)
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
instance HasServer api context m => HasServer (IsSecure :> api) context m where
type ServerT (IsSecure :> api) context m = IsSecure -> ServerT api context m
route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver (bool NotSecure Secure . rqIsSecure))
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
-- This appears to be about 1000000% WAI-specific, so better hope you didn't need it
-- instance HasServer api context m => HasServer (Vault :> api) context m where
-- type ServerT (Vault :> api) context m = Vault -> ServerT api context m
--
-- route Proxy context subserver =
-- route (Proxy :: Proxy api) context (passToServer subserver vault)
-- hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
instance HasServer api context m => HasServer (HttpVersion :> api) context m where
type ServerT (HttpVersion :> api) context m = HttpVersion -> ServerT api context m
route Proxy ctx subserver =
route (Proxy :: Proxy api) ctx (passToServer subserver rqVersion)
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
-- | Ignore @'Summary'@ in server handlers.
instance HasServer api ctx m => HasServer (Summary desc :> api) ctx m where
type ServerT (Summary desc :> api) ctx m = ServerT api ctx m
route _ = route (Proxy :: Proxy api)
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s
-- | Ignore @'Description'@ in server handlers.
instance HasServer api ctx m => HasServer (Description desc :> api) ctx m where
type ServerT (Description desc :> api) ctx m = ServerT api ctx m
route _ = route (Proxy :: Proxy api)
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s
-- | Singleton type representing a server that serves an empty API.
data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)
-- | Server for `EmptyAPI`
emptyServer :: ServerT EmptyAPI context m
emptyServer = Tagged EmptyServer
-- | The server for an `EmptyAPI` is `emptyAPIServer`.
--
-- > type MyApi = "nothing" :> EmptyApi
-- >
-- > server :: Server MyApi
-- > server = emptyAPIServer
instance HasServer EmptyAPI context m where
type ServerT EmptyAPI context m = Tagged m EmptyServer
route Proxy _ _ = StaticRouter mempty mempty
hoistServerWithContext _ _ _ = retag
-- | Basic Authentication
instance ( KnownSymbol realm
, HasServer api context m
, HasContextEntry context (BasicAuthCheck m usr)
)
=> HasServer (BasicAuth realm usr :> api) context m where
type ServerT (BasicAuth realm usr :> api) context m = usr -> ServerT api context m
route Proxy context subserver =
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck)
where
realm = B.pack $ symbolVal (Proxy :: Proxy realm)
basicAuthContext = getContextEntry context
authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
-- newtype BasicAuthCheck m usr =
-- BasicAuthCheck { unBasicAuthCheck :: BasicAuthData -> m (BasicAuthResult usr) }
-- deriving (Functor, Generic)
data BasicAuthResult usr = Unauthorized | BadPassword | NoSuchUser | Authorized usr
deriving (Functor, Eq, Read, Show, Generic)
-- * helpers
--
ct_wildcard :: B.ByteString
ct_wildcard = "*" <> "/" <> "*" -- Because CPP
instance forall ctype chunk method status framing m context a.
( MimeRender ctype chunk, ReflectMethod method, KnownNat status,
FramingRender framing, MonadSnap m, ToSourceIO chunk a
) => HasServer (Stream method status framing ctype a) context m where
type ServerT (Stream method status framing ctype a) context m = m a
hoistServerWithContext _ _ nt s = nt s
route Proxy _ action = streamRouter ([],) method status
(Proxy :: Proxy framing)
(Proxy :: Proxy ctype) action
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance ( MimeRender ctype chunk, ReflectMethod method, MimeRender ctype a, KnownNat status, MonadSnap m,
FramingRender framing, ToSourceIO chunk a, GetHeaders (Headers h a)
) => HasServer (Stream method status framing ctype (Headers h a)) context m where
type ServerT (Stream method status framing ctype (Headers h a)) context m = m (Headers h a)
hoistServerWithContext _ _ nt s = nt s
route Proxy _ action =
streamRouter (\x -> (getHeaders x, getResponse x))
method
status
(Proxy :: Proxy framing)
(Proxy :: Proxy ctype)
action
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
streamRouter :: forall ctype a c chunk env framing m
.(MimeRender ctype chunk,
FramingRender framing,
-- ToSourceIO chunk (m a),
ToSourceIO chunk a,
MonadSnap m
) =>
(c -> ([(HeaderName, B.ByteString)], a))
-> Method
-> Status
-> Proxy framing
-> Proxy ctype
-> Delayed m env (m c)
-> Router m env
streamRouter splitHeaders method status framingproxy ctypeproxy action =
leafRouter $ \env request respond ->
let accH = fromMaybe ct_wildcard $ getHeader hAccept request
cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
accCheck = when (isNothing cmediatype) $ delayedFail err406
contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` accCheck
) env request respond $ \ output ->
let (headers', fa) = splitHeaders output
sourceT = toSourceIO fa
S.SourceT kStepLBS =
framingRender framingproxy
(mimeRender ctypeproxy :: chunk -> BL.ByteString)
sourceT
response = setResponseStatus (statusCode status) (statusMessage status)
$ setHeaders (contentHeader:headers') emptyResponse
in
Route $ flip setResponseBody response $ \outStream -> do
let
writeAndFlush bb = IOS.write (Just $ bb <> BB.flush) outStream
justFlush = IOS.write (Just BB.flush) outStream
loop :: S.StepT IO BL.ByteString -> IO (IOS.OutputStream BB.Builder)
loop S.Stop = justFlush >> return outStream
loop (S.Error err) = fail err -- TODO: Provide a better error message
loop (S.Skip s) = loop s
loop (S.Effect ms) = ms >>= loop
loop (S.Yield lbs s) = do
writeAndFlush (BB.lazyByteString lbs)
loop s
kStepLBS loop