eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #111 from haskell-servant/improved-routing

Browse source 
Improved routing
This commit is contained in:
Alp Mestanogullari 2015-06-04 12:57:45 +01:00
commit d654ccaf3d
8 changed files with 475 additions and 424 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
servant-examples/auth-combinator/auth-combinator.hs
View file

@ -28,14 +28,15 @@ data AuthProtected
instance HasServer rest => HasServer (AuthProtected :> rest) where instance HasServer rest => HasServer (AuthProtected :> rest) where
type ServerT (AuthProtected :> rest) m = ServerT rest m type ServerT (AuthProtected :> rest) m = ServerT rest m
route Proxy a request respond = route Proxy a = WithRequest $ \ request ->
case lookup "Cookie" (requestHeaders request) of route (Proxy :: Proxy rest) $ do
Nothing -> respond . succeedWith $ responseLBS status401 [] "Missing auth header." case lookup "Cookie" (requestHeaders request) of
Just v -> do Nothing -> return $ failWith $ HttpError status401 (Just "Missing auth header.")
authGranted <- isGoodCookie v Just v -> do
if authGranted authGranted <- isGoodCookie v
then route (Proxy :: Proxy rest) a request respond if authGranted
else respond . succeedWith $ responseLBS status403 [] "Invalid cookie." then a
else return $ failWith $ HttpError status403 (Just "Invalid cookie.")
type PrivateAPI = Get '[JSON] [PrivateData] type PrivateAPI = Get '[JSON] [PrivateData]

6
servant-server/servant-server.cabal
View file

@ -35,14 +35,18 @@ library
Servant Servant
Servant.Server Servant.Server
Servant.Server.Internal Servant.Server.Internal
Servant.Server.Internal.ServantErr
Servant.Server.Internal.Enter Servant.Server.Internal.Enter
Servant.Server.Internal.PathInfo
Servant.Server.Internal.Router
Servant.Server.Internal.RoutingApplication
Servant.Server.Internal.ServantErr
Servant.Utils.StaticFiles Servant.Utils.StaticFiles
build-depends: build-depends:
base >= 4.7 && < 5 base >= 4.7 && < 5
, aeson >= 0.7 && < 0.10 , aeson >= 0.7 && < 0.10
, attoparsec >= 0.12 && < 0.14 , attoparsec >= 0.12 && < 0.14
, bytestring >= 0.10 && < 0.11 , bytestring >= 0.10 && < 0.11
, containers >= 0.5 && < 0.6
, either >= 4.3 && < 4.5 , either >= 4.3 && < 4.5
, http-types >= 0.8 && < 0.9 , http-types >= 0.8 && < 0.9
, network-uri >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7

3
servant-server/src/Servant/Server.hs
View file

@ -81,7 +81,6 @@ import Data.Proxy (Proxy)
import Network.Wai (Application) import Network.Wai (Application)
import Servant.Server.Internal import Servant.Server.Internal
import Servant.Server.Internal.Enter import Servant.Server.Internal.Enter
import Servant.Server.Internal.ServantErr
-- * Implementing Servers -- * Implementing Servers
@ -108,7 +107,7 @@ import Servant.Server.Internal.ServantErr
-- > main = Network.Wai.Handler.Warp.run 8080 app -- > main = Network.Wai.Handler.Warp.run 8080 app
-- --
serve :: HasServer layout => Proxy layout -> Server layout -> Application serve :: HasServer layout => Proxy layout -> Server layout -> Application
serve p server = toApplication (route p server) serve p server = toApplication (runRouter (route p (return (RR (Right server)))))
-- Documentation -- Documentation

563
servant-server/src/Servant/Server/Internal.hs
View file

@ -2,6 +2,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -11,17 +12,20 @@
{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverlappingInstances #-}
#endif #endif
module Servant.Server.Internal where module Servant.Server.Internal
( module Servant.Server.Internal
, module Servant.Server.Internal.PathInfo
, module Servant.Server.Internal.Router
, module Servant.Server.Internal.RoutingApplication
, module Servant.Server.Internal.ServantErr
) where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Data.Monoid (Monoid, mappend, mempty)
#endif #endif
import Control.Monad.Trans.Either (EitherT, runEitherT) import Control.Monad.Trans.Either (EitherT)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.Map as M
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.List (unfoldr)
import Data.Maybe (catMaybes, fromMaybe) import Data.Maybe (catMaybes, fromMaybe)
import Data.String (fromString) import Data.String (fromString)
import Data.String.Conversions (cs, (<>)) import Data.String.Conversions (cs, (<>))
@ -31,12 +35,9 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Typeable import Data.Typeable
import GHC.TypeLits (KnownSymbol, symbolVal) import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Wai (Application, Request, Response, import Network.Wai (Application, lazyRequestBody,
ResponseReceived, lazyRequestBody, rawQueryString, requestHeaders,
pathInfo, rawQueryString, requestMethod, responseLBS)
requestBody, requestHeaders,
requestMethod, responseLBS,
strictRequestBody)
import Servant.API ((:<|>) (..), (:>), Capture, import Servant.API ((:<|>) (..), (:>), Capture,
Delete, Get, Header, Delete, Get, Header,
MatrixFlag, MatrixParam, MatrixParams, MatrixFlag, MatrixParam, MatrixParams,
@ -50,136 +51,15 @@ import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
getHeaders) getHeaders)
import Servant.Common.Text (FromText, fromText) import Servant.Common.Text (FromText, fromText)
import Servant.Server.Internal.PathInfo
import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr import Servant.Server.Internal.ServantErr
data ReqBodyState = Uncalled
| Called !B.ByteString
| Done !B.ByteString
toApplication :: RoutingApplication -> Application
toApplication ra request respond = do
reqBodyRef <- newIORef Uncalled
-- 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
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
ra request{ requestBody = memoReqBody } (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 err)) =
respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
routingRespond (Left UnsupportedMediaType) =
respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
routingRespond (Left (HttpError status body)) =
respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
routingRespond (Right response) =
respond response
-- Note that the ordering of the constructors has great significance! It
-- determines the Ord instance and, consequently, the monoid instance.
-- * Route mismatch
data RouteMismatch =
NotFound -- ^ the usual "not found" error
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
| UnsupportedMediaType -- ^ request body has unsupported media type
| InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
| HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
deriving (Eq, Ord, Show)
instance Monoid RouteMismatch where
mempty = NotFound
-- The following isn't great, since it picks @InvalidBody@ based on
-- alphabetical ordering, but any choice would be arbitrary.
--
-- "As one judge said to the other, 'Be just and if you can't be just, be
-- arbitrary'" -- William Burroughs
mappend = max
-- | 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
pathIsEmpty = f . processedPathInfo
where
f [] = True
f [""] = True
f _ = 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
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
class HasServer layout where class HasServer layout where
type ServerT layout (m :: * -> *) :: * type ServerT layout (m :: * -> *) :: *
route :: Proxy layout -> Server layout -> RoutingApplication route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router
type Server layout = ServerT layout (EitherT ServantErr IO) type Server layout = ServerT layout (EitherT ServantErr IO)
@ -200,12 +80,8 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
route Proxy (a :<|> b) request respond = route Proxy server = choice (route pa (extractL <$> server))
route pa a request $ \mResponse -> (route pb (extractR <$> server))
if isMismatch mResponse
then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
else respond mResponse
where pa = Proxy :: Proxy a where pa = Proxy :: Proxy a
pb = Proxy :: Proxy b pb = Proxy :: Proxy b
@ -235,18 +111,65 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
type ServerT (Capture capture a :> sublayout) m = type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m a -> ServerT sublayout m
route Proxy subserver request respond = case processedPathInfo request of route Proxy subserver =
(first : rest) DynamicRouter $ \ first ->
-> case captured captureProxy first of route (Proxy :: Proxy sublayout)
Nothing -> respond $ failWith NotFound (case captured captureProxy first of
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{ Nothing -> return $ failWith NotFound
pathInfo = rest Just v -> feedTo subserver v)
} respond
_ -> respond $ failWith NotFound
where captureProxy = Proxy :: Proxy (Capture capture a) where captureProxy = Proxy :: Proxy (Capture capture a)
methodRouter :: (AllCTRender ctypes a)
=> Method -> Proxy ctypes -> Status
-> IO (RouteResult (EitherT ServantErr IO a))
-> Router
methodRouter method proxy status action = LeafRouter route'
where
route' request respond
| pathIsEmpty request && requestMethod request == method = do
runAction action respond $ \ output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH proxy (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status [ ("Content-Type" , cs contentT)] body
| pathIsEmpty request && requestMethod request /= method =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
=> Method -> Proxy ctypes -> Status
-> IO (RouteResult (EitherT ServantErr IO (Headers h v)))
-> Router
methodRouterHeaders method proxy status action = LeafRouter route'
where
route' request respond
| pathIsEmpty request && requestMethod request == method = do
runAction action respond $ \ output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH proxy (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status ( ("Content-Type" , cs contentT) : headers) body
| pathIsEmpty request && requestMethod request /= method =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
methodRouterEmpty :: Method
-> IO (RouteResult (EitherT ServantErr IO ()))
-> Router
methodRouterEmpty method action = LeafRouter route'
where
route' request respond
| pathIsEmpty request && requestMethod request == method = do
runAction action respond $ \ () ->
succeedWith $ responseLBS noContent204 [] ""
| pathIsEmpty request && requestMethod request /= method =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | If you have a 'Delete' endpoint in your API, -- | If you have a 'Delete' endpoint in your API,
-- the handler for this endpoint is meant to delete -- the handler for this endpoint is meant to delete
-- a resource. -- a resource.
@ -267,20 +190,7 @@ instance
type ServerT (Delete ctypes a) m = m a type ServerT (Delete ctypes a) m = m a
route Proxy action request respond route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -290,15 +200,7 @@ instance
type ServerT (Delete ctypes ()) m = m () type ServerT (Delete ctypes ()) m = m ()
route Proxy action request respond route Proxy = methodRouterEmpty methodDelete
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers -- Add response headers
instance instance
@ -310,21 +212,7 @@ instance
type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v) type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | When implementing the handler for a 'Get' endpoint, -- | When implementing the handler for a 'Get' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
@ -347,20 +235,7 @@ instance
type ServerT (Get ctypes a) m = m a type ServerT (Get ctypes a) m = m a
route Proxy action request respond route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS ok200 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- '()' ==> 204 No Content -- '()' ==> 204 No Content
instance instance
@ -371,15 +246,7 @@ instance
type ServerT (Get ctypes ()) m = m () type ServerT (Get ctypes ()) m = m ()
route Proxy action request respond route Proxy = methodRouterEmpty methodGet
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers -- Add response headers
instance instance
@ -391,21 +258,7 @@ instance
type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | If you use 'Header' in one of the endpoints for your API, -- | If you use 'Header' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
@ -433,11 +286,10 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
type ServerT (Header sym a :> sublayout) m = type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver = WithRequest $ \ request ->
let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request) let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
route (Proxy :: Proxy sublayout) (subserver mheader) request respond in route (Proxy :: Proxy sublayout) (feedTo subserver mheader)
where str = fromString $ symbolVal (Proxy :: Proxy sym)
where str = fromString $ symbolVal (Proxy :: Proxy sym)
-- | When implementing the handler for a 'Post' endpoint, -- | When implementing the handler for a 'Post' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
@ -461,20 +313,7 @@ instance
type ServerT (Post ctypes a) m = m a type ServerT (Post ctypes a) m = m a
route Proxy action request respond route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status201 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -484,15 +323,7 @@ instance
type ServerT (Post ctypes ()) m = m () type ServerT (Post ctypes ()) m = m ()
route Proxy action request respond route Proxy = methodRouterEmpty methodPost
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers -- Add response headers
instance instance
@ -504,21 +335,7 @@ instance
type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | When implementing the handler for a 'Put' endpoint, -- | When implementing the handler for a 'Put' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
@ -541,20 +358,7 @@ instance
type ServerT (Put ctypes a) m = m a type ServerT (Put ctypes a) m = m a
route Proxy action request respond route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -564,15 +368,7 @@ instance
type ServerT (Put ctypes ()) m = m () type ServerT (Put ctypes ()) m = m ()
route Proxy action request respond route Proxy = methodRouterEmpty methodPut
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers -- Add response headers
instance instance
@ -584,21 +380,7 @@ instance
type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | When implementing the handler for a 'Patch' endpoint, -- | When implementing the handler for a 'Patch' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
@ -619,20 +401,7 @@ instance
type ServerT (Patch ctypes a) m = m a type ServerT (Patch ctypes a) m = m a
route Proxy action request respond route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -642,15 +411,7 @@ instance
type ServerT (Patch ctypes ()) m = m () type ServerT (Patch ctypes ()) m = m ()
route Proxy action request respond route Proxy = methodRouterEmpty methodPatch
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers -- Add response headers
instance instance
@ -662,21 +423,7 @@ instance
type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond $ case e of
Right outpatch -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders outpatch
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- | 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 -- this automatically requires your server-side handler to be a function
@ -705,7 +452,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
type ServerT (QueryParam sym a :> sublayout) m = type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
param = param =
case lookup paramname querytext of case lookup paramname querytext of
@ -713,9 +460,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
Just Nothing -> Nothing -- param present with no value -> Nothing Just Nothing -> Nothing -- param present with no value -> Nothing
Just (Just v) -> fromText v -- if present, we try to convert to Just (Just v) -> fromText v -- if present, we try to convert to
-- the right type -- the right type
in route (Proxy :: Proxy sublayout) (feedTo subserver param)
route (Proxy :: Proxy sublayout) (subserver param) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
@ -743,16 +488,14 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
type ServerT (QueryParams sym a :> sublayout) m = type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m [a] -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
-- if sym is "foo", we look for query string parameters -- if sym is "foo", we look for query string parameters
-- named "foo" or "foo[]" and call fromText on the -- named "foo" or "foo[]" and call fromText on the
-- corresponding values -- corresponding values
parameters = filter looksLikeParam querytext parameters = filter looksLikeParam querytext
values = catMaybes $ map (convert . snd) parameters values = catMaybes $ map (convert . snd) parameters
in route (Proxy :: Proxy sublayout) (feedTo subserver values)
route (Proxy :: Proxy sublayout) (subserver values) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing convert Nothing = Nothing
@ -776,15 +519,13 @@ instance (KnownSymbol sym, HasServer sublayout)
type ServerT (QueryFlag sym :> sublayout) m = type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m Bool -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
param = case lookup paramname querytext of param = case lookup paramname querytext of
Just Nothing -> True -- param is there, with no value Just Nothing -> True -- param is there, with no value
Just (Just v) -> examine v -- param with a value Just (Just v) -> examine v -- param with a value
Nothing -> False -- param not in the query string Nothing -> False -- param not in the query string
in route (Proxy :: Proxy sublayout) (feedTo subserver param)
route (Proxy :: Proxy sublayout) (subserver param) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False | otherwise = False
@ -819,16 +560,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
type ServerT (MatrixParam sym a :> sublayout) m = type ServerT (MatrixParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver = WithRequest $ \ request ->
(first : _) case parsePathInfo request of
-> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first (first : _)
param = case lookup paramname querytext of -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
Nothing -> Nothing -- param absent from the query string param = case lookup paramname querytext of
Just Nothing -> Nothing -- param present with no value -> Nothing Nothing -> Nothing -- param absent from the query string
Just (Just v) -> fromText v -- if present, we try to convert to Just Nothing -> Nothing -- param present with no value -> Nothing
-- the right type Just (Just v) -> fromText v -- if present, we try to convert to
route (Proxy :: Proxy sublayout) (subserver param) request respond -- the right type
_ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond route (Proxy :: Proxy sublayout) (feedTo subserver param)
_ -> route (Proxy :: Proxy sublayout) (feedTo subserver Nothing)
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
@ -857,16 +599,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
type ServerT (MatrixParams sym a :> sublayout) m = type ServerT (MatrixParams sym a :> sublayout) m =
[a] -> ServerT sublayout m [a] -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver = WithRequest $ \ request ->
(first : _) case parsePathInfo request of
-> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first (first : _)
-- if sym is "foo", we look for matrix parameters -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
-- named "foo" or "foo[]" and call fromText on the -- if sym is "foo", we look for matrix parameters
-- corresponding values -- named "foo" or "foo[]" and call fromText on the
parameters = filter looksLikeParam matrixtext -- corresponding values
values = catMaybes $ map (convert . snd) parameters parameters = filter looksLikeParam matrixtext
route (Proxy :: Proxy sublayout) (subserver values) request respond values = catMaybes $ map (convert . snd) parameters
_ -> route (Proxy :: Proxy sublayout) (subserver []) request respond route (Proxy :: Proxy sublayout) (feedTo subserver values)
_ -> route (Proxy :: Proxy sublayout) (feedTo subserver [])
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
@ -891,17 +634,18 @@ instance (KnownSymbol sym, HasServer sublayout)
type ServerT (MatrixFlag sym :> sublayout) m = type ServerT (MatrixFlag sym :> sublayout) m =
Bool -> ServerT sublayout m Bool -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver = WithRequest $ \ request ->
(first : _) case parsePathInfo request of
-> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first (first : _)
param = case lookup paramname matrixtext of -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
Just Nothing -> True -- param is there, with no value param = case lookup paramname matrixtext of
Just (Just v) -> examine v -- param with a value Just Nothing -> True -- param is there, with no value
Nothing -> False -- param not in the query string 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) (feedTo subserver param)
_ -> route (Proxy :: Proxy sublayout) (subserver False) request respond _ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True examine v | v == "true" || v == "1" || v == "" = True
@ -919,8 +663,11 @@ instance HasServer Raw where
type ServerT Raw m = Application type ServerT Raw m = Application
route Proxy rawApplication request respond = route Proxy rawApplication = LeafRouter $ \ request respond -> do
rawApplication request (respond . succeedWith) r <- rawApplication
case r of
RR (Left err) -> respond $ failWith err
RR (Right app) -> app request (respond . succeedWith)
-- | If you use 'ReqBody' in one of the endpoints for your API, -- | If you use 'ReqBody' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
@ -948,19 +695,20 @@ instance ( AllCTUnrender list a, HasServer sublayout
type ServerT (ReqBody list a :> sublayout) m = type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m a -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver = WithRequest $ \ request ->
-- See HTTP RFC 2616, section 7.2.1 route (Proxy :: Proxy sublayout) $ do
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 -- See HTTP RFC 2616, section 7.2.1
-- See also "W3C Internet Media Type registration, consistency of use" -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
-- http://www.w3.org/2001/tag/2002/0129-mime -- See also "W3C Internet Media Type registration, consistency of use"
let contentTypeH = fromMaybe "application/octet-stream" -- http://www.w3.org/2001/tag/2002/0129-mime
$ lookup hContentType $ requestHeaders request let contentTypeH = fromMaybe "application/octet-stream"
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) $ lookup hContentType $ requestHeaders request
<$> lazyRequestBody request mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
case mrqbody of <$> lazyRequestBody request
Nothing -> respond . failWith $ UnsupportedMediaType case mrqbody of
Just (Left e) -> respond . failWith $ InvalidBody e Nothing -> return $ failWith $ UnsupportedMediaType
Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond Just (Left e) -> return $ failWith $ InvalidBody e
Just (Right v) -> feedTo subserver v
-- | Make sure the incoming request starts with @"/path"@, strip it and -- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @sublayout@. -- pass the rest of the request path to @sublayout@.
@ -968,14 +716,9 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout
type ServerT (path :> sublayout) m = ServerT sublayout m type ServerT (path :> sublayout) m = ServerT sublayout m
route Proxy subserver request respond = case processedPathInfo request of route Proxy subserver = StaticRouter $
(first : rest) M.singleton (cs (symbolVal proxyPath))
| first == cs (symbolVal proxyPath) (route (Proxy :: Proxy sublayout) subserver)
-> route (Proxy :: Proxy sublayout) subserver request{
pathInfo = rest
} respond
_ -> respond $ failWith NotFound
where proxyPath = Proxy :: Proxy path where proxyPath = Proxy :: Proxy path
ct_wildcard :: B.ByteString ct_wildcard :: B.ByteString

38
servant-server/src/Servant/Server/Internal/PathInfo.hs Normal file
View file

@ -0,0 +1,38 @@
{-# LANGUAGE OverloadedStrings #-}
module Servant.Server.Internal.PathInfo where
import Data.List (unfoldr)
import Data.Text (Text)
import qualified Data.Text as T
import Network.Wai (Request, pathInfo)
-- | Like `null . pathInfo`, but works with redundant trailing slashes.
pathIsEmpty :: Request -> Bool
pathIsEmpty = f . processedPathInfo
where
f [] = True
f [""] = True
f _ = False
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

72
servant-server/src/Servant/Server/Internal/Router.hs Normal file
View file

@ -0,0 +1,72 @@
module Servant.Server.Internal.Router where
import Data.Map (Map)
import qualified Data.Map as M
import Data.Monoid ((<>))
import Data.Text (Text)
import Network.Wai (Request, pathInfo)
import Servant.Server.Internal.PathInfo
import Servant.Server.Internal.RoutingApplication
-- | Internal representation of a router.
data Router =
WithRequest (Request -> Router)
-- ^ current request is passed to the router
| StaticRouter (Map Text Router)
-- ^ first path component used for lookup and removed afterwards
| DynamicRouter (Text -> Router)
-- ^ first path component used for lookup and removed afterwards
| LeafRouter RoutingApplication
-- ^ to be used for routes that match an empty path
| Choice Router Router
-- ^ left-biased choice between two routers
-- | Smart constructor for the choice between routers.
-- We currently optimize the following cases:
--
-- * Two static routers can be joined by joining their maps.
-- * Two dynamic routers can be joined by joining their codomains.
-- * Two 'WithRequest' routers can be joined by passing them
-- the same request and joining their codomains.
-- * A 'WithRequest' router can be joined with anything else by
-- passing the same request to both but ignoring it in the
-- component that does not need it.
--
choice :: Router -> Router -> Router
choice (StaticRouter table1) (StaticRouter table2) =
StaticRouter (M.unionWith choice table1 table2)
choice (DynamicRouter fun1) (DynamicRouter fun2) =
DynamicRouter (\ first -> choice (fun1 first) (fun2 first))
choice (WithRequest router1) (WithRequest router2) =
WithRequest (\ request -> choice (router1 request) (router2 request))
choice (WithRequest router1) router2 =
WithRequest (\ request -> choice (router1 request) router2)
choice router1 (WithRequest router2) =
WithRequest (\ request -> choice router1 (router2 request))
choice router1 router2 = Choice router1 router2
-- | Interpret a router as an application.
runRouter :: Router -> RoutingApplication
runRouter (WithRequest router) request respond =
runRouter (router request) request respond
runRouter (StaticRouter table) request respond =
case processedPathInfo request of
first : rest
| Just router <- M.lookup first table
-> let request' = request { pathInfo = rest }
in runRouter router request' respond
_ -> respond $ failWith NotFound
runRouter (DynamicRouter fun) request respond =
case processedPathInfo request of
first : rest
-> let request' = request { pathInfo = rest }
in runRouter (fun first) request' respond
_ -> respond $ failWith NotFound
runRouter (LeafRouter app) request respond = app request respond
runRouter (Choice r1 r2) request respond =
runRouter r1 request $ \ mResponse1 ->
if isMismatch mResponse1
then runRouter r2 request $ \ mResponse2 ->
respond (mResponse1 <> mResponse2)
else respond mResponse1

144
servant-server/src/Servant/Server/Internal/RoutingApplication.hs Normal file
View file

@ -0,0 +1,144 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Server.Internal.RoutingApplication where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative, (<$>))
import Data.Monoid (Monoid, mappend, mempty)
#endif
import Control.Monad.Trans.Either (EitherT, runEitherT)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.String (fromString)
import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Wai (Application, Request, Response,
ResponseReceived,
requestBody,
responseLBS,
strictRequestBody)
import Servant.API ((:<|>) (..))
import Servant.Server.Internal.ServantErr
type RoutingApplication =
Request -- ^ the request, the field 'pathInfo' may be modified by url routing
-> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
-- | A wrapper around @'Either' 'RouteMismatch' a@.
newtype RouteResult a =
RR { routeResult :: Either RouteMismatch a }
deriving (Eq, Show, Functor, Applicative)
-- | 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
-- Note that the ordering of the constructors has great significance! It
-- determines the Ord instance and, consequently, the monoid instance.
data RouteMismatch =
NotFound -- ^ the usual "not found" error
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
| UnsupportedMediaType -- ^ request body has unsupported media type
| InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
| HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
deriving (Eq, Ord, Show)
instance Monoid RouteMismatch where
mempty = NotFound
-- The following isn't great, since it picks @InvalidBody@ based on
-- alphabetical ordering, but any choice would be arbitrary.
--
-- "As one judge said to the other, 'Be just and if you can't be just, be
-- arbitrary'" -- William Burroughs
mappend = max
data ReqBodyState = Uncalled
| Called !B.ByteString
| Done !B.ByteString
toApplication :: RoutingApplication -> Application
toApplication ra request respond = do
reqBodyRef <- newIORef Uncalled
-- 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
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
ra request{ requestBody = memoReqBody } (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 err)) =
respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
routingRespond (Left UnsupportedMediaType) =
respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
routingRespond (Left (HttpError status body)) =
respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
routingRespond (Right response) =
respond response
runAction :: IO (RouteResult (EitherT ServantErr IO a))
-> (RouteResult Response -> IO r)
-> (a -> RouteResult Response)
-> IO r
runAction action respond k = do
r <- action
go r
where
go (RR (Right a)) = do
e <- runEitherT a
respond $ case e of
Right x -> k x
Left err -> succeedWith $ responseServantErr err
go (RR (Left err)) = respond $ failWith err
feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)
feedTo f x = (($ x) <$>) <$> f
extractL :: RouteResult (a :<|> b) -> RouteResult a
extractL (RR (Right (a :<|> _))) = RR (Right a)
extractL (RR (Left err)) = RR (Left err)
extractR :: RouteResult (a :<|> b) -> RouteResult b
extractR (RR (Right (_ :<|> b))) = RR (Right b)
extractR (RR (Left err)) = RR (Left err)
failWith :: RouteMismatch -> RouteResult a
failWith = RR . Left
succeedWith :: a -> RouteResult a
succeedWith = RR . Right
isMismatch :: RouteResult a -> Bool
isMismatch (RR (Left _)) = True
isMismatch _ = False

52
servant-server/test/Servant/ServerSpec.hs
View file

@ -42,7 +42,8 @@ import Servant.API ((:<|>) (..), (:>),
Post, Put, QueryFlag, QueryParam, Post, Put, QueryFlag, QueryParam,
QueryParams, Raw, ReqBody) QueryParams, Raw, ReqBody)
import Servant.Server (Server, serve, ServantErr(..), err404) import Servant.Server (Server, serve, ServantErr(..), err404)
import Servant.Server.Internal (RouteMismatch (..)) import Servant.Server.Internal.RoutingApplication
(RouteMismatch (..))
-- * test data types -- * test data types
@ -89,6 +90,7 @@ spec = do
headerSpec headerSpec
rawSpec rawSpec
unionSpec unionSpec
prioErrorsSpec
errorsSpec errorsSpec
responseHeadersSpec responseHeadersSpec
@ -572,6 +574,54 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415 `shouldRespondWith` 415
type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer
prioErrorsApi :: Proxy PrioErrorsApi
prioErrorsApi = Proxy
-- | Test the relative priority of error responses from the server.
--
-- In particular, we check whether matching continues even if a 'ReqBody'
-- or similar construct is encountered early in a path. We don't want to
-- see a complaint about the request body unless the path actually matches.
--
prioErrorsSpec :: Spec
prioErrorsSpec = describe "PrioErrors" $ do
let server = return . age
with (return $ serve prioErrorsApi server) $ do
let check (mdescr, method) path (cdescr, ctype, body) resp =
it fulldescr $
Test.Hspec.Wai.request method path [(hContentType, ctype)] body
`shouldRespondWith` resp
where
fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr
++ " " ++ cs path ++ " (" ++ cdescr ++ ")"
get' = ("GET", methodGet)
put' = ("PUT", methodPut)
txt = ("text" , "text/plain;charset=utf8" , "42" )
ijson = ("invalid json", "application/json;charset=utf8", "invalid" )
vjson = ("valid json" , "application/json;charset=utf8", encode alice)
check get' "/" txt 404
check get' "/bar" txt 404
check get' "/foo" txt 415
check put' "/" txt 404
check put' "/bar" txt 404
check put' "/foo" txt 405
check get' "/" ijson 404
check get' "/bar" ijson 404
check get' "/foo" ijson 400
check put' "/" ijson 404
check put' "/bar" ijson 404
check put' "/foo" ijson 405
check get' "/" vjson 404
check get' "/bar" vjson 404
check get' "/foo" vjson 200
check put' "/" vjson 404
check put' "/bar" vjson 404
check put' "/foo" vjson 405
-- | Test server error functionality. -- | Test server error functionality.
errorsSpec :: Spec errorsSpec :: Spec