2015-09-15 11:37:17 +02:00
|
|
|
{-# LANGUAGE CPP #-}
|
2016-01-14 23:43:48 +01:00
|
|
|
{-# LANGUAGE ConstraintKinds #-}
|
2015-09-15 11:37:17 +02:00
|
|
|
{-# LANGUAGE DataKinds #-}
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
2015-05-29 17:16:36 +02:00
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
2016-01-19 00:19:51 +01:00
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
2015-09-15 11:37:17 +02:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE PolyKinds #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
{-# LANGUAGE TypeOperators #-}
|
2015-12-27 17:54:29 +01:00
|
|
|
|
|
|
|
#include "overlapping-compat.h"
|
2015-04-22 14:57:30 +02:00
|
|
|
|
2015-06-01 19:38:51 +02:00
|
|
|
module Servant.Server.Internal
|
|
|
|
( module Servant.Server.Internal
|
2016-02-17 19:56:15 +01:00
|
|
|
, module Servant.Server.Internal.BasicAuth
|
2015-12-02 21:48:12 +01:00
|
|
|
, module Servant.Server.Internal.Context
|
2017-01-16 10:44:25 +01:00
|
|
|
, module Servant.Server.Internal.Handler
|
2015-06-01 19:38:51 +02:00
|
|
|
, module Servant.Server.Internal.Router
|
|
|
|
, module Servant.Server.Internal.RoutingApplication
|
|
|
|
, module Servant.Server.Internal.ServantErr
|
|
|
|
) where
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2016-04-09 15:42:57 +02:00
|
|
|
import Control.Monad.Trans (liftIO)
|
2017-01-18 11:25:18 +01:00
|
|
|
import Control.Monad.Trans.Resource (runResourceT)
|
2015-11-27 02:05:34 +01:00
|
|
|
import qualified Data.ByteString as B
|
2016-02-17 19:56:15 +01:00
|
|
|
import qualified Data.ByteString.Char8 as BC8
|
2015-11-27 02:05:34 +01:00
|
|
|
import qualified Data.ByteString.Lazy as BL
|
2017-01-16 13:17:20 +01:00
|
|
|
import Data.Maybe (fromMaybe, mapMaybe)
|
2016-12-12 15:17:06 +01:00
|
|
|
import Data.Either (partitionEithers)
|
2015-11-27 02:05:34 +01:00
|
|
|
import Data.String (fromString)
|
|
|
|
import Data.String.Conversions (cs, (<>))
|
2017-05-16 11:34:07 +02:00
|
|
|
import Data.Tagged (Tagged(..), untag)
|
2017-01-16 13:17:20 +01:00
|
|
|
import qualified Data.Text as T
|
2015-04-13 15:13:55 +02:00
|
|
|
import Data.Typeable
|
2015-11-27 02:05:34 +01:00
|
|
|
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,
|
2016-04-07 13:45:15 +02:00
|
|
|
lazyRequestBody,
|
2015-11-27 02:05:34 +01:00
|
|
|
rawQueryString, remoteHost,
|
|
|
|
requestHeaders, requestMethod,
|
|
|
|
responseLBS, vault)
|
2016-03-01 19:25:04 +01:00
|
|
|
import Prelude ()
|
2016-03-01 12:41:24 +01:00
|
|
|
import Prelude.Compat
|
2017-04-06 13:59:16 +02:00
|
|
|
import Web.HttpApiData (FromHttpApiData, parseHeader,
|
2016-12-12 15:17:06 +01:00
|
|
|
parseQueryParam,
|
2016-08-31 12:32:12 +02:00
|
|
|
parseUrlPieceMaybe,
|
|
|
|
parseUrlPieces)
|
2016-03-06 22:23:55 +01:00
|
|
|
import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,
|
2017-05-16 11:34:07 +02:00
|
|
|
CaptureAll, Verb, EmptyAPI,
|
2016-05-26 20:10:15 +02:00
|
|
|
ReflectMethod(reflectMethod),
|
|
|
|
IsSecure(..), Header, QueryFlag,
|
|
|
|
QueryParam, QueryParams, Raw,
|
|
|
|
RemoteHost, ReqBody, Vault,
|
2016-02-28 23:23:32 +01:00
|
|
|
WithNamedContext)
|
2015-04-13 15:13:55 +02:00
|
|
|
import Servant.API.ContentTypes (AcceptHeader (..),
|
|
|
|
AllCTRender (..),
|
2015-09-16 22:07:55 +02:00
|
|
|
AllCTUnrender (..),
|
|
|
|
AllMime,
|
|
|
|
canHandleAcceptH)
|
2015-09-15 11:37:17 +02:00
|
|
|
import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
|
|
|
|
getResponse)
|
2015-01-13 20:40:41 +01:00
|
|
|
|
2016-02-28 23:23:32 +01:00
|
|
|
import Servant.Server.Internal.Context
|
2016-02-17 19:56:15 +01:00
|
|
|
import Servant.Server.Internal.BasicAuth
|
2017-01-16 10:44:25 +01:00
|
|
|
import Servant.Server.Internal.Handler
|
2015-06-01 19:38:51 +02:00
|
|
|
import Servant.Server.Internal.Router
|
|
|
|
import Servant.Server.Internal.RoutingApplication
|
2015-05-02 04:38:53 +02:00
|
|
|
import Servant.Server.Internal.ServantErr
|
|
|
|
|
2015-10-07 23:38:47 +02:00
|
|
|
|
2016-06-02 09:49:55 +02:00
|
|
|
class HasServer api context where
|
|
|
|
type ServerT api (m :: * -> *) :: *
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2016-04-09 15:42:57 +02:00
|
|
|
route ::
|
2016-06-02 09:49:55 +02:00
|
|
|
Proxy api
|
2016-04-09 15:42:57 +02:00
|
|
|
-> Context context
|
2016-06-02 09:49:55 +02:00
|
|
|
-> Delayed env (Server api)
|
2016-04-09 15:42:57 +02:00
|
|
|
-> Router env
|
2014-12-28 23:07:14 +01:00
|
|
|
|
2016-06-02 09:49:55 +02:00
|
|
|
type Server api = ServerT api Handler
|
2015-03-02 22:23:56 +01:00
|
|
|
|
2014-12-10 16:10:57 +01:00
|
|
|
-- * Instances
|
|
|
|
|
2014-12-28 23:07:14 +01:00
|
|
|
-- | A server for @a ':<|>' b@ first tries to match the request against the route
|
2014-12-10 16:10:57 +01:00
|
|
|
-- represented by @a@ and if it fails tries @b@. You must provide a request
|
|
|
|
-- handler for each route.
|
|
|
|
--
|
2015-01-13 20:40:41 +01:00
|
|
|
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
|
|
|
|
-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
|
2014-12-10 16:10:57 +01:00
|
|
|
-- >
|
|
|
|
-- > server :: Server MyApi
|
|
|
|
-- > server = listAllBooks :<|> postBook
|
|
|
|
-- > where listAllBooks = ...
|
|
|
|
-- > postBook book = ...
|
2016-02-28 23:23:32 +01:00
|
|
|
instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) context where
|
2015-03-02 22:23:56 +01:00
|
|
|
|
2015-05-03 01:45:17 +02:00
|
|
|
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
|
2015-03-02 22:23:56 +01:00
|
|
|
|
2016-02-28 23:23:32 +01:00
|
|
|
route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server))
|
2016-04-09 15:42:57 +02:00
|
|
|
(route pb context ((\ (_ :<|> b) -> b) <$> server))
|
2014-12-10 16:10:57 +01:00
|
|
|
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
|
2015-10-07 23:38:47 +02:00
|
|
|
-- by simply providing an instance of 'FromHttpApiData' for your type.
|
2014-12-10 16:10:57 +01:00
|
|
|
--
|
|
|
|
-- Example:
|
|
|
|
--
|
2015-01-13 20:40:41 +01:00
|
|
|
-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
|
2014-12-10 16:10:57 +01:00
|
|
|
-- >
|
|
|
|
-- > server :: Server MyApi
|
|
|
|
-- > server = getBook
|
2016-04-07 23:34:23 +02:00
|
|
|
-- > where getBook :: Text -> Handler Book
|
2014-12-10 16:10:57 +01:00
|
|
|
-- > getBook isbn = ...
|
2016-06-02 09:49:55 +02:00
|
|
|
instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
|
|
|
|
=> HasServer (Capture capture a :> api) context where
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2016-06-02 09:49:55 +02:00
|
|
|
type ServerT (Capture capture a :> api) m =
|
|
|
|
a -> ServerT api m
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2016-02-28 23:23:32 +01:00
|
|
|
route Proxy context d =
|
2016-04-09 15:42:57 +02:00
|
|
|
CaptureRouter $
|
2016-06-02 09:49:55 +02:00
|
|
|
route (Proxy :: Proxy api)
|
2016-02-28 23:23:32 +01:00
|
|
|
context
|
2016-05-26 20:10:15 +02:00
|
|
|
(addCapture d $ \ txt -> case parseUrlPieceMaybe txt of
|
2016-04-09 15:42:57 +02:00
|
|
|
Nothing -> delayedFail err400
|
|
|
|
Just v -> return v
|
2015-09-16 22:07:55 +02:00
|
|
|
)
|
2015-01-12 15:08:41 +01:00
|
|
|
|
2016-05-26 20:10:15 +02:00
|
|
|
-- | If you use 'CaptureAll' in one of the endpoints for your API,
|
|
|
|
-- this automatically requires your server-side handler to be a
|
|
|
|
-- function that takes an argument of a list of the type specified by
|
|
|
|
-- the 'CaptureAll'. This lets servant worry about getting values from
|
|
|
|
-- the URL and turning them into values of the type you specify.
|
|
|
|
--
|
|
|
|
-- You can control how they'll be converted from 'Text' to your type
|
|
|
|
-- by simply providing an instance of 'FromHttpApiData' for your type.
|
|
|
|
--
|
|
|
|
-- Example:
|
|
|
|
--
|
|
|
|
-- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile
|
|
|
|
-- >
|
|
|
|
-- > server :: Server MyApi
|
|
|
|
-- > server = getSourceFile
|
|
|
|
-- > where getSourceFile :: [Text] -> Handler Book
|
|
|
|
-- > getSourceFile pathSegments = ...
|
|
|
|
instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)
|
|
|
|
=> HasServer (CaptureAll capture a :> sublayout) context where
|
|
|
|
|
|
|
|
type ServerT (CaptureAll capture a :> sublayout) m =
|
|
|
|
[a] -> ServerT sublayout m
|
|
|
|
|
|
|
|
route Proxy context d =
|
|
|
|
CaptureAllRouter $
|
|
|
|
route (Proxy :: Proxy sublayout)
|
|
|
|
context
|
|
|
|
(addCapture d $ \ txts -> case parseUrlPieces txts of
|
|
|
|
Left _ -> delayedFail err400
|
|
|
|
Right v -> return v
|
|
|
|
)
|
|
|
|
|
|
|
|
|
2015-07-30 01:37:55 +02:00
|
|
|
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
|
|
|
|
|
2015-11-27 02:05:34 +01:00
|
|
|
processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method
|
2015-07-30 01:37:55 +02:00
|
|
|
-> Maybe [(HeaderName, B.ByteString)]
|
|
|
|
-> Request -> RouteResult Response
|
|
|
|
processMethodRouter handleA status method headers request = case handleA of
|
2015-09-16 22:07:55 +02:00
|
|
|
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
|
2015-07-30 01:37:55 +02:00
|
|
|
where
|
2015-08-17 23:50:42 +02:00
|
|
|
bdy = if allowedMethodHead method request then "" else body
|
2015-07-30 01:37:55 +02:00
|
|
|
hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2016-04-09 15:42:57 +02:00
|
|
|
methodCheck :: Method -> Request -> DelayedIO ()
|
2015-09-16 22:07:55 +02:00
|
|
|
methodCheck method request
|
2016-04-09 15:42:57 +02:00
|
|
|
| allowedMethod method request = return ()
|
|
|
|
| otherwise = delayedFail err405
|
2015-09-16 22:07:55 +02:00
|
|
|
|
2016-04-12 10:35:07 +02:00
|
|
|
-- 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.
|
2016-04-09 15:42:57 +02:00
|
|
|
acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()
|
2015-09-16 22:07:55 +02:00
|
|
|
acceptCheck proxy accH
|
2016-04-09 15:42:57 +02:00
|
|
|
| canHandleAcceptH proxy (AcceptHeader accH) = return ()
|
2016-04-12 10:35:07 +02:00
|
|
|
| otherwise = delayedFail err406
|
2015-09-16 22:07:55 +02:00
|
|
|
|
2015-06-01 21:12:12 +02:00
|
|
|
methodRouter :: (AllCTRender ctypes a)
|
|
|
|
=> Method -> Proxy ctypes -> Status
|
2016-04-09 15:42:57 +02:00
|
|
|
-> Delayed env (Handler a)
|
|
|
|
-> Router env
|
2016-04-07 13:45:15 +02:00
|
|
|
methodRouter method proxy status action = leafRouter route'
|
2015-06-01 21:12:12 +02:00
|
|
|
where
|
2016-04-09 15:42:57 +02:00
|
|
|
route' env request respond =
|
2015-09-16 22:07:55 +02:00
|
|
|
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
|
|
|
in runAction (action `addMethodCheck` methodCheck method request
|
2015-11-27 02:05:34 +01:00
|
|
|
`addAcceptCheck` acceptCheck proxy accH
|
2016-04-09 15:42:57 +02:00
|
|
|
) env request respond $ \ output -> do
|
2015-09-16 22:07:55 +02:00
|
|
|
let handleA = handleAcceptH proxy (AcceptHeader accH) output
|
|
|
|
processMethodRouter handleA status method Nothing request
|
2015-06-01 21:12:12 +02:00
|
|
|
|
|
|
|
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
|
|
|
|
=> Method -> Proxy ctypes -> Status
|
2016-04-09 15:42:57 +02:00
|
|
|
-> Delayed env (Handler (Headers h v))
|
|
|
|
-> Router env
|
2016-04-07 13:45:15 +02:00
|
|
|
methodRouterHeaders method proxy status action = leafRouter route'
|
2015-06-01 21:12:12 +02:00
|
|
|
where
|
2016-04-09 15:42:57 +02:00
|
|
|
route' env request respond =
|
2015-09-16 22:07:55 +02:00
|
|
|
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
|
|
|
in runAction (action `addMethodCheck` methodCheck method request
|
2015-11-27 02:05:34 +01:00
|
|
|
`addAcceptCheck` acceptCheck proxy accH
|
2016-04-09 15:42:57 +02:00
|
|
|
) env request respond $ \ output -> do
|
2015-09-16 22:07:55 +02:00
|
|
|
let headers = getHeaders output
|
|
|
|
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
|
|
|
|
processMethodRouter handleA status method (Just headers) request
|
2015-06-01 21:12:12 +02:00
|
|
|
|
2015-12-27 17:54:29 +01:00
|
|
|
instance OVERLAPPABLE_
|
2015-11-27 02:05:34 +01:00
|
|
|
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
|
2016-02-28 23:23:32 +01:00
|
|
|
) => HasServer (Verb method status ctypes a) context where
|
2015-05-06 21:21:35 +02:00
|
|
|
|
2015-11-27 02:05:34 +01:00
|
|
|
type ServerT (Verb method status ctypes a) m = m a
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2016-01-14 23:43:48 +01:00
|
|
|
route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
|
2015-11-27 02:05:34 +01:00
|
|
|
where method = reflectMethod (Proxy :: Proxy method)
|
|
|
|
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
2015-05-06 21:21:35 +02:00
|
|
|
|
2015-12-27 17:54:29 +01:00
|
|
|
instance OVERLAPPING_
|
2015-11-27 02:05:34 +01:00
|
|
|
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
|
|
|
|
, GetHeaders (Headers h a)
|
2016-02-28 23:23:32 +01:00
|
|
|
) => HasServer (Verb method status ctypes (Headers h a)) context where
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2015-11-27 02:05:34 +01:00
|
|
|
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
|
2015-03-02 22:23:56 +01:00
|
|
|
|
2016-01-14 23:43:48 +01:00
|
|
|
route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
|
2015-11-27 02:05:34 +01:00
|
|
|
where method = reflectMethod (Proxy :: Proxy method)
|
|
|
|
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
2015-04-13 15:13:55 +02:00
|
|
|
|
2014-12-10 16:10:57 +01:00
|
|
|
-- | 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.
|
|
|
|
--
|
2015-10-07 23:38:47 +02:00
|
|
|
-- All it asks is for a 'FromHttpApiData' instance.
|
2014-12-10 16:10:57 +01:00
|
|
|
--
|
|
|
|
-- Example:
|
|
|
|
--
|
|
|
|
-- > newtype Referer = Referer Text
|
2016-04-02 09:03:00 +02:00
|
|
|
-- > deriving (Eq, Show, FromHttpApiData)
|
2014-12-10 16:10:57 +01:00
|
|
|
-- >
|
|
|
|
-- > -- GET /view-my-referer
|
2015-01-13 20:40:41 +01:00
|
|
|
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
|
2014-12-10 16:10:57 +01:00
|
|
|
-- >
|
|
|
|
-- > server :: Server MyApi
|
|
|
|
-- > server = viewReferer
|
2016-04-07 23:34:23 +02:00
|
|
|
-- > where viewReferer :: Referer -> Handler referer
|
2014-12-10 16:10:57 +01:00
|
|
|
-- > viewReferer referer = return referer
|
2016-06-02 09:49:55 +02:00
|
|
|
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
|
|
|
|
=> HasServer (Header sym a :> api) context where
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2016-06-02 09:49:55 +02:00
|
|
|
type ServerT (Header sym a :> api) m =
|
|
|
|
Maybe a -> ServerT api m
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2017-04-06 13:59:16 +02:00
|
|
|
route Proxy context subserver = route (Proxy :: Proxy api) context $
|
|
|
|
subserver `addHeaderCheck` withRequest headerCheck
|
|
|
|
where
|
|
|
|
headerName = symbolVal (Proxy :: Proxy sym)
|
|
|
|
headerCheck req =
|
|
|
|
case lookup (fromString headerName) (requestHeaders req) of
|
|
|
|
Nothing -> return Nothing
|
|
|
|
Just txt ->
|
|
|
|
case parseHeader txt of
|
|
|
|
Left e -> delayedFailFatal err400
|
|
|
|
{ errBody = cs $ "Error parsing header "
|
|
|
|
<> fromString headerName
|
|
|
|
<> " failed: " <> e
|
|
|
|
}
|
|
|
|
Right header -> return $ Just header
|
2014-12-10 16:10:57 +01:00
|
|
|
|
|
|
|
-- | 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
|
2015-10-07 23:38:47 +02:00
|
|
|
-- by simply providing an instance of 'FromHttpApiData' for your type.
|
2014-12-10 16:10:57 +01:00
|
|
|
--
|
|
|
|
-- Example:
|
|
|
|
--
|
2015-01-13 20:40:41 +01:00
|
|
|
-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
|
2014-12-10 16:10:57 +01:00
|
|
|
-- >
|
|
|
|
-- > server :: Server MyApi
|
|
|
|
-- > server = getBooksBy
|
2016-04-07 23:34:23 +02:00
|
|
|
-- > where getBooksBy :: Maybe Text -> Handler [Book]
|
2014-12-10 16:10:57 +01:00
|
|
|
-- > getBooksBy Nothing = ...return all books...
|
|
|
|
-- > getBooksBy (Just author) = ...return books by the given author...
|
2016-06-02 09:49:55 +02:00
|
|
|
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
|
|
|
|
=> HasServer (QueryParam sym a :> api) context where
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2016-06-02 09:49:55 +02:00
|
|
|
type ServerT (QueryParam sym a :> api) m =
|
|
|
|
Maybe a -> ServerT api m
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2016-04-09 15:42:57 +02:00
|
|
|
route Proxy context subserver =
|
2016-12-12 15:17:06 +01:00
|
|
|
let querytext req = parseQueryText $ rawQueryString req
|
|
|
|
parseParam req =
|
|
|
|
case lookup paramname (querytext req) of
|
|
|
|
Nothing -> return Nothing -- param absent from the query string
|
|
|
|
Just Nothing -> return Nothing -- param present with no value -> Nothing
|
|
|
|
Just (Just v) ->
|
|
|
|
case parseQueryParam v of
|
2017-01-16 13:17:20 +01:00
|
|
|
Left e -> delayedFailFatal err400
|
2017-04-06 13:59:16 +02:00
|
|
|
{ errBody = cs $ "Error parsing query parameter "
|
|
|
|
<> paramname <> " failed: " <> e
|
2017-01-16 13:17:20 +01:00
|
|
|
}
|
2016-12-12 15:17:06 +01:00
|
|
|
|
|
|
|
Right param -> return $ Just param
|
|
|
|
delayed = addParameterCheck subserver . withRequest $ \req ->
|
|
|
|
parseParam req
|
|
|
|
|
|
|
|
in route (Proxy :: Proxy api) context delayed
|
2014-12-10 16:10:57 +01:00
|
|
|
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
|
2015-10-07 23:38:47 +02:00
|
|
|
-- by simply providing an instance of 'FromHttpApiData' for your type.
|
2014-12-10 16:10:57 +01:00
|
|
|
--
|
|
|
|
-- Example:
|
|
|
|
--
|
2015-01-13 20:40:41 +01:00
|
|
|
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
|
2014-12-10 16:10:57 +01:00
|
|
|
-- >
|
|
|
|
-- > server :: Server MyApi
|
|
|
|
-- > server = getBooksBy
|
2016-04-07 23:34:23 +02:00
|
|
|
-- > where getBooksBy :: [Text] -> Handler [Book]
|
2014-12-10 16:10:57 +01:00
|
|
|
-- > getBooksBy authors = ...return all books by these authors...
|
2016-06-02 09:49:55 +02:00
|
|
|
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
|
|
|
|
=> HasServer (QueryParams sym a :> api) context where
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2016-06-02 09:49:55 +02:00
|
|
|
type ServerT (QueryParams sym a :> api) m =
|
|
|
|
[a] -> ServerT api m
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2017-01-16 13:17:20 +01:00
|
|
|
route Proxy context subserver = route (Proxy :: Proxy api) context $
|
|
|
|
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
|
2017-04-06 13:59:16 +02:00
|
|
|
{ errBody = cs $ "Error parsing query parameter(s) "
|
|
|
|
<> paramname <> " failed: "
|
|
|
|
<> T.intercalate ", " errs
|
2017-01-16 13:17:20 +01:00
|
|
|
}
|
|
|
|
where
|
|
|
|
params :: [T.Text]
|
|
|
|
params = mapMaybe snd
|
|
|
|
. filter (looksLikeParam . fst)
|
|
|
|
. parseQueryText
|
|
|
|
. rawQueryString
|
|
|
|
$ req
|
|
|
|
|
|
|
|
looksLikeParam name = name == paramname || name == (paramname <> "[]")
|
2014-12-10 16:10:57 +01:00
|
|
|
|
|
|
|
-- | 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:
|
|
|
|
--
|
2015-01-13 20:40:41 +01:00
|
|
|
-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
|
2014-12-10 16:10:57 +01:00
|
|
|
-- >
|
|
|
|
-- > server :: Server MyApi
|
|
|
|
-- > server = getBooks
|
2016-04-07 23:34:23 +02:00
|
|
|
-- > where getBooks :: Bool -> Handler [Book]
|
2014-12-10 16:10:57 +01:00
|
|
|
-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
|
2016-06-02 09:49:55 +02:00
|
|
|
instance (KnownSymbol sym, HasServer api context)
|
|
|
|
=> HasServer (QueryFlag sym :> api) context where
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2016-06-02 09:49:55 +02:00
|
|
|
type ServerT (QueryFlag sym :> api) m =
|
|
|
|
Bool -> ServerT api m
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2016-04-09 15:42:57 +02:00
|
|
|
route Proxy context subserver =
|
|
|
|
let querytext r = parseQueryText $ rawQueryString r
|
|
|
|
param r = case lookup paramname (querytext r) of
|
2014-12-10 16:10:57 +01:00
|
|
|
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
|
2016-06-02 09:49:55 +02:00
|
|
|
in route (Proxy :: Proxy api) context (passToServer subserver param)
|
2014-12-10 16:10:57 +01:00
|
|
|
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"
|
2016-02-28 23:23:32 +01:00
|
|
|
instance HasServer Raw context where
|
2015-03-02 22:23:56 +01:00
|
|
|
|
2015-12-02 21:48:12 +01:00
|
|
|
type ServerT Raw m = Tagged m Application
|
2015-03-02 22:23:56 +01:00
|
|
|
|
2017-01-18 11:25:18 +01:00
|
|
|
route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do
|
2016-10-24 19:21:28 +02:00
|
|
|
-- note: a Raw application doesn't register any cleanup
|
|
|
|
-- but for the sake of consistency, we nonetheless run
|
|
|
|
-- the cleanup once its done
|
2017-01-18 10:37:18 +01:00
|
|
|
r <- runDelayed rawApplication env request
|
2017-01-18 11:25:18 +01:00
|
|
|
liftIO $ go r request respond
|
2016-10-21 19:24:15 +02:00
|
|
|
|
|
|
|
where go r request respond = case r of
|
2015-12-02 21:48:12 +01:00
|
|
|
Route app -> untag app request (respond . Route)
|
2016-10-21 19:24:15 +02:00
|
|
|
Fail a -> respond $ Fail a
|
|
|
|
FailFatal e -> respond $ FailFatal e
|
2014-12-10 16:10:57 +01:00
|
|
|
|
|
|
|
-- | 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'.
|
2015-01-13 20:40:41 +01:00
|
|
|
-- The @Content-Type@ header is inspected, and the list provided is used to
|
|
|
|
-- attempt deserialization. If the request does not have a @Content-Type@
|
2015-09-15 17:21:41 +02:00
|
|
|
-- header, it is treated as @application/octet-stream@ (as specified in
|
|
|
|
-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.
|
2014-12-10 16:10:57 +01:00
|
|
|
-- This lets servant worry about extracting it from the request and turning
|
|
|
|
-- it into a value of the type you specify.
|
|
|
|
--
|
2015-01-13 20:40:41 +01:00
|
|
|
--
|
2014-12-10 16:10:57 +01:00
|
|
|
-- All it asks is for a 'FromJSON' instance.
|
|
|
|
--
|
|
|
|
-- Example:
|
|
|
|
--
|
2015-01-13 20:40:41 +01:00
|
|
|
-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
|
2014-12-10 16:10:57 +01:00
|
|
|
-- >
|
|
|
|
-- > server :: Server MyApi
|
|
|
|
-- > server = postBook
|
2016-04-07 23:34:23 +02:00
|
|
|
-- > where postBook :: Book -> Handler Book
|
2014-12-10 16:10:57 +01:00
|
|
|
-- > postBook book = ...insert into your db...
|
2016-06-02 09:49:55 +02:00
|
|
|
instance ( AllCTUnrender list a, HasServer api context
|
|
|
|
) => HasServer (ReqBody list a :> api) context where
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2016-06-02 09:49:55 +02:00
|
|
|
type ServerT (ReqBody list a :> api) m =
|
|
|
|
a -> ServerT api m
|
2014-12-10 16:10:57 +01:00
|
|
|
|
2017-01-16 13:17:20 +01:00
|
|
|
route Proxy context subserver
|
|
|
|
= route (Proxy :: Proxy api) context $
|
|
|
|
addBodyCheck subserver ctCheck bodyCheck
|
2015-09-16 22:07:55 +02:00
|
|
|
where
|
2017-01-16 13:17:20 +01:00
|
|
|
-- Content-Type check, we only lookup we can try to parse the request body
|
|
|
|
ctCheck = withRequest $ \ request -> do
|
2015-09-16 22:07:55 +02:00
|
|
|
-- 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
|
2017-01-16 13:17:20 +01:00
|
|
|
case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of
|
|
|
|
Nothing -> delayedFailFatal err415
|
|
|
|
Just f -> return f
|
|
|
|
|
|
|
|
-- Body check, we get a body parsing functions as the first argument.
|
|
|
|
bodyCheck f = withRequest $ \ request -> do
|
|
|
|
mrqbody <- f <$> liftIO (lazyRequestBody request)
|
2015-09-16 22:07:55 +02:00
|
|
|
case mrqbody of
|
2017-01-16 13:17:20 +01:00
|
|
|
Left e -> delayedFailFatal err400 { errBody = cs e }
|
|
|
|
Right v -> return v
|
2014-12-10 16:10:57 +01:00
|
|
|
|
|
|
|
-- | Make sure the incoming request starts with @"/path"@, strip it and
|
2016-06-02 09:49:55 +02:00
|
|
|
-- pass the rest of the request path to @api@.
|
|
|
|
instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where
|
2015-03-02 22:23:56 +01:00
|
|
|
|
2016-06-02 09:49:55 +02:00
|
|
|
type ServerT (path :> api) m = ServerT api m
|
2015-03-02 22:23:56 +01:00
|
|
|
|
2016-04-07 13:45:15 +02:00
|
|
|
route Proxy context subserver =
|
|
|
|
pathRouter
|
|
|
|
(cs (symbolVal proxyPath))
|
2016-06-02 09:49:55 +02:00
|
|
|
(route (Proxy :: Proxy api) context subserver)
|
2014-12-10 16:10:57 +01:00
|
|
|
where proxyPath = Proxy :: Proxy path
|
2015-04-22 14:57:30 +02:00
|
|
|
|
2016-02-28 23:23:32 +01:00
|
|
|
instance HasServer api context => HasServer (RemoteHost :> api) context where
|
2015-06-23 10:34:20 +02:00
|
|
|
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
|
|
|
|
|
2016-04-09 15:42:57 +02:00
|
|
|
route Proxy context subserver =
|
|
|
|
route (Proxy :: Proxy api) context (passToServer subserver remoteHost)
|
2015-06-23 10:34:20 +02:00
|
|
|
|
2016-02-28 23:23:32 +01:00
|
|
|
instance HasServer api context => HasServer (IsSecure :> api) context where
|
2015-06-23 10:34:20 +02:00
|
|
|
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
|
|
|
|
|
2016-04-09 15:42:57 +02:00
|
|
|
route Proxy context subserver =
|
|
|
|
route (Proxy :: Proxy api) context (passToServer subserver secure)
|
2015-06-23 10:34:20 +02:00
|
|
|
|
|
|
|
where secure req = if isSecure req then Secure else NotSecure
|
|
|
|
|
2016-02-28 23:23:32 +01:00
|
|
|
instance HasServer api context => HasServer (Vault :> api) context where
|
2015-06-23 10:34:20 +02:00
|
|
|
type ServerT (Vault :> api) m = Vault -> ServerT api m
|
|
|
|
|
2016-04-09 15:42:57 +02:00
|
|
|
route Proxy context subserver =
|
|
|
|
route (Proxy :: Proxy api) context (passToServer subserver vault)
|
2015-06-23 10:34:20 +02:00
|
|
|
|
2016-02-28 23:23:32 +01:00
|
|
|
instance HasServer api context => HasServer (HttpVersion :> api) context where
|
2015-06-23 10:34:20 +02:00
|
|
|
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
|
|
|
|
|
2016-04-09 15:42:57 +02:00
|
|
|
route Proxy context subserver =
|
|
|
|
route (Proxy :: Proxy api) context (passToServer subserver httpVersion)
|
2015-06-23 10:34:20 +02:00
|
|
|
|
2017-05-16 17:53:19 +02:00
|
|
|
-- | Singleton type representing a server that serves an empty API.
|
|
|
|
data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)
|
2017-05-16 11:34:07 +02:00
|
|
|
|
2017-05-16 13:09:54 +02:00
|
|
|
-- | Server for `EmptyAPI`
|
2017-05-16 17:59:41 +02:00
|
|
|
emptyServer :: Server EmptyAPI
|
|
|
|
emptyServer = Tagged EmptyServer
|
2017-05-16 11:34:07 +02:00
|
|
|
|
2017-05-16 13:09:54 +02:00
|
|
|
-- | The server for an `EmptyAPI` is `emptyAPIServer`.
|
|
|
|
--
|
|
|
|
-- > type MyApi = "nothing" :> EmptyApi
|
|
|
|
-- >
|
|
|
|
-- > server :: Server MyApi
|
|
|
|
-- > server = emptyAPIServer
|
2017-05-16 11:34:07 +02:00
|
|
|
instance HasServer EmptyAPI context where
|
2017-05-16 17:53:19 +02:00
|
|
|
type ServerT EmptyAPI m = Tagged m EmptyServer
|
2017-05-16 11:34:07 +02:00
|
|
|
|
|
|
|
route Proxy _ _ = StaticRouter mempty mempty
|
|
|
|
|
2016-02-17 19:56:15 +01:00
|
|
|
-- | Basic Authentication
|
|
|
|
instance ( KnownSymbol realm
|
2016-03-08 23:28:27 +01:00
|
|
|
, HasServer api context
|
|
|
|
, HasContextEntry context (BasicAuthCheck usr)
|
2016-02-17 19:56:15 +01:00
|
|
|
)
|
2016-03-08 23:28:27 +01:00
|
|
|
=> HasServer (BasicAuth realm usr :> api) context where
|
2016-02-17 19:56:15 +01:00
|
|
|
|
|
|
|
type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m
|
|
|
|
|
2016-04-09 15:42:57 +02:00
|
|
|
route Proxy context subserver =
|
|
|
|
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck)
|
2016-02-17 19:56:15 +01:00
|
|
|
where
|
|
|
|
realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
|
2016-03-08 23:28:27 +01:00
|
|
|
basicAuthContext = getContextEntry context
|
2016-04-09 15:42:57 +02:00
|
|
|
authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext
|
2016-02-17 19:56:15 +01:00
|
|
|
|
|
|
|
-- * helpers
|
|
|
|
|
2015-04-22 14:57:30 +02:00
|
|
|
ct_wildcard :: B.ByteString
|
|
|
|
ct_wildcard = "*" <> "/" <> "*" -- Because CPP
|
2016-01-14 23:43:48 +01:00
|
|
|
|
2016-02-17 21:21:57 +01:00
|
|
|
-- * General Authentication
|
|
|
|
|
|
|
|
|
2016-02-28 23:23:32 +01:00
|
|
|
-- * contexts
|
2016-01-14 23:43:48 +01:00
|
|
|
|
2016-02-28 23:23:32 +01:00
|
|
|
instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext)
|
|
|
|
=> HasServer (WithNamedContext name subContext subApi) context where
|
2016-01-19 00:19:51 +01:00
|
|
|
|
2016-02-28 23:23:32 +01:00
|
|
|
type ServerT (WithNamedContext name subContext subApi) m =
|
2016-01-14 23:43:48 +01:00
|
|
|
ServerT subApi m
|
|
|
|
|
2016-02-28 23:23:32 +01:00
|
|
|
route Proxy context delayed =
|
|
|
|
route subProxy subContext delayed
|
2016-01-14 23:43:48 +01:00
|
|
|
where
|
|
|
|
subProxy :: Proxy subApi
|
|
|
|
subProxy = Proxy
|
|
|
|
|
2016-02-28 23:23:32 +01:00
|
|
|
subContext :: Context subContext
|
|
|
|
subContext = descendIntoNamedContext (Proxy :: Proxy name) context
|