#include "overlapping-compat.h"
module Servant.Server.Internal
( module Servant.Server.Internal
, module Servant.Server.Internal.Context
, module Servant.Server.Internal.BasicAuth
, module Servant.Server.Internal.Router
, module Servant.Server.Internal.RoutingApplication
, module Servant.Server.Internal.ServantErr
) where
import Control.Monad.Trans (liftIO)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
import Data.Maybe (fromMaybe, mapMaybe)
import Data.String (fromString)
import Data.String.Conversions (cs, (<>))
import Data.Typeable
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
symbolVal)
import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Socket (SockAddr)
import Network.Wai (Application, Request, Response,
httpVersion, isSecure,
lazyRequestBody,
rawQueryString, remoteHost,
requestHeaders, requestMethod,
responseLBS, vault)
import Prelude ()
import Prelude.Compat
import Web.HttpApiData (FromHttpApiData)
import Web.HttpApiData.Internal (parseHeaderMaybe,
parseQueryParamMaybe,
parseUrlPieceMaybe)
import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,
Verb, ReflectMethod(reflectMethod),
IsSecure(..), Header,
QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody, Vault,
WithNamedContext)
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
AllCTUnrender (..),
AllMime,
canHandleAcceptH)
import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
getResponse)
import Servant.Server.Internal.Context
import Servant.Server.Internal.BasicAuth
import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
class HasServer layout context where
type ServerT layout (m :: * -> *) :: *
route ::
Proxy layout
-> Context context
-> Delayed env (Server layout)
-> Router env
type Server layout = ServerT layout Handler
instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) context where
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server))
(route pb context ((\ (_ :<|> b) -> b) <$> server))
where pa = Proxy :: Proxy a
pb = Proxy :: Proxy b
instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)
=> HasServer (Capture capture a :> sublayout) context where
type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m
route Proxy context d =
CaptureRouter $
route (Proxy :: Proxy sublayout)
context
(addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of
Nothing -> delayedFail err400
Just v -> return v
)
allowedMethodHead :: Method -> Request -> Bool
allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
allowedMethod :: Method -> Request -> Bool
allowedMethod method request = allowedMethodHead method request || requestMethod request == method
processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method
-> Maybe [(HeaderName, B.ByteString)]
-> Request -> RouteResult Response
processMethodRouter handleA status method headers request = case handleA of
Nothing -> FailFatal err406
Just (contentT, body) -> Route $ responseLBS status hdrs bdy
where
bdy = if allowedMethodHead method request then "" else body
hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
methodCheck :: Method -> Request -> DelayedIO ()
methodCheck method request
| allowedMethod method request = return ()
| otherwise = delayedFail err405
acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()
acceptCheck proxy accH
| canHandleAcceptH proxy (AcceptHeader accH) = return ()
| otherwise = delayedFail err406
methodRouter :: (AllCTRender ctypes a)
=> Method -> Proxy ctypes -> Status
-> Delayed env (Handler a)
-> Router env
methodRouter method proxy status action = leafRouter route'
where
route' env request respond =
let accH = fromMaybe ct_wildcard $ 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)
=> Method -> Proxy ctypes -> Status
-> Delayed env (Handler (Headers h v))
-> Router env
methodRouterHeaders method proxy status action = leafRouter route'
where
route' env request respond =
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH
) env request respond $ \ output -> do
let headers = getHeaders output
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
processMethodRouter handleA status method (Just headers) request
instance OVERLAPPABLE_
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
) => HasServer (Verb method status ctypes a) context where
type ServerT (Verb method status ctypes a) m = m a
route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance OVERLAPPING_
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
, GetHeaders (Headers h a)
) => HasServer (Verb method status ctypes (Headers h a)) context where
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
=> HasServer (Header sym a :> sublayout) context where
type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy context subserver =
let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req)
in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader)
where str = fromString $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
=> HasServer (QueryParam sym a :> sublayout) context where
type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy context subserver =
let querytext r = parseQueryText $ rawQueryString r
param r =
case lookup paramname (querytext r) of
Nothing -> Nothing
Just Nothing -> Nothing
Just (Just v) -> parseQueryParamMaybe v
in route (Proxy :: Proxy sublayout) context (passToServer subserver param)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
=> HasServer (QueryParams sym a :> sublayout) context where
type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m
route Proxy context subserver =
let querytext r = parseQueryText $ rawQueryString r
parameters r = filter looksLikeParam (querytext r)
values r = mapMaybe (convert . snd) (parameters r)
in route (Proxy :: Proxy sublayout) context (passToServer subserver values)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing
convert (Just v) = parseQueryParamMaybe v
instance (KnownSymbol sym, HasServer sublayout context)
=> HasServer (QueryFlag sym :> sublayout) context where
type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
route Proxy context subserver =
let querytext r = parseQueryText $ rawQueryString r
param r = case lookup paramname (querytext r) of
Just Nothing -> True
Just (Just v) -> examine v
Nothing -> False
in route (Proxy :: Proxy sublayout) context (passToServer subserver param)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False
instance HasServer Raw context where
type ServerT Raw m = Application
route Proxy _ rawApplication = RawRouter $ \ env request respond -> do
r <- runDelayed rawApplication env request
case r of
Route app -> app request (respond . Route)
Fail a -> respond $ Fail a
FailFatal e -> respond $ FailFatal e
instance ( AllCTUnrender list a, HasServer sublayout context
) => HasServer (ReqBody list a :> sublayout) context where
type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m
route Proxy context subserver =
route (Proxy :: Proxy sublayout) context (addBodyCheck subserver bodyCheck)
where
bodyCheck = withRequest $ \ request -> do
let contentTypeH = fromMaybe "application/octet-stream"
$ lookup hContentType $ requestHeaders request
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
<$> liftIO (lazyRequestBody request)
case mrqbody of
Nothing -> delayedFailFatal err415
Just (Left e) -> delayedFailFatal err400 { errBody = cs e }
Just (Right v) -> return v
instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> sublayout) context where
type ServerT (path :> sublayout) m = ServerT sublayout m
route Proxy context subserver =
pathRouter
(cs (symbolVal proxyPath))
(route (Proxy :: Proxy sublayout) context subserver)
where proxyPath = Proxy :: Proxy path
instance HasServer api context => HasServer (RemoteHost :> api) context where
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver remoteHost)
instance HasServer api context => HasServer (IsSecure :> api) context where
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver secure)
where secure req = if isSecure req then Secure else NotSecure
instance HasServer api context => HasServer (Vault :> api) context where
type ServerT (Vault :> api) m = Vault -> ServerT api m
route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver vault)
instance HasServer api context => HasServer (HttpVersion :> api) context where
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver httpVersion)
instance ( KnownSymbol realm
, HasServer api context
, HasContextEntry context (BasicAuthCheck usr)
)
=> HasServer (BasicAuth realm usr :> api) context where
type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m
route Proxy context subserver =
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck)
where
realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
basicAuthContext = getContextEntry context
authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext
ct_wildcard :: B.ByteString
ct_wildcard = "*" <> "/" <> "*"
instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext)
=> HasServer (WithNamedContext name subContext subApi) context where
type ServerT (WithNamedContext name subContext subApi) m =
ServerT subApi m
route Proxy context delayed =
route subProxy subContext delayed
where
subProxy :: Proxy subApi
subProxy = Proxy
subContext :: Context subContext
subContext = descendIntoNamedContext (Proxy :: Proxy name) context