460 lines
18 KiB
Haskell
460 lines
18 KiB
Haskell
|
{-# LANGUAGE DataKinds #-}
|
||
|
|
{-# LANGUAGE PolyKinds #-}
|
||
|
|
{-# LANGUAGE TypeFamilies #-}
|
||
|
|
{-# LANGUAGE TypeOperators #-}
|
||
|
|
{-# LANGUAGE FlexibleInstances #-}
|
||
|
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||
|
|
module Servant.Server.Internal where
|
||
|
|
|
||
|
|
import Control.Applicative
|
||
|
|
import Control.Monad.Trans.Either
|
||
|
|
import Data.Aeson
|
||
|
|
import Data.Maybe (catMaybes)
|
||
|
|
import Data.Monoid
|
||
|
|
import Data.Proxy
|
||
|
|
import Data.String
|
||
|
|
import Data.String.Conversions
|
||
|
|
import Data.Text (Text)
|
||
|
|
import Data.Text.Encoding (decodeUtf8)
|
||
|
|
import GHC.TypeLits
|
||
|
|
import Network.HTTP.Types hiding (Header)
|
||
|
|
import Network.Wai
|
||
|
|
import Servant.API
|
||
|
|
import Servant.Common.Text
|
||
|
|
|
||
|
|
toApplication :: RoutingApplication -> Application
|
||
|
|
toApplication ra request respond = do
|
||
|
|
ra request (routingRespond . routeResult)
|
||
|
|
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)
|
||
|
|
|
||
|
|
-- |
|
||
|
|
-- @
|
||
|
|
-- > 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
|
||
|
|
|
||
|
|
-- | 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
|
||
|
|
|
||
|
|
class HasServer layout where
|
||
|
|
type Server layout :: *
|
||
|
|
route :: Proxy layout -> Server layout -> RoutingApplication
|
||
|
|
|
||
|
|
-- * Instances
|
||
|
|
|
||
|
|
-- | A server for @a ':<|>' b@ first tries to match the request again the route
|
||
|
|
-- 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
|
||
|
|
|
||
|
|
route Proxy subserver request respond = case pathInfo request of
|
||
|
|
(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)
|
||
|
|
|
||
|
|
-- | 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
|
||
|
|
| null (pathInfo request) && requestMethod request == methodDelete = do
|
||
|
|
e <- runEitherT action
|
||
|
|
respond $ succeedWith $ case e of
|
||
|
|
Right () ->
|
||
|
|
responseLBS status204 [] ""
|
||
|
|
Left (status, message) ->
|
||
|
|
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||
|
|
| null (pathInfo request) && requestMethod request /= methodDelete =
|
||
|
|
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
|
||
|
|
| null (pathInfo request) && requestMethod request == methodGet = do
|
||
|
|
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)
|
||
|
|
| null (pathInfo request) && requestMethod request /= methodGet =
|
||
|
|
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
|
||
|
|
| null (pathInfo request) && requestMethod request == methodPost = do
|
||
|
|
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)
|
||
|
|
| null (pathInfo request) && requestMethod request /= methodPost =
|
||
|
|
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
|
||
|
|
| null (pathInfo request) && requestMethod request == methodPut = do
|
||
|
|
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)
|
||
|
|
| null (pathInfo request) && requestMethod request /= methodPut =
|
||
|
|
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
|
||
|
|
|
||
|
|
-- | 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
|
||
|
|
route Proxy subserver request respond = case pathInfo request of
|
||
|
|
(first : rest)
|
||
|
|
| first == cs (symbolVal proxyPath)
|
||
|
|
-> route (Proxy :: Proxy sublayout) subserver request{
|
||
|
|
pathInfo = rest
|
||
|
|
} respond
|
||
|
|
_ -> respond $ failWith NotFound
|
||
|
|
|
||
|
|
where proxyPath = Proxy :: Proxy path
|