servant-server 0.6.1 → 0.7
raw patch · 16 files changed
+585/−377 lines, 16 filesdep ~base-compatdep ~servantdep ~transformers
Dependency ranges changed: base-compat, servant, transformers
Files
- CHANGELOG.md +24/−0
- example/greet.hs +1/−1
- servant-server.cabal +3/−3
- src/Servant.hs +2/−0
- src/Servant/Server.hs +67/−4
- src/Servant/Server/Experimental/Auth.hs +14/−12
- src/Servant/Server/Internal.hs +79/−79
- src/Servant/Server/Internal/BasicAuth.hs +6/−5
- src/Servant/Server/Internal/Router.hs +168/−61
- src/Servant/Server/Internal/RoutingApplication.hs +136/−127
- src/Servant/Server/Internal/ServantErr.hs +33/−30
- test/Servant/Server/ErrorSpec.hs +24/−7
- test/Servant/Server/Internal/EnterSpec.hs +1/−1
- test/Servant/Server/UsingContextSpec.hs +1/−1
- test/Servant/Server/UsingContextSpec/TestCombinators.hs +1/−2
- test/Servant/ServerSpec.hs +25/−44
CHANGELOG.md view
@@ -1,3 +1,27 @@+0.7+---++* The `Router` type has been changed. Static router tables should now+ be properly shared between requests, drastically increasing the+ number of situations where servers will be able to route requests+ efficiently. Functions `layout` and `layoutWithContext` have been+ added to visualize the router layout for debugging purposes. Test+ cases for expected router layouts have been added.+* If an endpoint is discovered to have a non-matching "accept header",+ this is now a recoverable rather than a fatal failure, allowing+ different endpoints for the same route, but with different content+ types to be specified modularly.+* Export `throwError` from module `Servant`+* Add `Handler` type synonym++0.6.1+-----++* If servers use the `BasicAuth` combinator and receive requests with missing or+ invalid credentials, the resulting error responses (401 and 403) could be+ overwritten by subsequent alternative routes. Now `BasicAuth` uses `FailFatal`+ and the error responses can't be overwritten anymore.+ 0.6 ---
example/greet.hs view
@@ -44,7 +44,7 @@ -- There's one handler per endpoint, which, just like in the type -- that represents the API, are glued together using :<|>. ----- Each handler runs in the 'ExceptT ServantErr IO' monad.+-- Each handler runs in the 'Handler' monad. server :: Server TestApi server = helloH :<|> postGreetH :<|> deleteGreetH
servant-server.cabal view
@@ -1,5 +1,5 @@ name: servant-server-version: 0.6.1+version: 0.7 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them@@ -60,13 +60,13 @@ , mmorph >= 1 , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4- , servant == 0.6.*+ , servant == 0.7.* , split >= 0.2 && < 0.3 , string-conversions >= 0.3 && < 0.5 , system-filepath >= 0.4 && < 0.5 , filepath >= 1 , text >= 1.2 && < 1.3- , transformers >= 0.3 && < 0.5+ , transformers >= 0.3 && < 0.6 , transformers-compat>= 0.4 , wai >= 3.0 && < 3.3 , wai-app-static >= 3.0 && < 3.2
src/Servant.hs view
@@ -10,8 +10,10 @@ module Servant.Utils.StaticFiles, -- | Useful re-exports Proxy(..),+ throwError ) where +import Control.Monad.Error.Class (throwError) import Data.Proxy import Servant.API import Servant.Server
src/Servant/Server.hs view
@@ -17,7 +17,12 @@ , -- * Handlers for all standard combinators HasServer(..) , Server+ , Handler + -- * Debugging the server layout+ , layout+ , layoutWithContext+ -- * Enter -- $enterDoc @@ -93,6 +98,7 @@ ) where import Data.Proxy (Proxy)+import Data.Text (Text) import Network.Wai (Application) import Servant.Server.Internal import Servant.Server.Internal.Enter@@ -126,11 +132,68 @@ serveWithContext :: (HasServer layout context) => Proxy layout -> Context context -> Server layout -> Application-serveWithContext p context server = toApplication (runRouter (route p context d))- where- d = Delayed r r r r (\ _ _ _ -> Route server)- r = return (Route ())+serveWithContext p context server =+ toApplication (runRouter (route p context (emptyDelayed (Route server)))) +-- | The function 'layout' produces a textual description of the internal+-- router layout for debugging purposes. Note that the router layout is+-- determined just by the API, not by the handlers.+--+-- Example:+--+-- For the following API+--+-- > type API =+-- > "a" :> "d" :> Get '[JSON] ()+-- > :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool+-- > :<|> "c" :> Put '[JSON] Bool+-- > :<|> "a" :> "e" :> Get '[JSON] Int+-- > :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool+-- > :<|> Raw+--+-- we get the following output:+--+-- > /+-- > ├─ a/+-- > │ ├─ d/+-- > │ │ └─•+-- > │ └─ e/+-- > │ └─•+-- > ├─ b/+-- > │ └─ <capture>/+-- > │ ├─•+-- > │ ┆+-- > │ └─•+-- > ├─ c/+-- > │ └─•+-- > ┆+-- > └─ <raw>+--+-- Explanation of symbols:+--+-- [@├@] Normal lines reflect static branching via a table.+--+-- [@a/@] Nodes reflect static path components.+--+-- [@─•@] Leaves reflect endpoints.+--+-- [@\<capture\>/@] This is a delayed capture of a path component.+--+-- [@\<raw\>@] This is a part of the API we do not know anything about.+--+-- [@┆@] Dashed lines suggest a dynamic choice between the part above+-- and below. If there is a success for fatal failure in the first part,+-- that one takes precedence. If both parts fail, the \"better\" error+-- code will be returned.+--+layout :: (HasServer layout '[]) => Proxy layout -> Text+layout p = layoutWithContext p EmptyContext++-- | Variant of 'layout' that takes an additional 'Context'.+layoutWithContext :: (HasServer layout context)+ => Proxy layout -> Context context -> Text+layoutWithContext p context =+ routerLayout (route p context (emptyDelayed (FailFatal err501))) -- Documentation
src/Servant/Server/Experimental/Auth.hs view
@@ -12,8 +12,8 @@ module Servant.Server.Experimental.Auth where -import Control.Monad.Trans.Except (ExceptT,- runExceptT)+import Control.Monad.Trans (liftIO)+import Control.Monad.Trans.Except (runExceptT) import Data.Proxy (Proxy (Proxy)) import Data.Typeable (Typeable) import GHC.Generics (Generic)@@ -25,10 +25,11 @@ HasServer, ServerT, getContextEntry, route)-import Servant.Server.Internal.Router (Router' (WithRequest))-import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route),- addAuthCheck)-import Servant.Server.Internal.ServantErr (ServantErr)+import Servant.Server.Internal.RoutingApplication (addAuthCheck,+ delayedFailFatal,+ DelayedIO,+ withRequest)+import Servant.Server.Internal.ServantErr (Handler) -- * General Auth @@ -42,11 +43,11 @@ -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE newtype AuthHandler r usr = AuthHandler- { unAuthHandler :: r -> ExceptT ServantErr IO usr }+ { unAuthHandler :: r -> Handler usr } deriving (Generic, Typeable) -- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE-mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr+mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr mkAuthHandler = AuthHandler -- | Known orphan instance.@@ -58,9 +59,10 @@ type ServerT (AuthProtect tag :> api) m = AuthServerData (AuthProtect tag) -> ServerT api m - route Proxy context subserver = WithRequest $ \ request ->- route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)+ route Proxy context subserver =+ route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck) where+ authHandler :: Request -> Handler (AuthServerData (AuthProtect tag)) authHandler = unAuthHandler (getContextEntry context)- authCheck = fmap (either FailFatal Route) . runExceptT . authHandler-+ authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag))+ authCheck = (>>= either delayedFailFatal return) . liftIO . runExceptT . authHandler
src/Servant/Server/Internal.hs view
@@ -22,15 +22,13 @@ , module Servant.Server.Internal.ServantErr ) where -import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans (liftIO) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL-import qualified Data.Map as M import Data.Maybe (fromMaybe, mapMaybe) import Data.String (fromString) import Data.String.Conversions (cs, (<>))-import Data.Text (Text) import Data.Typeable import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal)@@ -38,7 +36,7 @@ import Network.Socket (SockAddr) import Network.Wai (Application, Request, Response, httpVersion, isSecure,- lazyRequestBody, pathInfo,+ lazyRequestBody, rawQueryString, remoteHost, requestHeaders, requestMethod, responseLBS, vault)@@ -73,9 +71,13 @@ class HasServer layout context where type ServerT layout (m :: * -> *) :: * - route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router+ route ::+ Proxy layout+ -> Context context+ -> Delayed env (Server layout)+ -> Router env -type Server layout = ServerT layout (ExceptT ServantErr IO)+type Server layout = ServerT layout Handler -- * Instances @@ -95,7 +97,7 @@ type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server))- (route pb context ((\ (_ :<|> b) -> b) <$> server))+ (route pb context ((\ (_ :<|> b) -> b) <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b @@ -114,7 +116,7 @@ -- > -- > server :: Server MyApi -- > server = getBook--- > where getBook :: Text -> ExceptT ServantErr IO Book+-- > where getBook :: Text -> Handler Book -- > getBook isbn = ... instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) => HasServer (Capture capture a :> sublayout) context where@@ -123,12 +125,12 @@ a -> ServerT sublayout m route Proxy context d =- DynamicRouter $ \ first ->+ CaptureRouter $ route (Proxy :: Proxy sublayout) context- (addCapture d $ case parseUrlPieceMaybe first :: Maybe a of- Nothing -> return $ Fail err400- Just v -> return $ Route v+ (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of+ Nothing -> delayedFail err400+ Just v -> return v ) allowedMethodHead :: Method -> Request -> Bool@@ -147,48 +149,51 @@ bdy = if allowedMethodHead method request then "" else body hdrs = (hContentType, cs contentT) : (fromMaybe [] headers) -methodCheck :: Method -> Request -> IO (RouteResult ())+methodCheck :: Method -> Request -> DelayedIO () methodCheck method request- | allowedMethod method request = return $ Route ()- | otherwise = return $ Fail err405+ | allowedMethod method request = return ()+ | otherwise = delayedFail err405 -acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())+-- This has switched between using 'Fail' and 'FailFatal' a number of+-- times. If the 'acceptCheck' is run after the body check (which would+-- be morally right), then we have to set this to 'FailFatal', because+-- the body check is not reversible, and therefore backtracking after the+-- body check is no longer an option. However, we now run the accept+-- check before the body check and can therefore afford to make it+-- recoverable.+acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO () acceptCheck proxy accH- | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()- | otherwise = return $ FailFatal err406+ | canHandleAcceptH proxy (AcceptHeader accH) = return ()+ | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a) => Method -> Proxy ctypes -> Status- -> Delayed (ExceptT ServantErr IO a)- -> Router-methodRouter method proxy status action = LeafRouter route'+ -> Delayed env (Handler a)+ -> Router env+methodRouter method proxy status action = leafRouter route' where- route' request respond- | pathIsEmpty request =+ route' env request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH- ) respond $ \ output -> do+ ) env request respond $ \ output -> do let handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request- | otherwise = respond $ Fail err404 methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) => Method -> Proxy ctypes -> Status- -> Delayed (ExceptT ServantErr IO (Headers h v))- -> Router-methodRouterHeaders method proxy status action = LeafRouter route'+ -> Delayed env (Handler (Headers h v))+ -> Router env+methodRouterHeaders method proxy status action = leafRouter route' where- route' request respond- | pathIsEmpty request =+ route' env request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH- ) respond $ \ output -> do+ ) env request respond $ \ output -> do let headers = getHeaders output handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) processMethodRouter handleA status method (Just headers) request- | otherwise = respond $ Fail err404 instance OVERLAPPABLE_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status@@ -229,7 +234,7 @@ -- > -- > server :: Server MyApi -- > server = viewReferer--- > where viewReferer :: Referer -> ExceptT ServantErr IO referer+-- > where viewReferer :: Referer -> Handler referer -- > viewReferer referer = return referer instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) => HasServer (Header sym a :> sublayout) context where@@ -237,8 +242,8 @@ type ServerT (Header sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request ->- let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)+ route Proxy context subserver =+ let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req) in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) @@ -260,7 +265,7 @@ -- > -- > server :: Server MyApi -- > server = getBooksBy--- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book]+-- > where getBooksBy :: Maybe Text -> Handler [Book] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author... instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)@@ -269,10 +274,10 @@ type ServerT (QueryParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request ->- let querytext = parseQueryText $ rawQueryString request- param =- case lookup paramname querytext of+ route Proxy context subserver =+ let querytext r = parseQueryText $ rawQueryString r+ param r =+ case lookup paramname (querytext r) of Nothing -> Nothing -- param absent from the query string Just Nothing -> Nothing -- param present with no value -> Nothing Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to@@ -297,7 +302,7 @@ -- > -- > server :: Server MyApi -- > server = getBooksBy--- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book]+-- > where getBooksBy :: [Text] -> Handler [Book] -- > getBooksBy authors = ...return all books by these authors... instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) => HasServer (QueryParams sym a :> sublayout) context where@@ -305,13 +310,13 @@ type ServerT (QueryParams sym a :> sublayout) m = [a] -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request ->- let querytext = parseQueryText $ rawQueryString request+ route Proxy context subserver =+ let querytext r = parseQueryText $ rawQueryString r -- if sym is "foo", we look for query string parameters -- named "foo" or "foo[]" and call parseQueryParam on the -- corresponding values- parameters = filter looksLikeParam querytext- values = mapMaybe (convert . snd) parameters+ parameters r = filter looksLikeParam (querytext r)+ values r = mapMaybe (convert . snd) (parameters r) in route (Proxy :: Proxy sublayout) context (passToServer subserver values) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")@@ -328,7 +333,7 @@ -- > -- > server :: Server MyApi -- > server = getBooks--- > where getBooks :: Bool -> ExceptT ServantErr IO [Book]+-- > where getBooks :: Bool -> Handler [Book] -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... instance (KnownSymbol sym, HasServer sublayout context) => HasServer (QueryFlag sym :> sublayout) context where@@ -336,9 +341,9 @@ type ServerT (QueryFlag sym :> sublayout) m = Bool -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request ->- let querytext = parseQueryText $ rawQueryString request- param = case lookup paramname querytext of+ route Proxy context subserver =+ let querytext r = parseQueryText $ rawQueryString r+ param r = case lookup paramname (querytext r) 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@@ -359,8 +364,8 @@ type ServerT Raw m = Application - route Proxy _ rawApplication = LeafRouter $ \ request respond -> do- r <- runDelayed rawApplication+ route Proxy _ rawApplication = RawRouter $ \ env request respond -> do+ r <- runDelayed rawApplication env request case r of Route app -> app request (respond . Route) Fail a -> respond $ Fail a@@ -385,7 +390,7 @@ -- > -- > server :: Server MyApi -- > server = postBook--- > where postBook :: Book -> ExceptT ServantErr IO Book+-- > where postBook :: Book -> Handler Book -- > postBook book = ...insert into your db... instance ( AllCTUnrender list a, HasServer sublayout context ) => HasServer (ReqBody list a :> sublayout) context where@@ -393,10 +398,10 @@ type ServerT (ReqBody list a :> sublayout) m = a -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request ->- route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request))+ route Proxy context subserver =+ route (Proxy :: Proxy sublayout) context (addBodyCheck subserver bodyCheck) where- bodyCheck request = do+ bodyCheck = withRequest $ \ request -> do -- See HTTP RFC 2616, section 7.2.1 -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 -- See also "W3C Internet Media Type registration, consistency of use"@@ -404,11 +409,11 @@ let contentTypeH = fromMaybe "application/octet-stream" $ lookup hContentType $ requestHeaders request mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)- <$> lazyRequestBody request+ <$> liftIO (lazyRequestBody request) case mrqbody of- Nothing -> return $ FailFatal err415- Just (Left e) -> return $ FailFatal err400 { errBody = cs e }- Just (Right v) -> return $ Route v+ Nothing -> delayedFailFatal err415+ Just (Left e) -> delayedFailFatal err400 { errBody = cs e }+ Just (Right v) -> return v -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@.@@ -416,36 +421,37 @@ type ServerT (path :> sublayout) m = ServerT sublayout m - route Proxy context subserver = StaticRouter $- M.singleton (cs (symbolVal proxyPath))- (route (Proxy :: Proxy sublayout) context subserver)+ route Proxy context subserver =+ pathRouter+ (cs (symbolVal proxyPath))+ (route (Proxy :: Proxy sublayout) context subserver) where proxyPath = Proxy :: Proxy path instance HasServer api context => HasServer (RemoteHost :> api) context where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m - route Proxy context subserver = WithRequest $ \req ->- route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req)+ route Proxy context subserver =+ route (Proxy :: Proxy api) context (passToServer subserver remoteHost) instance HasServer api context => HasServer (IsSecure :> api) context where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m - route Proxy context subserver = WithRequest $ \req ->- route (Proxy :: Proxy api) context (passToServer subserver $ secure req)+ route Proxy context subserver =+ route (Proxy :: Proxy api) context (passToServer subserver secure) where secure req = if isSecure req then Secure else NotSecure instance HasServer api context => HasServer (Vault :> api) context where type ServerT (Vault :> api) m = Vault -> ServerT api m - route Proxy context subserver = WithRequest $ \req ->- route (Proxy :: Proxy api) context (passToServer subserver $ vault req)+ route Proxy context subserver =+ route (Proxy :: Proxy api) context (passToServer subserver vault) instance HasServer api context => HasServer (HttpVersion :> api) context where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m - route Proxy context subserver = WithRequest $ \req ->- route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)+ route Proxy context subserver =+ route (Proxy :: Proxy api) context (passToServer subserver httpVersion) -- | Basic Authentication instance ( KnownSymbol realm@@ -456,20 +462,14 @@ type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m - route Proxy context subserver = WithRequest $ \ request ->- route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)+ route Proxy context subserver =+ route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck) where realm = BC8.pack $ symbolVal (Proxy :: Proxy realm) basicAuthContext = getContextEntry context- authCheck req = runBasicAuth req realm basicAuthContext+ authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext -- * helpers--pathIsEmpty :: Request -> Bool-pathIsEmpty = go . pathInfo- where go [] = True- go [""] = True- go _ = False ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP
src/Servant/Server/Internal/BasicAuth.hs view
@@ -6,6 +6,7 @@ module Servant.Server.Internal.BasicAuth where import Control.Monad (guard)+import Control.Monad.Trans (liftIO) import qualified Data.ByteString as BS import Data.ByteString.Base64 (decodeLenient) import Data.Monoid ((<>))@@ -57,13 +58,13 @@ -- | Run and check basic authentication, returning the appropriate http error per -- the spec.-runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr)+runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> DelayedIO usr runBasicAuth req realm (BasicAuthCheck ba) = case decodeBAHdr req of Nothing -> plzAuthenticate- Just e -> ba e >>= \res -> case res of+ Just e -> liftIO (ba e) >>= \res -> case res of BadPassword -> plzAuthenticate NoSuchUser -> plzAuthenticate- Unauthorized -> return $ FailFatal err403- Authorized usr -> return $ Route usr- where plzAuthenticate = return $ FailFatal err401 { errHeaders = [mkBAChallengerHdr realm] }+ Unauthorized -> delayedFailFatal err403+ Authorized usr -> return usr+ where plzAuthenticate = delayedFailFatal err401 { errHeaders = [mkBAChallengerHdr realm] }
src/Servant/Server/Internal/Router.hs view
@@ -1,89 +1,196 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-} 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, Response, pathInfo)+import qualified Data.Text as T+import Network.Wai (Response, pathInfo) import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -type Router = Router' RoutingApplication+type Router env = Router' env RoutingApplication -- | Internal representation of a router.-data Router' a =- 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 a- -- ^ to be used for routes that match an empty path- | Choice Router Router+--+-- The first argument describes an environment type that is+-- expected as extra input by the routers at the leaves. The+-- environment is filled while running the router, with path+-- components that can be used to process captures.+--+data Router' env a =+ StaticRouter (Map Text (Router' env a)) [env -> a]+ -- ^ the map contains routers for subpaths (first path component used+ -- for lookup and removed afterwards), the list contains handlers+ -- for the empty path, to be tried in order+ | CaptureRouter (Router' (Text, env) a)+ -- ^ first path component is passed to the child router in its+ -- environment and removed afterwards+ | RawRouter (env -> a)+ -- ^ to be used for routes we do not know anything about+ | Choice (Router' env a) (Router' env a) -- ^ left-biased choice between two routers deriving Functor --- | Apply a transformation to the response of a `Router`.-tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router-tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))+-- | Smart constructor for a single static path component.+pathRouter :: Text -> Router' env a -> Router' env a+pathRouter t r = StaticRouter (M.singleton t r) [] +-- | Smart constructor for a leaf, i.e., a router that expects+-- the empty path.+--+leafRouter :: (env -> a) -> Router' env a+leafRouter l = StaticRouter M.empty [l]+ -- | Smart constructor for the choice between routers. -- We currently optimize the following cases: ----- * Two static routers can be joined by joining their maps.+-- * Two static routers can be joined by joining their maps+-- and concatenating their leaf-lists. -- * 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 nodes can be reordered. ---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 :: Router' env a -> Router' env a -> Router' env a+choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =+ StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)+choice (CaptureRouter router1) (CaptureRouter router2) =+ CaptureRouter (choice router1 router2)+choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3 choice router1 router2 = Choice router1 router2 +-- | Datatype used for representing and debugging the+-- structure of a router. Abstracts from the handlers+-- at the leaves.+--+-- Two 'Router's can be structurally compared by computing+-- their 'RouterStructure' using 'routerStructure' and+-- then testing for equality, see 'sameStructure'.+--+data RouterStructure =+ StaticRouterStructure (Map Text RouterStructure) Int+ | CaptureRouterStructure RouterStructure+ | RawRouterStructure+ | ChoiceStructure RouterStructure RouterStructure+ deriving (Eq, Show)++-- | Compute the structure of a router.+--+-- Assumes that the request or text being passed+-- in 'WithRequest' or 'CaptureRouter' does not+-- affect the structure of the underlying tree.+--+routerStructure :: Router' env a -> RouterStructure+routerStructure (StaticRouter m ls) =+ StaticRouterStructure (fmap routerStructure m) (length ls)+routerStructure (CaptureRouter router) =+ CaptureRouterStructure $+ routerStructure router+routerStructure (RawRouter _) =+ RawRouterStructure+routerStructure (Choice r1 r2) =+ ChoiceStructure+ (routerStructure r1)+ (routerStructure r2)++-- | Compare the structure of two routers.+--+sameStructure :: Router' env a -> Router' env b -> Bool+sameStructure r1 r2 =+ routerStructure r1 == routerStructure r2++-- | Provide a textual representation of the+-- structure of a router.+--+routerLayout :: Router' env a -> Text+routerLayout router =+ T.unlines (["/"] ++ mkRouterLayout False (routerStructure router))+ where+ mkRouterLayout :: Bool -> RouterStructure -> [Text]+ mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n+ mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)+ mkRouterLayout c RawRouterStructure =+ if c then ["├─ <raw>"] else ["└─ <raw>"]+ mkRouterLayout c (ChoiceStructure r1 r2) =+ mkRouterLayout True r1 ++ ["┆"] ++ mkRouterLayout c r2++ mkSubTrees :: Bool -> [(Text, RouterStructure)] -> Int -> [Text]+ mkSubTrees _ [] 0 = []+ mkSubTrees c [] n =+ concat (replicate (n - 1) (mkLeaf True) ++ [mkLeaf c])+ mkSubTrees c [(t, r)] 0 =+ mkSubTree c t (mkRouterLayout False r)+ mkSubTrees c ((t, r) : trs) n =+ mkSubTree True t (mkRouterLayout False r) ++ mkSubTrees c trs n++ mkLeaf :: Bool -> [Text]+ mkLeaf True = ["├─•","┆"]+ mkLeaf False = ["└─•"]++ mkSubTree :: Bool -> Text -> [Text] -> [Text]+ mkSubTree True path children = ("├─ " <> path <> "/") : map ("│ " <>) children+ mkSubTree False path children = ("└─ " <> path <> "/") : map (" " <>) children++-- | Apply a transformation to the response of a `Router`.+tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env -> Router env+tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))+ -- | 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 pathInfo request of- first : rest- | Just router <- M.lookup first table- -> let request' = request { pathInfo = rest }- in runRouter router request' respond- _ -> respond $ Fail err404-runRouter (DynamicRouter fun) request respond =- case pathInfo request of- first : rest- -> let request' = request { pathInfo = rest }- in runRouter (fun first) request' respond- _ -> respond $ Fail err404-runRouter (LeafRouter app) request respond = app request respond-runRouter (Choice r1 r2) request respond =- runRouter r1 request $ \ mResponse1 -> case mResponse1 of- Fail _ -> runRouter r2 request $ \ mResponse2 ->- respond (highestPri mResponse1 mResponse2)- _ -> respond mResponse1- where- highestPri (Fail e1) (Fail e2) =- if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)- then Fail e2- else Fail e1- highestPri (Fail _) y = y- highestPri x _ = x+runRouter :: Router () -> RoutingApplication+runRouter r = runRouterEnv r () +runRouterEnv :: Router env -> env -> RoutingApplication+runRouterEnv router env request respond =+ case router of+ StaticRouter table ls ->+ case pathInfo request of+ [] -> runChoice ls env request respond+ -- This case is to handle trailing slashes.+ [""] -> runChoice ls env request respond+ first : rest | Just router' <- M.lookup first table+ -> let request' = request { pathInfo = rest }+ in runRouterEnv router' env request' respond+ _ -> respond $ Fail err404+ CaptureRouter router' ->+ case pathInfo request of+ [] -> respond $ Fail err404+ -- This case is to handle trailing slashes.+ [""] -> respond $ Fail err404+ first : rest+ -> let request' = request { pathInfo = rest }+ in runRouterEnv router' (first, env) request' respond+ RawRouter app ->+ app env request respond+ Choice r1 r2 ->+ runChoice [runRouterEnv r1, runRouterEnv r2] env request respond++-- | Try a list of routing applications in order.+-- We stop as soon as one fails fatally or succeeds.+-- If all fail normally, we pick the "best" error.+--+runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication+runChoice ls =+ case ls of+ [] -> \ _ _ respond -> respond (Fail err404)+ [r] -> r+ (r : rs) ->+ \ env request respond ->+ r env request $ \ response1 ->+ case response1 of+ Fail _ -> runChoice rs env request $ \ response2 ->+ respond $ highestPri response1 response2+ _ -> respond response1+ where+ highestPri (Fail e1) (Fail e2) =+ if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)+ then Fail e2+ else Fail e1+ highestPri (Fail _) y = y+ highestPri x _ = x -- Priority on HTTP codes. --
src/Servant/Server/Internal/RoutingApplication.hs view
@@ -8,7 +8,10 @@ {-# LANGUAGE StandaloneDeriving #-} module Servant.Server.Internal.RoutingApplication where -import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Control.Monad (ap, liftM)+import Control.Monad.Trans (MonadIO(..))+import Control.Monad.Trans.Except (runExceptT)+import Data.Text (Text) import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude ()@@ -35,31 +38,6 @@ routingRespond (FailFatal err) = respond $ responseServantErr err routingRespond (Route v) = respond v --- We currently mix up the order in which we perform checks--- and the priority with which errors are reported.------ For example, we perform Capture checks prior to method checks,--- and therefore get 404 before 405.------ However, we also perform body checks prior to method checks--- now, and therefore get 415 before 405, which is wrong.------ If we delay Captures, but perform method checks eagerly, we--- end up potentially preferring 405 over 404, which is also bad.------ So in principle, we'd like:------ static routes (can cause 404)--- delayed captures (can cause 404)--- methods (can cause 405)--- authentication and authorization (can cause 401, 403)--- delayed body (can cause 415, 400)--- accept header (can cause 406)------ According to the HTTP decision diagram, the priority order--- between HTTP status codes is as follows:---- -- | A 'Delayed' is a representation of a handler with scheduled -- delayed checks that can trigger errors. --@@ -120,113 +98,139 @@ -- The accept header check can be performed as the final -- computation in this block. It can cause a 406. ---data Delayed c where- Delayed :: { capturesD :: IO (RouteResult captures)- , methodD :: IO (RouteResult ())- , authD :: IO (RouteResult auth)- , bodyD :: IO (RouteResult body)- , serverD :: (captures -> auth -> body -> RouteResult c)- } -> Delayed c+data Delayed env c where+ Delayed :: { capturesD :: env -> DelayedIO captures+ , methodD :: DelayedIO ()+ , authD :: DelayedIO auth+ , bodyD :: DelayedIO body+ , serverD :: captures -> auth -> body -> Request -> RouteResult c+ } -> Delayed env c -instance Functor Delayed where- fmap f Delayed{..}- = Delayed { capturesD = capturesD- , methodD = methodD- , authD = authD- , bodyD = bodyD- , serverD = (fmap.fmap.fmap.fmap) f serverD- } -- Note [Existential Record Update]+instance Functor (Delayed env) where+ fmap f Delayed{..} =+ Delayed+ { serverD = \ c a b req -> f <$> serverD c a b req+ , ..+ } -- Note [Existential Record Update] +-- | Computations used in a 'Delayed' can depend on the+-- incoming 'Request', may perform 'IO, and result in a+-- 'RouteResult, meaning they can either suceed, fail+-- (with the possibility to recover), or fail fatally.+--+newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> IO (RouteResult a) }++instance Functor DelayedIO where+ fmap = liftM++instance Applicative DelayedIO where+ pure = return+ (<*>) = ap++instance Monad DelayedIO where+ return x = DelayedIO (const $ return (Route x))+ DelayedIO m >>= f =+ DelayedIO $ \ req -> do+ r <- m req+ case r of+ Fail e -> return $ Fail e+ FailFatal e -> return $ FailFatal e+ Route a -> runDelayedIO (f a) req++instance MonadIO DelayedIO where+ liftIO m = DelayedIO (const $ Route <$> m)++-- | A 'Delayed' without any stored checks.+emptyDelayed :: RouteResult a -> Delayed env a+emptyDelayed result =+ Delayed (const r) r r r (\ _ _ _ _ -> result)+ where+ r = return ()++-- | Fail with the option to recover.+delayedFail :: ServantErr -> DelayedIO a+delayedFail err = DelayedIO (const $ return $ Fail err)++-- | Fail fatally, i.e., without any option to recover.+delayedFailFatal :: ServantErr -> DelayedIO a+delayedFailFatal err = DelayedIO (const $ return $ FailFatal err)++-- | Gain access to the incoming request.+withRequest :: (Request -> DelayedIO a) -> DelayedIO a+withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)+ -- | Add a capture to the end of the capture block.-addCapture :: Delayed (a -> b)- -> IO (RouteResult a)- -> Delayed b-addCapture Delayed{..} new- = Delayed { capturesD = combineRouteResults (,) capturesD new- , methodD = methodD- , authD = authD- , bodyD = bodyD- , serverD = \ (x, v) y z -> ($ v) <$> serverD x y z- } -- Note [Existential Record Update]+addCapture :: Delayed env (a -> b)+ -> (Text -> DelayedIO a)+ -> Delayed (Text, env) b+addCapture Delayed{..} new =+ Delayed+ { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt+ , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req+ , ..+ } -- Note [Existential Record Update] -- | Add a method check to the end of the method block.-addMethodCheck :: Delayed a- -> IO (RouteResult ())- -> Delayed a-addMethodCheck Delayed{..} new- = Delayed { capturesD = capturesD- , methodD = combineRouteResults const methodD new- , authD = authD- , bodyD = bodyD- , serverD = serverD- } -- Note [Existential Record Update]+addMethodCheck :: Delayed env a+ -> DelayedIO ()+ -> Delayed env a+addMethodCheck Delayed{..} new =+ Delayed+ { methodD = methodD <* new+ , ..+ } -- Note [Existential Record Update] -- | Add an auth check to the end of the auth block.-addAuthCheck :: Delayed (a -> b)- -> IO (RouteResult a)- -> Delayed b-addAuthCheck Delayed{..} new- = Delayed { capturesD = capturesD- , methodD = methodD- , authD = combineRouteResults (,) authD new- , bodyD = bodyD- , serverD = \ x (y, v) z -> ($ v) <$> serverD x y z- } -- Note [Existential Record Update]+addAuthCheck :: Delayed env (a -> b)+ -> DelayedIO a+ -> Delayed env b+addAuthCheck Delayed{..} new =+ Delayed+ { authD = (,) <$> authD <*> new+ , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req+ , ..+ } -- Note [Existential Record Update] -- | Add a body check to the end of the body block.-addBodyCheck :: Delayed (a -> b)- -> IO (RouteResult a)- -> Delayed b-addBodyCheck Delayed{..} new- = Delayed { capturesD = capturesD- , methodD = methodD- , authD = authD- , bodyD = combineRouteResults (,) bodyD new- , serverD = \ x y (z, v) -> ($ v) <$> serverD x y z- } -- Note [Existential Record Update]+addBodyCheck :: Delayed env (a -> b)+ -> DelayedIO a+ -> Delayed env b+addBodyCheck Delayed{..} new =+ Delayed+ { bodyD = (,) <$> bodyD <*> new+ , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req+ , ..+ } -- Note [Existential Record Update] --- | Add an accept header check to the end of the body block.--- The accept header check should occur after the body check,--- but this will be the case, because the accept header check--- is only scheduled by the method combinators.-addAcceptCheck :: Delayed a- -> IO (RouteResult ())- -> Delayed a-addAcceptCheck Delayed{..} new- = Delayed { capturesD = capturesD- , methodD = methodD- , authD = authD- , bodyD = combineRouteResults const bodyD new- , serverD = serverD- } -- Note [Existential Record Update]+-- | Add an accept header check to the beginning of the body+-- block. There is a tradeoff here. In principle, we'd like+-- to take a bad body (400) response take precedence over a+-- failed accept check (406). BUT to allow streaming the body,+-- we cannot run the body check and then still backtrack.+-- We therefore do the accept check before the body check,+-- when we can still backtrack. There are other solutions to+-- this, but they'd be more complicated (such as delaying the+-- body check further so that it can still be run in a situation+-- where we'd otherwise report 406).+addAcceptCheck :: Delayed env a+ -> DelayedIO ()+ -> Delayed env a+addAcceptCheck Delayed{..} new =+ Delayed+ { bodyD = new *> bodyD+ , ..+ } -- Note [Existential Record Update] -- | Many combinators extract information that is passed to -- the handler without the possibility of failure. In such a -- case, 'passToServer' can be used.-passToServer :: Delayed (a -> b) -> a -> Delayed b-passToServer d x = ($ x) <$> d---- | The combination 'IO . RouteResult' is a monad, but we--- don't explicitly wrap it in a newtype in order to make it--- an instance. This is the '>>=' of that monad.------ We stop on the first error.-bindRouteResults :: IO (RouteResult a) -> (a -> IO (RouteResult b)) -> IO (RouteResult b)-bindRouteResults m f = do- r <- m- case r of- Fail e -> return $ Fail e- FailFatal e -> return $ FailFatal e- Route a -> f a---- | Common special case of 'bindRouteResults', corresponding--- to 'liftM2'.-combineRouteResults :: (a -> b -> c) -> IO (RouteResult a) -> IO (RouteResult b) -> IO (RouteResult c)-combineRouteResults f m1 m2 =- m1 `bindRouteResults` \ a ->- m2 `bindRouteResults` \ b ->- return (Route (f a b))+passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b+passToServer Delayed{..} x =+ Delayed+ { serverD = \ c a b req -> ($ x req) <$> serverD c a b req+ , ..+ } -- Note [Existential Record Update] -- | Run a delayed server. Performs all scheduled operations -- in order, and passes the results from the capture and body@@ -234,24 +238,29 @@ -- -- This should only be called once per request; otherwise the guarantees about -- effect and HTTP error ordering break down.-runDelayed :: Delayed a+runDelayed :: Delayed env a+ -> env+ -> Request -> IO (RouteResult a)-runDelayed Delayed{..} =- capturesD `bindRouteResults` \ c ->- methodD `bindRouteResults` \ _ ->- authD `bindRouteResults` \ a ->- bodyD `bindRouteResults` \ b ->- return (serverD c a b)+runDelayed Delayed{..} env = runDelayedIO $ do+ c <- capturesD env+ methodD+ a <- authD+ b <- bodyD+ DelayedIO (\ req -> return $ serverD c a b req) -- | Runs a delayed server and the resulting action. -- Takes a continuation that lets us send a response. -- Also takes a continuation for how to turn the -- result of the delayed server into a response.-runAction :: Delayed (ExceptT ServantErr IO a)+runAction :: Delayed env (Handler a)+ -> env+ -> Request -> (RouteResult Response -> IO r) -> (a -> RouteResult Response) -> IO r-runAction action respond k = runDelayed action >>= go >>= respond+runAction action env req respond k =+ runDelayed action env req >>= go >>= respond where go (Fail e) = return $ Fail e go (FailFatal e) = return $ FailFatal e
src/Servant/Server/Internal/ServantErr.hs view
@@ -4,6 +4,7 @@ module Servant.Server.Internal.ServantErr where import Control.Exception (Exception)+import Control.Monad.Trans.Except (ExceptT) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import Data.Typeable (Typeable)@@ -18,6 +19,8 @@ instance Exception ServantErr +type Handler = ExceptT ServantErr IO+ responseServantErr :: ServantErr -> Response responseServantErr ServantErr{..} = responseLBS status errHeaders errBody where@@ -27,7 +30,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err300 { errBody = "I can't choose." } -- err300 :: ServantErr@@ -41,7 +44,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr err301 -- err301 :: ServantErr@@ -55,7 +58,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr err302 -- err302 :: ServantErr@@ -69,7 +72,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr err303 -- err303 :: ServantErr@@ -83,7 +86,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr err304 -- err304 :: ServantErr@@ -97,7 +100,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr err305 -- err305 :: ServantErr@@ -111,7 +114,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr err307 -- err307 :: ServantErr@@ -125,7 +128,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err400 { errBody = "Your request makes no sense to me." } -- err400 :: ServantErr@@ -139,7 +142,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err401 { errBody = "Your credentials are invalid." } -- err401 :: ServantErr@@ -153,7 +156,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err402 { errBody = "You have 0 credits. Please give me $$$." } -- err402 :: ServantErr@@ -167,7 +170,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err403 { errBody = "Please login first." } -- err403 :: ServantErr@@ -181,7 +184,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } -- err404 :: ServantErr@@ -195,7 +198,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." } -- err405 :: ServantErr@@ -209,7 +212,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr err406 -- err406 :: ServantErr@@ -223,7 +226,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr err407 -- err407 :: ServantErr@@ -237,7 +240,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" } -- err409 :: ServantErr@@ -251,7 +254,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." } -- err410 :: ServantErr@@ -265,7 +268,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr err411 -- err411 :: ServantErr@@ -279,7 +282,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err412 { errBody = "Precondition fail: x < 42 && y > 57" } -- err412 :: ServantErr@@ -293,7 +296,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err413 { errBody = "Request exceeded 64k." } -- err413 :: ServantErr@@ -307,7 +310,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err414 { errBody = "Maximum length is 64." } -- err414 :: ServantErr@@ -321,7 +324,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err415 { errBody = "Supported media types: gif, png" } -- err415 :: ServantErr@@ -335,7 +338,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err416 { errBody = "Valid range is [0, 424242]." } -- err416 :: ServantErr@@ -349,7 +352,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err417 { errBody = "I found a quux in the request. This isn't going to work." } -- err417 :: ServantErr@@ -363,7 +366,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" } -- err500 :: ServantErr@@ -377,7 +380,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err501 { errBody = "/v1/foo is not supported with quux in the request." } -- err501 :: ServantErr@@ -391,7 +394,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." } -- err502 :: ServantErr@@ -405,7 +408,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err503 { errBody = "We're rewriting in PHP." } -- err503 :: ServantErr@@ -419,7 +422,7 @@ -- -- Example: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err504 { errBody = "Backend foobar did not respond in 5 seconds." } -- err504 :: ServantErr@@ -433,7 +436,7 @@ -- -- Example usage: ----- > failingHandler :: ExceptT ServantErr IO ()+-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err505 { errBody = "I support HTTP/4.0 only." } -- err505 :: ServantErr
test/Servant/Server/ErrorSpec.hs view
@@ -53,6 +53,23 @@ errorOrderServer :: Server ErrorOrderApi errorOrderServer = \_ _ _ -> throwE err402 +-- On error priorities:+--+-- We originally had+--+-- 404, 405, 401, 415, 400, 406, 402+--+-- but we changed this to+--+-- 404, 405, 401, 406, 415, 400, 402+--+-- for servant-0.7.+--+-- This change is due to the body check being irreversible (to support+-- streaming). Any check done after the body check has to be made fatal,+-- breaking modularity. We've therefore moved the accept check before+-- the body check, to allow it being recoverable and modular, and this+-- goes along with promoting the error priority of 406. errorOrderSpec :: Spec errorOrderSpec = describe "HTTP error order" $@@ -86,17 +103,17 @@ request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 401 - it "has 415 as its fourth highest priority error" $ do+ it "has 406 as its fourth highest priority error" $ do request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody+ `shouldRespondWith` 406++ it "has 415 as its fifth highest priority error" $ do+ request goodMethod goodUrl [goodAuth, badContentType, goodAccept] badBody `shouldRespondWith` 415 - it "has 400 as its fifth highest priority error" $ do- request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody+ it "has 400 as its sixth highest priority error" $ do+ request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody `shouldRespondWith` 400-- it "has 406 as its sixth highest priority error" $ do- request goodMethod goodUrl [goodAuth, goodContentType, badAccept] goodBody- `shouldRespondWith` 406 it "has handler-level errors as last priority" $ do request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody
test/Servant/Server/Internal/EnterSpec.hs view
@@ -34,7 +34,7 @@ readerServer' :: ServerT ReaderAPI (Reader String) readerServer' = return 1797 :<|> ask -fReader :: Reader String :~> ExceptT ServantErr IO+fReader :: Reader String :~> Handler fReader = generalizeNat C.. (runReaderTNat "hi") readerServer :: Server ReaderAPI
test/Servant/Server/UsingContextSpec.hs view
@@ -25,7 +25,7 @@ type OneEntryAPI = ExtractFromContext :> Get '[JSON] String -testServer :: String -> ExceptT ServantErr IO String+testServer :: String -> Handler String testServer s = return s oneEntryApp :: Application
test/Servant/Server/UsingContextSpec/TestCombinators.hs view
@@ -20,7 +20,6 @@ import GHC.TypeLits import Servant-import Servant.Server.Internal.RoutingApplication data ExtractFromContext @@ -31,7 +30,7 @@ String -> ServerT subApi m route Proxy context delayed =- route subProxy context (fmap (inject context) delayed :: Delayed (Server subApi))+ route subProxy context (fmap (inject context) delayed) where subProxy :: Proxy subApi subProxy = Proxy
test/Servant/ServerSpec.hs view
@@ -13,11 +13,8 @@ module Servant.ServerSpec where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif import Control.Monad (forM_, when, unless)-import Control.Monad.Trans.Except (ExceptT, throwE)+import Control.Monad.Trans.Except (throwE) import Data.Aeson (FromJSON, ToJSON, decode', encode) import qualified Data.ByteString.Base64 as Base64 import Data.ByteString.Conversion ()@@ -36,8 +33,7 @@ parseQuery) import Network.Wai (Application, Request, requestHeaders, pathInfo, queryString, rawQueryString,- responseBuilder, responseLBS)-import Network.Wai.Internal (Response (ResponseBuilder))+ responseLBS) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody, simpleHeaders, simpleStatus)@@ -52,8 +48,9 @@ Raw, RemoteHost, ReqBody, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI-import Servant.Server (ServantErr (..), Server, err401, err404,- serve, serveWithContext, Context((:.), EmptyContext))+import Servant.Server (Server, Handler, err401, err403,+ err404, serve, serveWithContext,+ Context((:.), EmptyContext)) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import qualified Test.Hspec.Wai as THW@@ -66,11 +63,6 @@ import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler)-import Servant.Server.Internal.RoutingApplication- (toApplication, RouteResult(..))-import Servant.Server.Internal.Router- (tweakResponse, runRouter,- Router, Router'(LeafRouter)) import Servant.Server.Internal.Context (NamedContext(..)) @@ -94,7 +86,6 @@ rawSpec alternativeSpec responseHeadersSpec- routerSpec miscCombinatorSpec basicAuthSpec genAuthSpec@@ -108,6 +99,9 @@ :<|> "noContent" :> Verb method status '[JSON] NoContent :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person) :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)+ :<|> "accept" :> ( Verb method status '[JSON] Person+ :<|> Verb method status '[PlainText] String+ ) verbSpec :: Spec verbSpec = describe "Servant.API.Verb" $ do@@ -116,6 +110,7 @@ :<|> return NoContent :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent)+ :<|> (return alice :<|> return "B") get200 = Proxy :: Proxy (VerbApi 'GET 200) post210 = Proxy :: Proxy (VerbApi 'POST 210) put203 = Proxy :: Proxy (VerbApi 'PUT 203)@@ -170,6 +165,12 @@ [(hAccept, "application/json")] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status + unless (status `elem` [214, 215] || method == methodHead) $+ it "allows modular specification of supported content types" $ do+ response <- THW.request method "/accept" [(hAccept, "text/plain")] ""+ liftIO $ statusCode (simpleStatus response) `shouldBe` status+ liftIO $ simpleBody response `shouldBe` "B"+ it "sets the Content-Type header" $ do response <- THW.request method "" [] "" liftIO $ simpleHeaders response `shouldContain`@@ -190,7 +191,7 @@ type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal captureApi :: Proxy CaptureApi captureApi = Proxy-captureServer :: Integer -> ExceptT ServantErr IO Animal+captureServer :: Integer -> Handler Animal captureServer legs = case legs of 4 -> return jerry 2 -> return tweety@@ -346,11 +347,11 @@ headerSpec :: Spec headerSpec = describe "Servant.API.Header" $ do - let expectsInt :: Maybe Int -> ExceptT ServantErr IO ()+ let expectsInt :: Maybe Int -> Handler () expectsInt (Just x) = when (x /= 5) $ error "Expected 5" expectsInt Nothing = error "Expected an int" - let expectsString :: Maybe String -> ExceptT ServantErr IO ()+ let expectsString :: Maybe String -> Handler () expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you" expectsString Nothing = error "Expected a string" @@ -484,28 +485,6 @@ -- }}} --------------------------------------------------------------------------------- * routerSpec {{{--------------------------------------------------------------------------------routerSpec :: Spec-routerSpec = do- describe "Servant.Server.Internal.Router" $ do- let app' :: Application- app' = toApplication $ runRouter router'-- router', router :: Router- router' = tweakResponse (twk <$>) router- router = LeafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")-- twk :: Response -> Response- twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b- twk b = b-- describe "tweakResponse" . with (return app') $ do- it "calls f on route result" $ do- get "" `shouldRespondWith` 202---- }}}------------------------------------------------------------------------------- -- * miscCombinatorSpec {{{ ------------------------------------------------------------------------------ type MiscCombinatorsAPI@@ -606,11 +585,10 @@ genAuthContext :: Context '[AuthHandler Request ()] genAuthContext =- let authHandler = (\req ->- if elem ("Auth", "secret") (requestHeaders req)- then return ()- else throwE err401- )+ let authHandler = \req -> case lookup "Auth" (requestHeaders req) of+ Just "secret" -> return ()+ Just _ -> throwE err403+ Nothing -> throwE err401 in mkAuthHandler authHandler :. EmptyContext genAuthSpec :: Spec@@ -621,6 +599,9 @@ context "Custom Auth Protection" $ do it "returns 401 when missing headers" $ do get "/auth" `shouldRespondWith` 401++ it "returns 403 on wrong passwords" $ do+ THW.request methodGet "/auth" [("Auth","wrong")] "" `shouldRespondWith` 403 it "returns 200 with the right header" $ do THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200