servant/servant-server/src/Servant/Server/Internal.hs
2016-03-26 20:58:59 +08:00

495 lines
21 KiB
Haskell

{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
#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.Except (ExceptT)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import Data.Maybe (fromMaybe, mapMaybe)
import Data.String (fromString)
import Data.String.Conversions (cs, (<>))
import Data.Text (Text)
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, pathInfo,
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 (Server layout) -> Router
type Server layout = ServerT layout (ExceptT ServantErr IO)
-- * 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 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
-- | 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 -> ExceptT ServantErr IO Book
-- > getBook isbn = ...
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 =
DynamicRouter $ \ first ->
route (Proxy :: Proxy sublayout)
context
(addCapture d $ case parseUrlPieceMaybe first :: Maybe a of
Nothing -> return $ Fail err404
Just v -> return $ Route 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 -- 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 [] headers)
methodCheck :: Method -> Request -> IO (RouteResult ())
methodCheck method request
| allowedMethod method request = return $ Route ()
| otherwise = return $ Fail err405
acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())
acceptCheck proxy accH
| canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()
| otherwise = return $ FailFatal err406
methodRouter :: (AllCTRender ctypes a)
=> Method -> Proxy ctypes -> Status
-> Delayed (ExceptT ServantErr IO a)
-> Router
methodRouter method proxy status action = LeafRouter route'
where
route' request respond
| pathIsEmpty request =
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH
) respond $ \ output -> do
let handleA = handleAcceptH proxy (AcceptHeader accH) output
processMethodRouter handleA status method Nothing request
| otherwise = respond $ Fail err404
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
=> Method -> Proxy ctypes -> Status
-> Delayed (ExceptT ServantErr IO (Headers h v))
-> Router
methodRouterHeaders method proxy status action = LeafRouter route'
where
route' request respond
| pathIsEmpty request =
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH
) respond $ \ output -> do
let headers = getHeaders output
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
processMethodRouter handleA status method (Just headers) request
| otherwise = respond $ Fail err404
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)
-- | 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, FromHttpApiData, ToText)
-- >
-- > -- GET /view-my-referer
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
-- >
-- > server :: Server MyApi
-- > server = viewReferer
-- > where viewReferer :: Referer -> ExceptT ServantErr IO referer
-- > viewReferer referer = return referer
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 = WithRequest $ \ request ->
let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader)
where str = fromString $ symbolVal (Proxy :: Proxy sym)
-- | 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 -> ExceptT ServantErr IO [Book]
-- > getBooksBy Nothing = ...return all books...
-- > getBooksBy (Just author) = ...return books by the given author...
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 = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
param =
case lookup paramname querytext of
Nothing -> Nothing -- param absent from the query string
Just Nothing -> Nothing -- param present with no value -> Nothing
Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
-- the right type
in route (Proxy :: Proxy sublayout) context (passToServer subserver param)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
-- | 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] -> ExceptT ServantErr IO [Book]
-- > getBooksBy authors = ...return all books by these authors...
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 = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
-- if sym is "foo", we look for query string parameters
-- named "foo" or "foo[]" and call parseQueryParam on the
-- corresponding values
parameters = filter looksLikeParam querytext
values = mapMaybe (convert . snd) parameters
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
-- | 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 -> ExceptT ServantErr IO [Book]
-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
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 = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
param = case lookup paramname querytext 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 sublayout) 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 where
type ServerT Raw m = Application
route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
r <- runDelayed rawApplication
case r of
Route app -> 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
-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 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 -> ExceptT ServantErr IO Book
-- > postBook book = ...insert into your db...
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 = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request))
where
bodyCheck 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"
$ lookup hContentType $ requestHeaders request
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
<$> lazyRequestBody request
case mrqbody of
Nothing -> return $ FailFatal err415
Just (Left e) -> return $ FailFatal err400 { errBody = cs e }
Just (Right v) -> return $ Route v
-- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @sublayout@.
instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> sublayout) context where
type ServerT (path :> sublayout) m = ServerT sublayout m
route Proxy context subserver = StaticRouter $
M.singleton (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 = WithRequest $ \req ->
route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req)
instance HasServer api context => HasServer (IsSecure :> api) context where
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
route Proxy context subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) context (passToServer subserver $ secure req)
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 = WithRequest $ \req ->
route (Proxy :: Proxy api) context (passToServer subserver $ vault req)
instance HasServer api context => HasServer (HttpVersion :> api) context where
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
route Proxy context subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)
-- | Basic Authentication
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 = WithRequest $ \ request ->
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)
where
realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
basicAuthContext = getContextEntry context
authCheck req = runBasicAuth req realm basicAuthContext
-- * helpers
pathIsEmpty :: Request -> Bool
pathIsEmpty = go . pathInfo
where go [] = True
go [""] = True
go _ = False
ct_wildcard :: B.ByteString
ct_wildcard = "*" <> "/" <> "*" -- Because CPP
-- * General Authentication
-- * contexts
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