servant-server 0.15 → 0.16
raw patch · 16 files changed
+997/−900 lines, 16 filesdep ~QuickCheckdep ~hspecdep ~http-media
Dependency ranges changed: QuickCheck, hspec, http-media, network, network-uri, servant
Files
- CHANGELOG.md +12/−0
- servant-server.cabal +12/−9
- src/Servant/Server.hs +1/−1
- src/Servant/Server/Experimental/Auth.hs +3/−5
- src/Servant/Server/Internal.hs +8/−2
- src/Servant/Server/Internal/BasicAuth.hs +3/−3
- src/Servant/Server/Internal/Delayed.hs +272/−0
- src/Servant/Server/Internal/DelayedIO.hs +72/−0
- src/Servant/Server/Internal/Handler.hs +6/−6
- src/Servant/Server/Internal/RouteResult.hs +76/−0
- src/Servant/Server/Internal/Router.hs +14/−4
- src/Servant/Server/Internal/RoutingApplication.hs +4/−383
- src/Servant/Server/Internal/ServantErr.hs +0/−475
- src/Servant/Server/Internal/ServerError.hs +477/−0
- test/Servant/Server/Internal/RoutingApplicationSpec.hs +1/−1
- test/Servant/Server/RouterSpec.hs +36/−11
CHANGELOG.md view
@@ -1,6 +1,18 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.16+----++- Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError`+ [#1131](https://github.com/haskell-servant/pull/1131)+- *servant-server* Reorder HTTP failure code priorities+ [#1103](https://github.com/haskell-servant/servant/pull/1103)+- *servant-server* Re-organise internal modules+ [#1139](https://github.com/haskell-servant/servant/pull/1139)+- Allow `network-3.0`+ [#1107](https://github.com/haskell-servant/pull/1107)+ 0.15 ----
servant-server.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-server-version: 0.15+version: 0.16 synopsis: A family of combinators for defining webservices APIs and serving them category: Servant, Web@@ -21,13 +21,13 @@ license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com-copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Custom tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4- || ==8.6.2+ || ==8.6.3 extra-source-files: CHANGELOG.md@@ -52,10 +52,13 @@ Servant.Server.Internal Servant.Server.Internal.BasicAuth Servant.Server.Internal.Context+ Servant.Server.Internal.Delayed+ Servant.Server.Internal.DelayedIO Servant.Server.Internal.Handler Servant.Server.Internal.Router+ Servant.Server.Internal.RouteResult Servant.Server.Internal.RoutingApplication- Servant.Server.Internal.ServantErr+ Servant.Server.Internal.ServerError Servant.Server.StaticFiles -- deprecated@@ -76,7 +79,7 @@ -- Servant dependencies -- strict dependency as we re-export 'servant' things. build-depends:- servant >= 0.15 && < 0.15.1+ servant >= 0.16 && < 0.17.1 , http-api-data >= 0.4 && < 0.4.1 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.@@ -87,9 +90,9 @@ , exceptions >= 0.10.0 && < 0.11 , http-media >= 0.7.1.3 && < 0.8 , http-types >= 0.12.2 && < 0.13- , network-uri >= 2.6.1.0 && < 2.7+ , network-uri >= 2.6.1.0 && < 2.8 , monad-control >= 1.0.2.3 && < 1.1- , network >= 2.8 && < 2.9+ , network >= 2.8 && < 3.1 , string-conversions >= 0.4.0.1 && < 0.5 , resourcet >= 1.2.2 && < 1.3 , tagged >= 0.8.6 && < 0.9@@ -160,7 +163,7 @@ build-depends: aeson >= 1.4.1.0 && < 1.5 , directory >= 1.3.0.0 && < 1.4- , hspec >= 2.6.0 && < 2.7+ , hspec >= 2.6.0 && < 2.8 , hspec-wai >= 0.9.0 && < 0.10 , QuickCheck >= 2.12.6.1 && < 2.13 , should-not-typecheck >= 2.1.0 && < 2.2@@ -168,7 +171,7 @@ , wai-extra >= 3.0.24.3 && < 3.1 build-tool-depends:- hspec-discover:hspec-discover >= 2.6.0 && <2.7+ hspec-discover:hspec-discover >= 2.6.0 && <2.8 test-suite doctests build-depends:
src/Servant/Server.hs view
@@ -49,7 +49,7 @@ -- , mkAuthHandler -- * Default error type- , ServantErr(..)+ , ServerError(..) -- ** 3XX , err300 , err301
src/Servant/Server/Experimental/Auth.hs view
@@ -27,11 +27,9 @@ ((:>)) import Servant.API.Experimental.Auth import Servant.Server.Internal- (HasContextEntry, HasServer (..), getContextEntry)-import Servant.Server.Internal.Handler- (Handler, runHandler)-import Servant.Server.Internal.RoutingApplication- (DelayedIO, addAuthCheck, delayedFailFatal, withRequest)+ (DelayedIO, Handler, HasContextEntry, HasServer (..),+ addAuthCheck, delayedFailFatal, getContextEntry, runHandler,+ withRequest) -- * General Auth
src/Servant/Server/Internal.hs view
@@ -22,10 +22,13 @@ ( module Servant.Server.Internal , module Servant.Server.Internal.BasicAuth , module Servant.Server.Internal.Context+ , module Servant.Server.Internal.Delayed+ , module Servant.Server.Internal.DelayedIO , module Servant.Server.Internal.Handler , module Servant.Server.Internal.Router+ , module Servant.Server.Internal.RouteResult , module Servant.Server.Internal.RoutingApplication- , module Servant.Server.Internal.ServantErr+ , module Servant.Server.Internal.ServerError ) where import Control.Monad@@ -88,10 +91,13 @@ import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context+import Servant.Server.Internal.Delayed+import Servant.Server.Internal.DelayedIO import Servant.Server.Internal.Handler import Servant.Server.Internal.Router+import Servant.Server.Internal.RouteResult import Servant.Server.Internal.RoutingApplication-import Servant.Server.Internal.ServantErr+import Servant.Server.Internal.ServerError #ifdef HAS_TYPE_ERROR import GHC.TypeLits
src/Servant/Server/Internal/BasicAuth.hs view
@@ -9,7 +9,7 @@ (guard) import Control.Monad.Trans (liftIO)-import qualified Data.ByteString as BS+import qualified Data.ByteString as BS import Data.ByteString.Base64 (decodeLenient) import Data.Monoid@@ -26,8 +26,8 @@ import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))-import Servant.Server.Internal.RoutingApplication-import Servant.Server.Internal.ServantErr+import Servant.Server.Internal.DelayedIO+import Servant.Server.Internal.ServerError -- * Basic Auth
+ src/Servant/Server/Internal/Delayed.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Servant.Server.Internal.Delayed where++import Control.Monad.IO.Class+ (MonadIO (..))+import Control.Monad.Reader+ (ask)+import Control.Monad.Trans.Resource+ (ResourceT, runResourceT)+import Network.Wai+ (Request, Response)++import Servant.Server.Internal.DelayedIO+import Servant.Server.Internal.Handler+import Servant.Server.Internal.RouteResult+import Servant.Server.Internal.ServerError++-- | A 'Delayed' is a representation of a handler with scheduled+-- delayed checks that can trigger errors.+--+-- Why would we want to delay checks?+--+-- There are two reasons:+--+-- 1. In a straight-forward implementation, the order in which we+-- perform checks will determine the error we generate. This is+-- because once an error occurs, we would abort and not perform+-- any subsequent checks, but rather return the current error.+--+-- This is not a necessity: we could continue doing other checks,+-- and choose the preferred error. However, that would in general+-- mean more checking, which leads us to the other reason.+--+-- 2. We really want to avoid doing certain checks too early. For+-- example, captures involve parsing, and are much more costly+-- than static route matches. In particular, if several paths+-- contain the "same" capture, we'd like as much as possible to+-- avoid trying the same parse many times. Also tricky is the+-- request body. Again, this involves parsing, but also, WAI makes+-- obtaining the request body a side-effecting operation. We+-- could/can work around this by manually caching the request body,+-- but we'd rather keep the number of times we actually try to+-- decode the request body to an absolute minimum.+--+-- We prefer to have the following relative priorities of error+-- codes:+--+-- @+-- 404+-- 405 (bad method)+-- 401 (unauthorized)+-- 415 (unsupported media type)+-- 406 (not acceptable)+-- 400 (bad request)+-- @+--+-- Therefore, while routing, we delay most checks so that they+-- will ultimately occur in the right order.+--+-- A 'Delayed' contains many delayed blocks of tests, and+-- the actual handler:+--+-- 1. Delayed captures. These can actually cause 404, and+-- while they're costly, they should be done first among the+-- delayed checks (at least as long as we do not decouple the+-- check order from the error reporting, see above). Delayed+-- captures can provide inputs to the actual handler.+--+-- 2. Method check(s). This can cause a 405. On success,+-- it does not provide an input for the handler. Method checks+-- are comparatively cheap.+--+-- 3. Authentication checks. This can cause 401.+--+-- 4. Accept and content type header checks. These checks+-- can cause 415 and 406 errors.+--+-- 5. Query parameter checks. They require parsing and can cause 400 if the+-- parsing fails. Query parameter checks provide inputs to the handler+--+-- 6. Header Checks. They also require parsing and can cause 400 if parsing fails.+--+-- 7. Body check. The request body check can cause 400.+--+data Delayed env c where+ Delayed :: { capturesD :: env -> DelayedIO captures+ , methodD :: DelayedIO ()+ , authD :: DelayedIO auth+ , acceptD :: DelayedIO ()+ , contentD :: DelayedIO contentType+ , paramsD :: DelayedIO params+ , headersD :: DelayedIO headers+ , bodyD :: contentType -> DelayedIO body+ , serverD :: captures+ -> params+ -> headers+ -> auth+ -> body+ -> Request+ -> RouteResult c+ } -> Delayed env c++instance Functor (Delayed env) where+ fmap f Delayed{..} =+ Delayed+ { serverD = \ c p h a b req -> f <$> serverD c p h a b req+ , ..+ } -- Note [Existential Record Update]++-- | A 'Delayed' without any stored checks.+emptyDelayed :: RouteResult a -> Delayed env a+emptyDelayed result =+ Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result)+ where+ r = return ()++-- | Add a capture to the end of the capture block.+addCapture :: Delayed env (a -> b)+ -> (captured -> DelayedIO a)+ -> Delayed (captured, env) b+addCapture Delayed{..} new =+ Delayed+ { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt+ , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req+ , ..+ } -- Note [Existential Record Update]++-- | Add a parameter check to the end of the params block+addParameterCheck :: Delayed env (a -> b)+ -> DelayedIO a+ -> Delayed env b+addParameterCheck Delayed {..} new =+ Delayed+ { paramsD = (,) <$> paramsD <*> new+ , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req+ , ..+ }++-- | Add a parameter check to the end of the params block+addHeaderCheck :: Delayed env (a -> b)+ -> DelayedIO a+ -> Delayed env b+addHeaderCheck Delayed {..} new =+ Delayed+ { headersD = (,) <$> headersD <*> new+ , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req+ , ..+ }++-- | Add a method check to the end of the method block.+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 env (a -> b)+ -> DelayedIO a+ -> Delayed env b+addAuthCheck Delayed{..} new =+ Delayed+ { authD = (,) <$> authD <*> new+ , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req+ , ..+ } -- Note [Existential Record Update]++-- | Add a content type and body checks around parameter checks.+--+-- We'll report failed content type check (415), before trying to parse+-- query parameters (400). Which, in turn, happens before request body parsing.+addBodyCheck :: Delayed env (a -> b)+ -> DelayedIO c -- ^ content type check+ -> (c -> DelayedIO a) -- ^ body check+ -> Delayed env b+addBodyCheck Delayed{..} newContentD newBodyD =+ Delayed+ { contentD = (,) <$> contentD <*> newContentD+ , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c+ , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req+ , ..+ } -- Note [Existential Record Update]+++-- | Add an accept header check before handling parameters.+-- 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+ { acceptD = acceptD *> new+ , ..+ } -- 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 env (a -> b) -> (Request -> a) -> Delayed env b+passToServer Delayed{..} x =+ Delayed+ { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h 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+-- blocks on to the actual handler.+--+-- This should only be called once per request; otherwise the guarantees about+-- effect and HTTP error ordering break down.+runDelayed :: Delayed env a+ -> env+ -> Request+ -> ResourceT IO (RouteResult a)+runDelayed Delayed{..} env = runDelayedIO $ do+ r <- ask+ c <- capturesD env+ methodD+ a <- authD+ acceptD+ content <- contentD+ p <- paramsD -- Has to be before body parsing, but after content-type checks+ h <- headersD+ b <- bodyD content+ liftRouteResult (serverD c p h a b r)++-- | 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 env (Handler a)+ -> env+ -> Request+ -> (RouteResult Response -> IO r)+ -> (a -> RouteResult Response)+ -> IO r+runAction action env req respond k = runResourceT $+ runDelayed action env req >>= go >>= liftIO . respond+ where+ go (Fail e) = return $ Fail e+ go (FailFatal e) = return $ FailFatal e+ go (Route a) = liftIO $ do+ e <- runHandler a+ case e of+ Left err -> return . Route $ responseServerError err+ Right x -> return $! k x++{- Note [Existential Record Update]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot+do the more succint thing - just update the records we actually change.+-}
+ src/Servant/Server/Internal/DelayedIO.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Servant.Server.Internal.DelayedIO where++import Control.Monad.Base+ (MonadBase (..))+import Control.Monad.Catch+ (MonadThrow (..))+import Control.Monad.Reader+ (MonadReader (..), ReaderT (..), runReaderT)+import Control.Monad.Trans+ (MonadIO (..), MonadTrans (..))+import Control.Monad.Trans.Control+ (ComposeSt, MonadBaseControl (..), MonadTransControl (..),+ defaultLiftBaseWith, defaultRestoreM)+import Control.Monad.Trans.Resource+ (MonadResource (..), ResourceT, runInternalState,+ runResourceT, transResourceT, withInternalState)+import Network.Wai+ (Application, Request, Response, ResponseReceived)++import Servant.Server.Internal.RouteResult+import Servant.Server.Internal.ServerError++-- | 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' :: ReaderT Request (ResourceT (RouteResultT IO)) a }+ deriving+ ( Functor, Applicative, Monad+ , MonadIO, MonadReader Request+ , MonadThrow+ , MonadResource+ )++instance MonadBase IO DelayedIO where+ liftBase = liftIO++liftRouteResult :: RouteResult a -> DelayedIO a+liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x++instance MonadBaseControl IO DelayedIO where+ -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a+ -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')+ -- restoreM = DelayedIO . restoreM++ type StM DelayedIO a = RouteResult a+ liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s ->+ liftBaseWith $ \runInBase -> f $ \x ->+ runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s)+ restoreM = DelayedIO . lift . withInternalState . const . restoreM+++runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)+runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req++-- | Fail with the option to recover.+delayedFail :: ServerError -> DelayedIO a+delayedFail err = liftRouteResult $ Fail err++-- | Fail fatally, i.e., without any option to recover.+delayedFailFatal :: ServerError -> DelayedIO a+delayedFailFatal err = liftRouteResult $ FailFatal err++-- | Gain access to the incoming request.+withRequest :: (Request -> DelayedIO a) -> DelayedIO a+withRequest f = do+ req <- ask+ f req
src/Servant/Server/Internal/Handler.hs view
@@ -22,13 +22,13 @@ (ExceptT, runExceptT) import GHC.Generics (Generic)-import Servant.Server.Internal.ServantErr- (ServantErr)+import Servant.Server.Internal.ServerError+ (ServerError) -newtype Handler a = Handler { runHandler' :: ExceptT ServantErr IO a }+newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a } deriving ( Functor, Applicative, Monad, MonadIO, Generic- , MonadError ServantErr+ , MonadError ServerError , MonadThrow, MonadCatch, MonadMask ) @@ -36,7 +36,7 @@ liftBase = Handler . liftBase instance MonadBaseControl IO Handler where- type StM Handler a = Either ServantErr a+ type StM Handler a = Either ServerError a -- liftBaseWith :: (RunInBase Handler IO -> IO a) -> Handler a liftBaseWith f = Handler (liftBaseWith (\g -> f (g . runHandler')))@@ -44,5 +44,5 @@ -- restoreM :: StM Handler a -> Handler a restoreM st = Handler (restoreM st) -runHandler :: Handler a -> IO (Either ServantErr a)+runHandler :: Handler a -> IO (Either ServerError a) runHandler = runExceptT . runHandler'
+ src/Servant/Server/Internal/RouteResult.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Servant.Server.Internal.RouteResult where++import Control.Monad+ (ap, liftM)+import Control.Monad.Base+ (MonadBase (..))+import Control.Monad.Catch+ (MonadThrow (..))+import Control.Monad.Trans+ (MonadIO (..), MonadTrans (..))+import Control.Monad.Trans.Control+ (ComposeSt, MonadBaseControl (..), MonadTransControl (..),+ defaultLiftBaseWith, defaultRestoreM)++import Servant.Server.Internal.ServerError++-- | The result of matching against a path in the route tree.+data RouteResult a =+ Fail ServerError -- ^ Keep trying other paths.+ -- The 'ServantError' should only be 404, 405 or 406.+ | FailFatal !ServerError -- ^ Don't try other paths.+ | Route !a+ deriving (Eq, Show, Read, Functor)++instance Applicative RouteResult where+ pure = return+ (<*>) = ap++instance Monad RouteResult where+ return = Route+ Route a >>= f = f a+ Fail e >>= _ = Fail e+ FailFatal e >>= _ = FailFatal e++newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) }+ deriving (Functor)++instance MonadTrans RouteResultT where+ lift = RouteResultT . liftM Route++instance (Functor m, Monad m) => Applicative (RouteResultT m) where+ pure = return+ (<*>) = ap++instance Monad m => Monad (RouteResultT m) where+ return = RouteResultT . return . Route+ m >>= k = RouteResultT $ do+ a <- runRouteResultT m+ case a of+ Fail e -> return $ Fail e+ FailFatal e -> return $ FailFatal e+ Route b -> runRouteResultT (k b)++instance MonadIO m => MonadIO (RouteResultT m) where+ liftIO = lift . liftIO++instance MonadBase b m => MonadBase b (RouteResultT m) where+ liftBase = lift . liftBase++instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where+ type StM (RouteResultT m) a = ComposeSt RouteResultT m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++instance MonadTransControl RouteResultT where+ type StT RouteResultT a = RouteResult a+ liftWith f = RouteResultT $ liftM return $ f runRouteResultT+ restoreT = RouteResultT++instance MonadThrow m => MonadThrow (RouteResultT m) where+ throwM = lift . throwM
src/Servant/Server/Internal/Router.hs view
@@ -7,6 +7,8 @@ import Prelude () import Prelude.Compat +import Data.Function+ (on) import Data.Map (Map) import qualified Data.Map as M@@ -16,7 +18,8 @@ import Network.Wai (Response, pathInfo) import Servant.Server.Internal.RoutingApplication-import Servant.Server.Internal.ServantErr+import Servant.Server.Internal.RouteResult+import Servant.Server.Internal.ServerError type Router env = Router' env RoutingApplication @@ -208,7 +211,14 @@ -- Priority on HTTP codes. ----- It just so happens that 404 < 405 < 406 as far as--- we are concerned here, so we can use (<). worseHTTPCode :: Int -> Int -> Bool-worseHTTPCode = (<)+worseHTTPCode = on (<) toPriority+ where+ toPriority :: Int -> Int+ toPriority 404 = 0 -- not found+ toPriority 405 = 1 -- method not allowed+ toPriority 401 = 2 -- unauthorized+ toPriority 415 = 3 -- unsupported media type+ toPriority 406 = 4 -- not acceptable+ toPriority 400 = 6 -- bad request+ toPriority _ = 5
src/Servant/Server/Internal/RoutingApplication.hs view
@@ -1,399 +1,20 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.RoutingApplication where -import Control.Monad- (ap, liftM)-import Control.Monad.Base- (MonadBase (..))-import Control.Monad.Catch- (MonadThrow (..))-import Control.Monad.Reader- (MonadReader (..), ReaderT (..), runReaderT)-import Control.Monad.Trans- (MonadIO (..), MonadTrans (..))-import Control.Monad.Trans.Control- (ComposeSt, MonadBaseControl (..), MonadTransControl (..),- defaultLiftBaseWith, defaultRestoreM)-import Control.Monad.Trans.Resource- (MonadResource (..), ResourceT, runInternalState,- runResourceT, transResourceT, withInternalState) import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude () import Prelude.Compat-import Servant.Server.Internal.Handler-import Servant.Server.Internal.ServantErr+import Servant.Server.Internal.RouteResult+import Servant.Server.Internal.ServerError type RoutingApplication = Request -- ^ the request, the field 'pathInfo' may be modified by url routing -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived --- | The result of matching against a path in the route tree.-data RouteResult a =- Fail ServantErr -- ^ Keep trying other paths. The @ServantErr@- -- should only be 404, 405 or 406.- | FailFatal !ServantErr -- ^ Don't try other paths.- | Route !a- deriving (Eq, Show, Read, Functor)--instance Applicative RouteResult where- pure = return- (<*>) = ap--instance Monad RouteResult where- return = Route- Route a >>= f = f a- Fail e >>= _ = Fail e- FailFatal e >>= _ = FailFatal e--newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) }- deriving (Functor)--instance MonadTrans RouteResultT where- lift = RouteResultT . liftM Route--instance (Functor m, Monad m) => Applicative (RouteResultT m) where- pure = return- (<*>) = ap--instance Monad m => Monad (RouteResultT m) where- return = RouteResultT . return . Route- m >>= k = RouteResultT $ do- a <- runRouteResultT m- case a of- Fail e -> return $ Fail e- FailFatal e -> return $ FailFatal e- Route b -> runRouteResultT (k b)--instance MonadIO m => MonadIO (RouteResultT m) where- liftIO = lift . liftIO--instance MonadBase b m => MonadBase b (RouteResultT m) where- liftBase = lift . liftBase--instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where- type StM (RouteResultT m) a = ComposeSt RouteResultT m a- liftBaseWith = defaultLiftBaseWith- restoreM = defaultRestoreM--instance MonadTransControl RouteResultT where- type StT RouteResultT a = RouteResult a- liftWith f = RouteResultT $ liftM return $ f runRouteResultT- restoreT = RouteResultT--instance MonadThrow m => MonadThrow (RouteResultT m) where- throwM = lift . throwM- toApplication :: RoutingApplication -> Application toApplication ra request respond = ra request routingRespond where routingRespond :: RouteResult Response -> IO ResponseReceived- routingRespond (Fail err) = respond $ responseServantErr err- routingRespond (FailFatal err) = respond $ responseServantErr err+ routingRespond (Fail err) = respond $ responseServerError err+ routingRespond (FailFatal err) = respond $ responseServerError err routingRespond (Route v) = respond v---- | A 'Delayed' is a representation of a handler with scheduled--- delayed checks that can trigger errors.------ Why would we want to delay checks?------ There are two reasons:------ 1. In a straight-forward implementation, the order in which we--- perform checks will determine the error we generate. This is--- because once an error occurs, we would abort and not perform--- any subsequent checks, but rather return the current error.------ This is not a necessity: we could continue doing other checks,--- and choose the preferred error. However, that would in general--- mean more checking, which leads us to the other reason.------ 2. We really want to avoid doing certain checks too early. For--- example, captures involve parsing, and are much more costly--- than static route matches. In particular, if several paths--- contain the "same" capture, we'd like as much as possible to--- avoid trying the same parse many times. Also tricky is the--- request body. Again, this involves parsing, but also, WAI makes--- obtaining the request body a side-effecting operation. We--- could/can work around this by manually caching the request body,--- but we'd rather keep the number of times we actually try to--- decode the request body to an absolute minimum.------ We prefer to have the following relative priorities of error--- codes:------ @--- 404--- 405 (bad method)--- 401 (unauthorized)--- 415 (unsupported media type)--- 406 (not acceptable)--- 400 (bad request)--- @------ Therefore, while routing, we delay most checks so that they--- will ultimately occur in the right order.------ A 'Delayed' contains many delayed blocks of tests, and--- the actual handler:------ 1. Delayed captures. These can actually cause 404, and--- while they're costly, they should be done first among the--- delayed checks (at least as long as we do not decouple the--- check order from the error reporting, see above). Delayed--- captures can provide inputs to the actual handler.------ 2. Method check(s). This can cause a 405. On success,--- it does not provide an input for the handler. Method checks--- are comparatively cheap.------ 3. Authentication checks. This can cause 401.------ 4. Accept and content type header checks. These checks--- can cause 415 and 406 errors.------ 5. Query parameter checks. They require parsing and can cause 400 if the--- parsing fails. Query parameter checks provide inputs to the handler------ 6. Header Checks. They also require parsing and can cause 400 if parsing fails.------ 7. Body check. The request body check can cause 400.----data Delayed env c where- Delayed :: { capturesD :: env -> DelayedIO captures- , methodD :: DelayedIO ()- , authD :: DelayedIO auth- , acceptD :: DelayedIO ()- , contentD :: DelayedIO contentType- , paramsD :: DelayedIO params- , headersD :: DelayedIO headers- , bodyD :: contentType -> DelayedIO body- , serverD :: captures- -> params- -> headers- -> auth- -> body- -> Request- -> RouteResult c- } -> Delayed env c--instance Functor (Delayed env) where- fmap f Delayed{..} =- Delayed- { serverD = \ c p h a b req -> f <$> serverD c p h 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' :: ReaderT Request (ResourceT (RouteResultT IO)) a }- deriving- ( Functor, Applicative, Monad- , MonadIO, MonadReader Request- , MonadThrow- , MonadResource- )--instance MonadBase IO DelayedIO where- liftBase = liftIO--liftRouteResult :: RouteResult a -> DelayedIO a-liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x--instance MonadBaseControl IO DelayedIO where- -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a- -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')- -- restoreM = DelayedIO . restoreM-- type StM DelayedIO a = RouteResult a- liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s ->- liftBaseWith $ \runInBase -> f $ \x ->- runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s)- restoreM = DelayedIO . lift . withInternalState . const . restoreM---runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)-runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req---- | A 'Delayed' without any stored checks.-emptyDelayed :: RouteResult a -> Delayed env a-emptyDelayed result =- Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result)- where- r = return ()---- | Fail with the option to recover.-delayedFail :: ServantErr -> DelayedIO a-delayedFail err = liftRouteResult $ Fail err---- | Fail fatally, i.e., without any option to recover.-delayedFailFatal :: ServantErr -> DelayedIO a-delayedFailFatal err = liftRouteResult $ FailFatal err---- | Gain access to the incoming request.-withRequest :: (Request -> DelayedIO a) -> DelayedIO a-withRequest f = do- req <- ask- f req---- | Add a capture to the end of the capture block.-addCapture :: Delayed env (a -> b)- -> (captured -> DelayedIO a)- -> Delayed (captured, env) b-addCapture Delayed{..} new =- Delayed- { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt- , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req- , ..- } -- Note [Existential Record Update]---- | Add a parameter check to the end of the params block-addParameterCheck :: Delayed env (a -> b)- -> DelayedIO a- -> Delayed env b-addParameterCheck Delayed {..} new =- Delayed- { paramsD = (,) <$> paramsD <*> new- , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req- , ..- }---- | Add a parameter check to the end of the params block-addHeaderCheck :: Delayed env (a -> b)- -> DelayedIO a- -> Delayed env b-addHeaderCheck Delayed {..} new =- Delayed- { headersD = (,) <$> headersD <*> new- , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req- , ..- }---- | Add a method check to the end of the method block.-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 env (a -> b)- -> DelayedIO a- -> Delayed env b-addAuthCheck Delayed{..} new =- Delayed- { authD = (,) <$> authD <*> new- , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req- , ..- } -- Note [Existential Record Update]---- | Add a content type and body checks around parameter checks.------ We'll report failed content type check (415), before trying to parse--- query parameters (400). Which, in turn, happens before request body parsing.-addBodyCheck :: Delayed env (a -> b)- -> DelayedIO c -- ^ content type check- -> (c -> DelayedIO a) -- ^ body check- -> Delayed env b-addBodyCheck Delayed{..} newContentD newBodyD =- Delayed- { contentD = (,) <$> contentD <*> newContentD- , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c- , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req- , ..- } -- Note [Existential Record Update]----- | Add an accept header check before handling parameters.--- 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- { acceptD = acceptD *> new- , ..- } -- 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 env (a -> b) -> (Request -> a) -> Delayed env b-passToServer Delayed{..} x =- Delayed- { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h 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--- blocks on to the actual handler.------ This should only be called once per request; otherwise the guarantees about--- effect and HTTP error ordering break down.-runDelayed :: Delayed env a- -> env- -> Request- -> ResourceT IO (RouteResult a)-runDelayed Delayed{..} env = runDelayedIO $ do- r <- ask- c <- capturesD env- methodD- a <- authD- acceptD- content <- contentD- p <- paramsD -- Has to be before body parsing, but after content-type checks- h <- headersD- b <- bodyD content- liftRouteResult (serverD c p h a b r)---- | 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 env (Handler a)- -> env- -> Request- -> (RouteResult Response -> IO r)- -> (a -> RouteResult Response)- -> IO r-runAction action env req respond k = runResourceT $- runDelayed action env req >>= go >>= liftIO . respond- where- go (Fail e) = return $ Fail e- go (FailFatal e) = return $ FailFatal e- go (Route a) = liftIO $ do- e <- runHandler a- case e of- Left err -> return . Route $ responseServantErr err- Right x -> return $! k x--{- Note [Existential Record Update]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot-do the more succint thing - just update the records we actually change.--}
− src/Servant/Server/Internal/ServantErr.hs
@@ -1,475 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-module Servant.Server.Internal.ServantErr where--import Control.Exception- (Exception)-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy as LBS-import Data.Typeable- (Typeable)-import qualified Network.HTTP.Types as HTTP-import Network.Wai- (Response, responseLBS)--data ServantErr = ServantErr { errHTTPCode :: Int- , errReasonPhrase :: String- , errBody :: LBS.ByteString- , errHeaders :: [HTTP.Header]- } deriving (Show, Eq, Read, Typeable)--instance Exception ServantErr--responseServantErr :: ServantErr -> Response-responseServantErr ServantErr{..} = responseLBS status errHeaders errBody- where- status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)---- | 'err300' Multiple Choices------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err300 { errBody = "I can't choose." }----err300 :: ServantErr-err300 = ServantErr { errHTTPCode = 300- , errReasonPhrase = "Multiple Choices"- , errBody = ""- , errHeaders = []- }---- | 'err301' Moved Permanently------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err301----err301 :: ServantErr-err301 = ServantErr { errHTTPCode = 301- , errReasonPhrase = "Moved Permanently"- , errBody = ""- , errHeaders = []- }---- | 'err302' Found------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err302----err302 :: ServantErr-err302 = ServantErr { errHTTPCode = 302- , errReasonPhrase = "Found"- , errBody = ""- , errHeaders = []- }---- | 'err303' See Other------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err303----err303 :: ServantErr-err303 = ServantErr { errHTTPCode = 303- , errReasonPhrase = "See Other"- , errBody = ""- , errHeaders = []- }---- | 'err304' Not Modified------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err304----err304 :: ServantErr-err304 = ServantErr { errHTTPCode = 304- , errReasonPhrase = "Not Modified"- , errBody = ""- , errHeaders = []- }---- | 'err305' Use Proxy------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err305----err305 :: ServantErr-err305 = ServantErr { errHTTPCode = 305- , errReasonPhrase = "Use Proxy"- , errBody = ""- , errHeaders = []- }---- | 'err307' Temporary Redirect------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err307----err307 :: ServantErr-err307 = ServantErr { errHTTPCode = 307- , errReasonPhrase = "Temporary Redirect"- , errBody = ""- , errHeaders = []- }---- | 'err400' Bad Request------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." }----err400 :: ServantErr-err400 = ServantErr { errHTTPCode = 400- , errReasonPhrase = "Bad Request"- , errBody = ""- , errHeaders = []- }---- | 'err401' Unauthorized------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." }----err401 :: ServantErr-err401 = ServantErr { errHTTPCode = 401- , errReasonPhrase = "Unauthorized"- , errBody = ""- , errHeaders = []- }---- | 'err402' Payment Required------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." }----err402 :: ServantErr-err402 = ServantErr { errHTTPCode = 402- , errReasonPhrase = "Payment Required"- , errBody = ""- , errHeaders = []- }---- | 'err403' Forbidden------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err403 { errBody = "Please login first." }----err403 :: ServantErr-err403 = ServantErr { errHTTPCode = 403- , errReasonPhrase = "Forbidden"- , errBody = ""- , errHeaders = []- }---- | 'err404' Not Found------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." }----err404 :: ServantErr-err404 = ServantErr { errHTTPCode = 404- , errReasonPhrase = "Not Found"- , errBody = ""- , errHeaders = []- }---- | 'err405' Method Not Allowed------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }----err405 :: ServantErr-err405 = ServantErr { errHTTPCode = 405- , errReasonPhrase = "Method Not Allowed"- , errBody = ""- , errHeaders = []- }---- | 'err406' Not Acceptable------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err406----err406 :: ServantErr-err406 = ServantErr { errHTTPCode = 406- , errReasonPhrase = "Not Acceptable"- , errBody = ""- , errHeaders = []- }---- | 'err407' Proxy Authentication Required------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err407----err407 :: ServantErr-err407 = ServantErr { errHTTPCode = 407- , errReasonPhrase = "Proxy Authentication Required"- , errBody = ""- , errHeaders = []- }---- | 'err409' Conflict------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }----err409 :: ServantErr-err409 = ServantErr { errHTTPCode = 409- , errReasonPhrase = "Conflict"- , errBody = ""- , errHeaders = []- }---- | 'err410' Gone------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }----err410 :: ServantErr-err410 = ServantErr { errHTTPCode = 410- , errReasonPhrase = "Gone"- , errBody = ""- , errHeaders = []- }---- | 'err411' Length Required------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err411----err411 :: ServantErr-err411 = ServantErr { errHTTPCode = 411- , errReasonPhrase = "Length Required"- , errBody = ""- , errHeaders = []- }---- | 'err412' Precondition Failed------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }----err412 :: ServantErr-err412 = ServantErr { errHTTPCode = 412- , errReasonPhrase = "Precondition Failed"- , errBody = ""- , errHeaders = []- }---- | 'err413' Request Entity Too Large------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." }----err413 :: ServantErr-err413 = ServantErr { errHTTPCode = 413- , errReasonPhrase = "Request Entity Too Large"- , errBody = ""- , errHeaders = []- }---- | 'err414' Request-URI Too Large------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." }----err414 :: ServantErr-err414 = ServantErr { errHTTPCode = 414- , errReasonPhrase = "Request-URI Too Large"- , errBody = ""- , errHeaders = []- }---- | 'err415' Unsupported Media Type------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" }----err415 :: ServantErr-err415 = ServantErr { errHTTPCode = 415- , errReasonPhrase = "Unsupported Media Type"- , errBody = ""- , errHeaders = []- }---- | 'err416' Request range not satisfiable------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." }----err416 :: ServantErr-err416 = ServantErr { errHTTPCode = 416- , errReasonPhrase = "Request range not satisfiable"- , errBody = ""- , errHeaders = []- }---- | 'err417' Expectation Failed------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." }----err417 :: ServantErr-err417 = ServantErr { errHTTPCode = 417- , errReasonPhrase = "Expectation Failed"- , errBody = ""- , errHeaders = []- }---- | 'err418' Expectation Failed------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err418 { errBody = "Apologies, this is not a webserver but a teapot." }----err418 :: ServantErr-err418 = ServantErr { errHTTPCode = 418- , errReasonPhrase = "I'm a teapot"- , errBody = ""- , errHeaders = []- }---- | 'err422' Unprocessable Entity------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err422 { errBody = "I understood your request, but can't process it." }----err422 :: ServantErr-err422 = ServantErr { errHTTPCode = 422- , errReasonPhrase = "Unprocessable Entity"- , errBody = ""- , errHeaders = []- }---- | 'err500' Internal Server Error------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }----err500 :: ServantErr-err500 = ServantErr { errHTTPCode = 500- , errReasonPhrase = "Internal Server Error"- , errBody = ""- , errHeaders = []- }---- | 'err501' Not Implemented------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." }----err501 :: ServantErr-err501 = ServantErr { errHTTPCode = 501- , errReasonPhrase = "Not Implemented"- , errBody = ""- , errHeaders = []- }---- | 'err502' Bad Gateway------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }----err502 :: ServantErr-err502 = ServantErr { errHTTPCode = 502- , errReasonPhrase = "Bad Gateway"- , errBody = ""- , errHeaders = []- }---- | 'err503' Service Unavailable------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." }----err503 :: ServantErr-err503 = ServantErr { errHTTPCode = 503- , errReasonPhrase = "Service Unavailable"- , errBody = ""- , errHeaders = []- }---- | 'err504' Gateway Time-out------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }----err504 :: ServantErr-err504 = ServantErr { errHTTPCode = 504- , errReasonPhrase = "Gateway Time-out"- , errBody = ""- , errHeaders = []- }---- | 'err505' HTTP Version not supported------ Example usage:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." }----err505 :: ServantErr-err505 = ServantErr { errHTTPCode = 505- , errReasonPhrase = "HTTP Version not supported"- , errBody = ""- , errHeaders = []- }
+ src/Servant/Server/Internal/ServerError.hs view
@@ -0,0 +1,477 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Servant.Server.Internal.ServerError where++import Control.Exception+ (Exception)+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Typeable+ (Typeable)+import qualified Network.HTTP.Types as HTTP+import Network.Wai+ (Response, responseLBS)++data ServerError = ServerError+ { errHTTPCode :: Int+ , errReasonPhrase :: String+ , errBody :: LBS.ByteString+ , errHeaders :: [HTTP.Header]+ }+ deriving (Show, Eq, Read, Typeable)++instance Exception ServerError++responseServerError :: ServerError -> Response+responseServerError ServerError{..} = responseLBS status errHeaders errBody+ where+ status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)++-- | 'err300' Multiple Choices+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err300 { errBody = "I can't choose." }+--+err300 :: ServerError+err300 = ServerError { errHTTPCode = 300+ , errReasonPhrase = "Multiple Choices"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err301' Moved Permanently+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err301+--+err301 :: ServerError+err301 = ServerError { errHTTPCode = 301+ , errReasonPhrase = "Moved Permanently"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err302' Found+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err302+--+err302 :: ServerError+err302 = ServerError { errHTTPCode = 302+ , errReasonPhrase = "Found"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err303' See Other+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err303+--+err303 :: ServerError+err303 = ServerError { errHTTPCode = 303+ , errReasonPhrase = "See Other"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err304' Not Modified+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err304+--+err304 :: ServerError+err304 = ServerError { errHTTPCode = 304+ , errReasonPhrase = "Not Modified"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err305' Use Proxy+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err305+--+err305 :: ServerError+err305 = ServerError { errHTTPCode = 305+ , errReasonPhrase = "Use Proxy"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err307' Temporary Redirect+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err307+--+err307 :: ServerError+err307 = ServerError { errHTTPCode = 307+ , errReasonPhrase = "Temporary Redirect"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err400' Bad Request+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." }+--+err400 :: ServerError+err400 = ServerError { errHTTPCode = 400+ , errReasonPhrase = "Bad Request"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err401' Unauthorized+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." }+--+err401 :: ServerError+err401 = ServerError { errHTTPCode = 401+ , errReasonPhrase = "Unauthorized"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err402' Payment Required+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." }+--+err402 :: ServerError+err402 = ServerError { errHTTPCode = 402+ , errReasonPhrase = "Payment Required"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err403' Forbidden+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err403 { errBody = "Please login first." }+--+err403 :: ServerError+err403 = ServerError { errHTTPCode = 403+ , errReasonPhrase = "Forbidden"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err404' Not Found+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." }+--+err404 :: ServerError+err404 = ServerError { errHTTPCode = 404+ , errReasonPhrase = "Not Found"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err405' Method Not Allowed+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }+--+err405 :: ServerError+err405 = ServerError { errHTTPCode = 405+ , errReasonPhrase = "Method Not Allowed"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err406' Not Acceptable+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err406+--+err406 :: ServerError+err406 = ServerError { errHTTPCode = 406+ , errReasonPhrase = "Not Acceptable"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err407' Proxy Authentication Required+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err407+--+err407 :: ServerError+err407 = ServerError { errHTTPCode = 407+ , errReasonPhrase = "Proxy Authentication Required"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err409' Conflict+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }+--+err409 :: ServerError+err409 = ServerError { errHTTPCode = 409+ , errReasonPhrase = "Conflict"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err410' Gone+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }+--+err410 :: ServerError+err410 = ServerError { errHTTPCode = 410+ , errReasonPhrase = "Gone"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err411' Length Required+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err411+--+err411 :: ServerError+err411 = ServerError { errHTTPCode = 411+ , errReasonPhrase = "Length Required"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err412' Precondition Failed+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }+--+err412 :: ServerError+err412 = ServerError { errHTTPCode = 412+ , errReasonPhrase = "Precondition Failed"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err413' Request Entity Too Large+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." }+--+err413 :: ServerError+err413 = ServerError { errHTTPCode = 413+ , errReasonPhrase = "Request Entity Too Large"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err414' Request-URI Too Large+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." }+--+err414 :: ServerError+err414 = ServerError { errHTTPCode = 414+ , errReasonPhrase = "Request-URI Too Large"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err415' Unsupported Media Type+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" }+--+err415 :: ServerError+err415 = ServerError { errHTTPCode = 415+ , errReasonPhrase = "Unsupported Media Type"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err416' Request range not satisfiable+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." }+--+err416 :: ServerError+err416 = ServerError { errHTTPCode = 416+ , errReasonPhrase = "Request range not satisfiable"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err417' Expectation Failed+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." }+--+err417 :: ServerError+err417 = ServerError { errHTTPCode = 417+ , errReasonPhrase = "Expectation Failed"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err418' Expectation Failed+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err418 { errBody = "Apologies, this is not a webserver but a teapot." }+--+err418 :: ServerError+err418 = ServerError { errHTTPCode = 418+ , errReasonPhrase = "I'm a teapot"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err422' Unprocessable Entity+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err422 { errBody = "I understood your request, but can't process it." }+--+err422 :: ServerError+err422 = ServerError { errHTTPCode = 422+ , errReasonPhrase = "Unprocessable Entity"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err500' Internal Server Error+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }+--+err500 :: ServerError+err500 = ServerError { errHTTPCode = 500+ , errReasonPhrase = "Internal Server Error"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err501' Not Implemented+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." }+--+err501 :: ServerError+err501 = ServerError { errHTTPCode = 501+ , errReasonPhrase = "Not Implemented"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err502' Bad Gateway+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }+--+err502 :: ServerError+err502 = ServerError { errHTTPCode = 502+ , errReasonPhrase = "Bad Gateway"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err503' Service Unavailable+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." }+--+err503 :: ServerError+err503 = ServerError { errHTTPCode = 503+ , errReasonPhrase = "Service Unavailable"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err504' Gateway Time-out+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }+--+err504 :: ServerError+err504 = ServerError { errHTTPCode = 504+ , errReasonPhrase = "Gateway Time-out"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err505' HTTP Version not supported+--+-- Example usage:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." }+--+err505 :: ServerError+err505 = ServerError { errHTTPCode = 505+ , errReasonPhrase = "HTTP Version not supported"+ , errBody = ""+ , errHeaders = []+ }
test/Servant/Server/Internal/RoutingApplicationSpec.hs view
@@ -23,7 +23,7 @@ import Network.Wai (defaultRequest) import Servant-import Servant.Server.Internal.RoutingApplication+import Servant.Server.Internal import Test.Hspec import Test.Hspec.Wai (request, shouldRespondWith, with)
test/Servant/Server/RouterSpec.hs view
@@ -30,20 +30,45 @@ routerSpec :: Spec routerSpec = do- let app' :: Application- app' = toApplication $ runRouter router'+ describe "tweakResponse" $ do+ let app' :: Application+ app' = toApplication $ runRouter router' - router', router :: Router ()- router' = tweakResponse (fmap twk) router- router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")+ router', router :: Router ()+ router' = tweakResponse (fmap 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+ 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+ with (return app') $ do+ it "calls f on route result" $ do+ get "" `shouldRespondWith` 202++ describe "runRouter" $ do+ let toApp :: Router () -> Application+ toApp = toApplication . runRouter++ cap :: Router ()+ cap = CaptureRouter $+ let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)+ in leafRouter+ $ \env req res ->+ runAction delayed env req res+ . const+ $ Route success++ router :: Router ()+ router = leafRouter (\_ _ res -> res $ Route success)+ `Choice` cap++ success :: Response+ success = responseBuilder (Status 200 "") [] ""++ with (pure $ toApp router) $ do+ it "capture failure returns a 400 response" $ do+ get "/badcapture" `shouldRespondWith` 400 distributivitySpec :: Spec distributivitySpec =