servant/src/Servant/Server/Internal.hs

642 lines
26 KiB
Haskell
Raw Normal View History

2014-12-10 16:10:57 +01:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.Server.Internal where
2015-01-06 17:25:25 +01:00
import Control.Applicative ((<$>))
import Control.Monad.Trans.Either (EitherT, runEitherT)
import Data.Aeson (ToJSON, FromJSON, encode, decode')
2015-01-03 18:07:39 +01:00
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
2015-01-06 17:25:25 +01:00
import Data.IORef (newIORef, readIORef, writeIORef)
2014-12-28 23:07:14 +01:00
import Data.List (unfoldr)
2015-01-03 18:07:39 +01:00
import Data.Maybe (catMaybes)
2015-01-06 17:25:25 +01:00
import Data.Monoid (Monoid, mempty, mappend)
import Data.Proxy (Proxy(Proxy))
import Data.String (fromString)
import Data.String.Conversions (cs, (<>))
2014-12-28 23:07:14 +01:00
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
2015-01-02 19:34:15 +01:00
import Data.Text (Text)
2014-12-28 23:07:14 +01:00
import qualified Data.Text as T
2015-01-06 17:25:25 +01:00
import GHC.TypeLits (KnownSymbol, symbolVal)
2014-12-10 16:10:57 +01:00
import Network.HTTP.Types hiding (Header)
2015-01-06 17:25:25 +01:00
import Network.Wai (Response, Request, ResponseReceived, Application, pathInfo, requestBody,
strictRequestBody, lazyRequestBody, requestHeaders, requestMethod,
rawQueryString, responseLBS)
2014-12-28 23:07:14 +01:00
import Servant.API (QueryParams, QueryParam, QueryFlag, MatrixParams, MatrixParam, MatrixFlag, ReqBody, Header, Capture, Get, Delete, Put, Post, Raw, (:>), (:<|>)(..))
2015-01-06 17:25:25 +01:00
import Servant.Common.Text (FromText, fromText)
2014-12-10 16:10:57 +01:00
2015-01-03 18:07:39 +01:00
data ReqBodyState = Uncalled
| Called !B.ByteString
| Done !B.ByteString
2015-01-03 18:07:39 +01:00
2014-12-10 16:10:57 +01:00
toApplication :: RoutingApplication -> Application
toApplication ra request respond = do
2015-01-03 18:07:39 +01:00
reqBodyRef <- newIORef Uncalled
2015-01-04 16:08:22 +01:00
-- We may need to consume the requestBody more than once. In order to
-- maintain the illusion that 'requestBody' works as expected,
-- 'ReqBodyState' is introduced, and the complete body is memoized and
-- returned as many times as requested with empty "Done" marker chunks in
-- between.
-- See https://github.com/haskell-servant/servant/issues/3
2015-01-03 18:07:39 +01:00
let memoReqBody = do
ior <- readIORef reqBodyRef
case ior of
Uncalled -> do
r <- BL.toStrict <$> strictRequestBody request
writeIORef reqBodyRef $ Done r
return r
Called bs -> do
writeIORef reqBodyRef $ Done bs
return bs
Done bs -> do
writeIORef reqBodyRef $ Called bs
return B.empty
2015-01-02 19:34:15 +01:00
ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
2014-12-10 16:10:57 +01:00
where
routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
routingRespond (Left NotFound) =
respond $ responseLBS notFound404 [] "not found"
routingRespond (Left WrongMethod) =
respond $ responseLBS methodNotAllowed405 [] "method not allowed"
routingRespond (Left InvalidBody) =
respond $ responseLBS badRequest400 [] "Invalid JSON in request body"
routingRespond (Right response) =
respond response
-- * Route mismatch
data RouteMismatch =
NotFound -- ^ the usual "not found" error
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
| InvalidBody -- ^ an even more informative "your json request body wasn't valid" error
deriving (Eq, Show)
2015-01-02 19:34:15 +01:00
-- |
2014-12-10 16:10:57 +01:00
-- @
-- > mempty = NotFound
-- >
-- > NotFound `mappend` x = x
-- > WrongMethod `mappend` InvalidBody = InvalidBody
-- > WrongMethod `mappend` _ = WrongMethod
-- > InvalidBody `mappend` _ = InvalidBody
-- @
instance Monoid RouteMismatch where
mempty = NotFound
NotFound `mappend` x = x
WrongMethod `mappend` InvalidBody = InvalidBody
WrongMethod `mappend` _ = WrongMethod
InvalidBody `mappend` _ = InvalidBody
-- | A wrapper around @'Either' 'RouteMismatch' a@.
newtype RouteResult a =
RR { routeResult :: Either RouteMismatch a }
deriving (Eq, Show)
failWith :: RouteMismatch -> RouteResult a
failWith = RR . Left
succeedWith :: a -> RouteResult a
succeedWith = RR . Right
isMismatch :: RouteResult a -> Bool
isMismatch (RR (Left _)) = True
isMismatch _ = False
-- | Like `null . pathInfo`, but works with redundant trailing slashes.
pathIsEmpty :: Request -> Bool
2014-12-28 23:07:14 +01:00
pathIsEmpty = f . processedPathInfo
where
f [] = True
f [""] = True
f _ = False
2014-12-10 16:10:57 +01:00
-- | If we get a `Right`, it has precedence over everything else.
--
-- This in particular means that if we could get several 'Right's,
-- only the first we encounter would be taken into account.
instance Monoid (RouteResult a) where
mempty = RR $ Left mempty
RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
RR (Left _) `mappend` RR (Right y) = RR $ Right y
r `mappend` _ = r
type RoutingApplication =
Request -- ^ the request, the field 'pathInfo' may be modified by url routing
-> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
2014-12-28 23:07:14 +01:00
splitMatrixParameters :: Text -> (Text, Text)
splitMatrixParameters = T.break (== ';')
parsePathInfo :: Request -> [Text]
parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo
where mergePairs = concat . unfoldr pairToList
pairToList [] = Nothing
pairToList ((a, b):xs) = Just ([a, b], xs)
-- | Returns a processed pathInfo from the request.
--
-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be
-- processed, so routing works as intended. Therefor this function should be used to access
-- the pathInfo for routing purposes.
processedPathInfo :: Request -> [Text]
processedPathInfo r =
case pinfo of
(x:xs) | T.head x == ';' -> xs
_ -> pinfo
where pinfo = parsePathInfo r
2014-12-10 16:10:57 +01:00
class HasServer layout where
type Server layout :: *
route :: Proxy layout -> Server layout -> RoutingApplication
2014-12-28 23:07:14 +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.
--
-- > type MyApi = "books" :> Get [Book] -- GET /books
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
-- >
-- > server :: Server MyApi
-- > server = listAllBooks :<|> postBook
-- > where listAllBooks = ...
-- > postBook book = ...
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type Server (a :<|> b) = Server a :<|> Server b
route Proxy (a :<|> b) request respond =
route pa a request $ \ mResponse ->
if isMismatch mResponse
then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
else respond mResponse
where pa = Proxy :: Proxy a
pb = Proxy :: Proxy b
captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
captured _ = fromText
-- | 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 'FromText' for your type.
--
-- Example:
--
-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book
-- >
-- > server :: Server MyApi
-- > server = getBook
-- > where getBook :: Text -> EitherT (Int, String) IO Book
-- > getBook isbn = ...
instance (KnownSymbol capture, FromText a, HasServer sublayout)
=> HasServer (Capture capture a :> sublayout) where
type Server (Capture capture a :> sublayout) =
a -> Server sublayout
2014-12-28 23:07:14 +01:00
route Proxy subserver request respond = case processedPathInfo request of
2014-12-10 16:10:57 +01:00
(first : rest)
-> case captured captureProxy first of
Nothing -> respond $ failWith NotFound
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
pathInfo = rest
} respond
_ -> respond $ failWith NotFound
where captureProxy = Proxy :: Proxy (Capture capture a)
2014-12-28 23:07:14 +01:00
2014-12-10 16:10:57 +01:00
-- | If you have a 'Delete' endpoint in your API,
-- the handler for this endpoint is meant to delete
-- a resource.
--
-- The code of the handler will, just like
-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and
-- 'Servant.API.Put.Put', run in @EitherT (Int, String) IO ()@.
-- The 'Int' represents the status code and the 'String' a message
-- to be returned. You can use 'Control.Monad.Trans.Either.left' to
-- painlessly error out if the conditions for a successful deletion
-- are not met.
instance HasServer Delete where
type Server Delete = EitherT (Int, String) IO ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do
2014-12-10 16:10:57 +01:00
e <- runEitherT action
respond $ succeedWith $ case e of
Right () ->
responseLBS status204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodDelete =
2014-12-10 16:10:57 +01:00
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | When implementing the handler for a 'Get' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
-- and 'Servant.API.Put.Put', the handler code runs in the
-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
-- the status code and the 'String' a message, returned in case of
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met.
--
-- If successfully returning a value, we just require that its type has
-- a 'ToJSON' instance and servant takes care of encoding it for you,
-- yielding status code 200 along the way.
instance ToJSON result => HasServer (Get result) where
type Server (Get result) = EitherT (Int, String) IO result
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
2014-12-10 16:10:57 +01:00
e <- runEitherT action
respond . succeedWith $ case e of
Right output ->
responseLBS ok200 [("Content-Type", "application/json")] (encode output)
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodGet =
2014-12-10 16:10:57 +01:00
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | 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 'FromText' instance.
--
-- Example:
--
-- > newtype Referer = Referer Text
-- > deriving (Eq, Show, FromText, ToText)
-- >
-- > -- GET /view-my-referer
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer
-- >
-- > server :: Server MyApi
-- > server = viewReferer
-- > where viewReferer :: Referer -> EitherT (Int, String) IO referer
-- > viewReferer referer = return referer
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (Header sym a :> sublayout) where
type Server (Header sym a :> sublayout) =
Maybe a -> Server sublayout
route Proxy subserver request respond = do
let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
route (Proxy :: Proxy sublayout) (subserver mheader) request respond
where str = fromString $ symbolVal (Proxy :: Proxy sym)
-- | When implementing the handler for a 'Post' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
-- and 'Servant.API.Put.Put', the handler code runs in the
-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
-- the status code and the 'String' a message, returned in case of
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met.
--
-- If successfully returning a value, we just require that its type has
-- a 'ToJSON' instance and servant takes care of encoding it for you,
-- yielding status code 201 along the way.
instance ToJSON a => HasServer (Post a) where
type Server (Post a) = EitherT (Int, String) IO a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
2014-12-10 16:10:57 +01:00
e <- runEitherT action
respond . succeedWith $ case e of
Right out ->
responseLBS status201 [("Content-Type", "application/json")] (encode out)
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPost =
2014-12-10 16:10:57 +01:00
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | When implementing the handler for a 'Put' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
-- and 'Servant.API.Post.Post', the handler code runs in the
-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
-- the status code and the 'String' a message, returned in case of
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met.
--
-- If successfully returning a value, we just require that its type has
-- a 'ToJSON' instance and servant takes care of encoding it for you,
-- yielding status code 200 along the way.
instance ToJSON a => HasServer (Put a) where
type Server (Put a) = EitherT (Int, String) IO a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
2014-12-10 16:10:57 +01:00
e <- runEitherT action
respond . succeedWith $ case e of
Right out ->
responseLBS ok200 [("Content-Type", "application/json")] (encode out)
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPut =
2014-12-10 16:10:57 +01:00
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | 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 'FromText' for your type.
--
-- Example:
--
-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]
-- > getBooksBy Nothing = ...return all books...
-- > getBooksBy (Just author) = ...return books by the given author...
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParam sym a :> sublayout) where
type Server (QueryParam sym a :> sublayout) =
Maybe a -> Server sublayout
route Proxy subserver request respond = do
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) -> fromText v -- if present, we try to convert to
-- the right type
route (Proxy :: Proxy sublayout) (subserver param) request respond
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 'FromText' for your type.
--
-- Example:
--
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]
-- > getBooksBy authors = ...return all books by these authors...
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParams sym a :> sublayout) where
type Server (QueryParams sym a :> sublayout) =
[a] -> Server sublayout
route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request
-- if sym is "foo", we look for query string parameters
-- named "foo" or "foo[]" and call fromText on the
-- corresponding values
parameters = filter looksLikeParam querytext
values = catMaybes $ map (convert . snd) parameters
route (Proxy :: Proxy sublayout) (subserver values) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing
convert (Just v) = fromText 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 [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooks
-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book]
-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (QueryFlag sym :> sublayout) where
type Server (QueryFlag sym :> sublayout) =
Bool -> Server sublayout
route Proxy subserver request respond = do
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
route (Proxy :: Proxy sublayout) (subserver param) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False
2014-12-28 23:07:14 +01:00
parseMatrixText :: B.ByteString -> QueryText
parseMatrixText = parseQueryText
-- | If you use @'MatrixParam' "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 'FromText' for your type.
--
-- Example:
--
-- > type MyApi = "books" :> MatrixParam "author" Text :> Get [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]
-- > getBooksBy Nothing = ...return all books...
-- > getBooksBy (Just author) = ...return books by the given author...
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParam sym a :> sublayout) where
type Server (MatrixParam sym a :> sublayout) =
Maybe a -> Server sublayout
route Proxy subserver request respond = case parsePathInfo request of
(first : _)
-> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
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) -> fromText v -- if present, we try to convert to
-- the right type
route (Proxy :: Proxy sublayout) (subserver param) request respond
_ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'MatrixParams' "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 'FromText' for your type.
--
-- Example:
--
-- > type MyApi = "books" :> MatrixParams "authors" Text :> Get [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]
-- > getBooksBy authors = ...return all books by these authors...
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParams sym a :> sublayout) where
type Server (MatrixParams sym a :> sublayout) =
[a] -> Server sublayout
route Proxy subserver request respond = case parsePathInfo request of
(first : _)
-> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
-- if sym is "foo", we look for matrix parameters
-- named "foo" or "foo[]" and call fromText on the
-- corresponding values
parameters = filter looksLikeParam matrixtext
values = catMaybes $ map (convert . snd) parameters
route (Proxy :: Proxy sublayout) (subserver values) request respond
_ -> route (Proxy :: Proxy sublayout) (subserver []) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing
convert (Just v) = fromText v
-- | If you use @'MatrixFlag' "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" :> MatrixFlag "published" :> Get [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooks
-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book]
-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (MatrixFlag sym :> sublayout) where
type Server (MatrixFlag sym :> sublayout) =
Bool -> Server sublayout
route Proxy subserver request respond = case parsePathInfo request of
(first : _)
-> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
param = case lookup paramname matrixtext 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
route (Proxy :: Proxy sublayout) (subserver param) request respond
_ -> route (Proxy :: Proxy sublayout) (subserver False) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False
2014-12-10 16:10:57 +01:00
-- | 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 where
type Server Raw = Application
route Proxy rawApplication request respond =
rawApplication request (respond . succeedWith)
-- | 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'.
-- 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 Book :> Post Book
-- >
-- > server :: Server MyApi
-- > server = postBook
-- > where postBook :: Book -> EitherT (Int, String) IO Book
-- > postBook book = ...insert into your db...
instance (FromJSON a, HasServer sublayout)
=> HasServer (ReqBody a :> sublayout) where
type Server (ReqBody a :> sublayout) =
a -> Server sublayout
route Proxy subserver request respond = do
mrqbody <- decode' <$> lazyRequestBody request
case mrqbody of
Nothing -> respond $ failWith InvalidBody
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
-- | 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) => HasServer (path :> sublayout) where
type Server (path :> sublayout) = Server sublayout
2014-12-28 23:07:14 +01:00
route Proxy subserver request respond = case processedPathInfo request of
2014-12-10 16:10:57 +01:00
(first : rest)
| first == cs (symbolVal proxyPath)
-> route (Proxy :: Proxy sublayout) subserver request{
pathInfo = rest
} respond
_ -> respond $ failWith NotFound
where proxyPath = Proxy :: Proxy path