servant-server 0.9.1.1 → 0.10
raw patch · 18 files changed
+856/−186 lines, 18 filesdep +monad-controldep +resourcetdep +transformers-basedep ~aesondep ~exceptionsdep ~hspec-waibuild-type:Customsetup-changednew-uploader
Dependencies added: monad-control, resourcet, transformers-base
Dependency ranges changed: aeson, exceptions, hspec-wai, servant
Files
- CHANGELOG.md +30/−0
- Setup.hs +0/−2
- Setup.lhs +165/−0
- servant-server.cabal +20/−10
- src/Servant/Server.hs +2/−1
- src/Servant/Server/Experimental/Auth.hs +2/−3
- src/Servant/Server/Internal.hs +65/−34
- src/Servant/Server/Internal/Handler.hs +41/−0
- src/Servant/Server/Internal/RoutingApplication.hs +151/−58
- src/Servant/Server/Internal/ServantErr.hs +14/−3
- src/Servant/Utils/StaticFiles.hs +54/−13
- test/Doctests.hs +0/−41
- test/Servant/Server/ErrorSpec.hs +31/−12
- test/Servant/Server/Internal/RoutingApplicationSpec.hs +141/−0
- test/Servant/Server/RouterSpec.hs +15/−0
- test/Servant/ServerSpec.hs +62/−7
- test/Servant/Utils/StaticFilesSpec.hs +2/−2
- test/doctests.hsc +61/−0
CHANGELOG.md view
@@ -1,3 +1,33 @@+0.10+----++### Breaking changes++* `Handler` is now an abstract datatype. Migration hint: change `throwE` to `throwError`.+ ([#641](https://github.com/haskell-servant/servant/issues/641))++* Changed `HasServer` instances for `QueryParam` and `QueryParam` to throw 400+ when parsing fails+ ([#649](https://github.com/haskell-servant/servant/pull/649))++### Other changes++* Added `paramD` block to `Delayed`++* Add `err422` Unprocessable Entity+ ([#646](https://github.com/haskell-servant/servant/pull/646))++* Deprecate `serveDirectory` and introduce `serveDirectoryFileServer`,+ `serveDirectoryWebApp`, `serveDirectoryWebAppLookup`, `serveDirectoryEmbedded`+ and `serveDirectoryWith` which offer 4 default options and a more flexible+ one for serving static files.+ ([#658](https://github.com/haskell-servant/servant/pull/658))++* `DelayedIO` is an instance of `MonadResource`, allowing safe resource handling.+ ([#622](https://github.com/haskell-servant/servant/pull/622)+ , [#674](https://github.com/haskell-servant/servant/pull/674)+ , [#675](https://github.com/haskell-servant/servant/pull/675))+ 0.7.1 ------
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,165 @@+\begin{code}+{-# LANGUAGE CPP #-}+#ifndef MIN_VERSION_Cabal+#define MIN_VERSION_Cabal(x,y,z) 0+#endif+#ifndef MIN_VERSION_directory+#define MIN_VERSION_directory(x,y,z) 0+#endif+#if MIN_VERSION_Cabal(1,24,0)+#define InstalledPackageId UnitId+#endif+module Main (main) where++import Control.Monad ( when )+import Data.List ( nub )+import Distribution.Package ( InstalledPackageId )+import Distribution.Package ( PackageId, Package (..), packageVersion )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..))+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildDistPref, buildVerbosity), fromFlag)+import Distribution.Simple.LocalBuildInfo ( withPackageDB, withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps), compiler )+import Distribution.Simple.Compiler ( showCompilerId , PackageDB (..))+import Distribution.Text ( display , simpleParse )+import System.FilePath ( (</>) )++#if MIN_VERSION_Cabal(1,25,0)+import Distribution.Simple.BuildPaths ( autogenComponentModulesDir )+#endif++#if MIN_VERSION_directory(1,2,2)+import System.Directory (makeAbsolute)+#else+import System.Directory (getCurrentDirectory)+import System.FilePath (isAbsolute)++makeAbsolute :: FilePath -> IO FilePath+makeAbsolute p | isAbsolute p = return p+ | otherwise = do+ cwd <- getCurrentDirectory+ return $ cwd </> p+#endif++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+ { buildHook = \pkg lbi hooks flags -> do+ generateBuildModule flags pkg lbi+ buildHook simpleUserHooks pkg lbi hooks flags+ }++generateBuildModule :: BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule flags pkg lbi = do+ let verbosity = fromFlag (buildVerbosity flags)+ let distPref = fromFlag (buildDistPref flags)++ -- Package DBs+ let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]+ let dbFlags = "-hide-all-packages" : packageDbArgs dbStack++ withLibLBI pkg lbi $ \lib libcfg -> do+ let libBI = libBuildInfo lib++ -- modules+ let modules = exposedModules lib ++ otherModules libBI+ -- it seems that doctest is happy to take in module names, not actual files!+ let module_sources = modules++ -- We need the directory with library's cabal_macros.h!+#if MIN_VERSION_Cabal(1,25,0)+ let libAutogenDir = autogenComponentModulesDir lbi libcfg+#else+ let libAutogenDir = autogenModulesDir lbi+#endif++ -- Lib sources and includes+ iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ libAutogenDir : hsSourceDirs libBI+ includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI++ -- CPP includes, i.e. include cabal_macros.h+ let cppFlags = map ("-optP"++) $+ [ "-include", libAutogenDir ++ "/cabal_macros.h" ]+ ++ cppOptions libBI++ -- Actually we need to check whether testName suite == "doctests"+ -- pending https://github.com/haskell/cabal/pull/4229 getting into GHC HEAD tree+ withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == "doctests") $ do++ -- get and create autogen dir+#if MIN_VERSION_Cabal(1,25,0)+ let testAutogenDir = autogenComponentModulesDir lbi suitecfg+#else+ let testAutogenDir = autogenModulesDir lbi+#endif+ createDirectoryIfMissingVerbose verbosity True testAutogenDir++ -- write autogen'd file+ rewriteFile (testAutogenDir </> "Build_doctests.hs") $ unlines+ [ "module Build_doctests where"+ , ""+ -- -package-id etc. flags+ , "pkgs :: [String]"+ , "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg)+ , ""+ , "flags :: [String]"+ , "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags)+ , ""+ , "module_sources :: [String]"+ , "module_sources = " ++ show (map display module_sources)+ ]+ where+ -- we do this check in Setup, as then doctests don't need to depend on Cabal+ isOldCompiler = maybe False id $ do+ a <- simpleParse $ showCompilerId $ compiler lbi+ b <- simpleParse "7.5"+ return $ packageVersion (a :: PackageId) < b++ formatDeps = map formatOne+ formatOne (installedPkgId, pkgId)+ -- The problem is how different cabal executables handle package databases+ -- when doctests depend on the library+ | packageId pkg == pkgId = "-package=" ++ display pkgId+ | otherwise = "-package-id=" ++ display installedPkgId++ -- From Distribution.Simple.Program.GHC+ packageDbArgs :: [PackageDB] -> [String]+ packageDbArgs | isOldCompiler = packageDbArgsConf+ | otherwise = packageDbArgsDb++ -- GHC <7.6 uses '-package-conf' instead of '-package-db'.+ packageDbArgsConf :: [PackageDB] -> [String]+ packageDbArgsConf dbstack = case dbstack of+ (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs+ (GlobalPackageDB:dbs) -> ("-no-user-package-conf")+ : concatMap specific dbs+ _ -> ierror+ where+ specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ]+ specific _ = ierror+ ierror = error $ "internal error: unexpected package db stack: "+ ++ show dbstack++ -- GHC >= 7.6 uses the '-package-db' flag. See+ -- https://ghc.haskell.org/trac/ghc/ticket/5977.+ packageDbArgsDb :: [PackageDB] -> [String]+ -- special cases to make arguments prettier in common scenarios+ packageDbArgsDb dbstack = case dbstack of+ (GlobalPackageDB:UserPackageDB:dbs)+ | all isSpecific dbs -> concatMap single dbs+ (GlobalPackageDB:dbs)+ | all isSpecific dbs -> "-no-user-package-db"+ : concatMap single dbs+ dbs -> "-clear-package-db"+ : concatMap single dbs+ where+ single (SpecificPackageDB db) = [ "-package-db=" ++ db ]+ single GlobalPackageDB = [ "-global-package-db" ]+ single UserPackageDB = [ "-user-package-db" ]+ isSpecific (SpecificPackageDB _) = True+ isSpecific _ = False++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++\end{code}
servant-server.cabal view
@@ -1,5 +1,5 @@ name: servant-server-version: 0.9.1.1+version: 0.10 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them@@ -18,8 +18,8 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors-category: Web-build-type: Simple+category: Servant Web+build-type: Custom cabal-version: >=1.10 tested-with: GHC >= 7.8 extra-source-files:@@ -31,6 +31,9 @@ type: git location: http://github.com/haskell-servant/servant.git +custom-setup+ setup-depends:+ Cabal >=1.14, base, filepath, directory library exposed-modules:@@ -40,6 +43,7 @@ Servant.Server.Internal Servant.Server.Internal.BasicAuth Servant.Server.Internal.Context+ Servant.Server.Internal.Handler Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServantErr@@ -47,24 +51,28 @@ build-depends: base >= 4.7 && < 4.10 , base-compat >= 0.9 && < 0.10- , aeson >= 0.7 && < 1.1+ , aeson >= 0.7 && < 1.2 , attoparsec >= 0.12 && < 0.14 , base64-bytestring >= 1.0 && < 1.1 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6+ , exceptions >= 0.8 && < 0.9 , http-api-data >= 0.3 && < 0.4 , http-types >= 0.8 && < 0.10 , network-uri >= 2.6 && < 2.7+ , monad-control >= 1.0.0.4 && < 1.1 , mtl >= 2 && < 2.3 , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4- , servant == 0.9.*+ , servant == 0.10.* , split >= 0.2 && < 0.3 , string-conversions >= 0.3 && < 0.5 , system-filepath >= 0.4 && < 0.5 , filepath >= 1 && < 1.5+ , resourcet >= 1.1.6 && <1.2 , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6+ , transformers-base >= 0.4.4 && < 0.5 , transformers-compat>= 0.4 && < 0.6 , wai >= 3.0 && < 3.3 , wai-app-static >= 3.1 && < 3.2@@ -102,6 +110,7 @@ Servant.ArbitraryMonadServerSpec Servant.Server.ErrorSpec Servant.Server.Internal.ContextSpec+ Servant.Server.Internal.RoutingApplicationSpec Servant.Server.RouterSpec Servant.Server.StreamingSpec Servant.Server.UsingContextSpec@@ -117,21 +126,22 @@ , directory , exceptions , hspec == 2.*- , hspec-wai+ , hspec-wai >= 0.8 && <0.9 , http-types+ , mtl , network >= 2.6- , QuickCheck , parsec+ , QuickCheck+ , resourcet , safe , servant , servant-server- , string-conversions , should-not-typecheck == 2.1.*+ , string-conversions , temporary , text , transformers , transformers-compat- , mtl , wai , wai-extra , warp@@ -144,7 +154,7 @@ , directory , filepath type: exitcode-stdio-1.0- main-is: test/Doctests.hs+ main-is: test/doctests.hs buildable: True default-language: Haskell2010 ghc-options: -Wall -threaded
src/Servant/Server.hs view
@@ -17,7 +17,8 @@ , -- * Handlers for all standard combinators HasServer(..) , Server- , Handler+ , Handler (..)+ , runHandler -- * Debugging the server layout , layout
src/Servant/Server/Experimental/Auth.hs view
@@ -13,7 +13,6 @@ module Servant.Server.Experimental.Auth where import Control.Monad.Trans (liftIO)-import Control.Monad.Trans.Except (runExceptT) import Data.Proxy (Proxy (Proxy)) import Data.Typeable (Typeable) import GHC.Generics (Generic)@@ -29,7 +28,7 @@ delayedFailFatal, DelayedIO, withRequest)-import Servant.Server.Internal.ServantErr (Handler)+import Servant.Server.Internal.Handler (Handler, runHandler) -- * General Auth @@ -65,4 +64,4 @@ authHandler :: Request -> Handler (AuthServerData (AuthProtect tag)) authHandler = unAuthHandler (getContextEntry context) authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag))- authCheck = (>>= either delayedFailFatal return) . liftIO . runExceptT . authHandler+ authCheck = (>>= either delayedFailFatal return) . liftIO . runHandler . authHandler
src/Servant/Server/Internal.hs view
@@ -17,18 +17,22 @@ ( module Servant.Server.Internal , module Servant.Server.Internal.Context , module Servant.Server.Internal.BasicAuth+ , module Servant.Server.Internal.Handler , module Servant.Server.Internal.Router , module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.ServantErr ) where import Control.Monad.Trans (liftIO)+import Control.Monad.Trans.Resource (runResourceT) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL import Data.Maybe (fromMaybe, mapMaybe)+import Data.Either (partitionEithers) import Data.String (fromString) import Data.String.Conversions (cs, (<>))+import qualified Data.Text as T import Data.Typeable import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal)@@ -43,7 +47,7 @@ import Prelude () import Prelude.Compat import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe,- parseQueryParamMaybe,+ parseQueryParam, parseUrlPieceMaybe, parseUrlPieces) import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,@@ -63,6 +67,7 @@ import Servant.Server.Internal.Context import Servant.Server.Internal.BasicAuth+import Servant.Server.Internal.Handler import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr@@ -308,14 +313,22 @@ Maybe a -> ServerT api m 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- -- the right type- in route (Proxy :: Proxy api) context (passToServer subserver param)+ let querytext req = parseQueryText $ rawQueryString req+ parseParam req =+ case lookup paramname (querytext req) of+ Nothing -> return Nothing -- param absent from the query string+ Just Nothing -> return Nothing -- param present with no value -> Nothing+ Just (Just v) ->+ case parseQueryParam v of+ Left e -> delayedFailFatal err400+ { errBody = cs $ "Error parsing query parameter " <> paramname <> " failed: " <> e+ }++ Right param -> return $ Just param+ delayed = addParameterCheck subserver . withRequest $ \req ->+ parseParam req++ in route (Proxy :: Proxy api) context delayed where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,@@ -343,19 +356,26 @@ type ServerT (QueryParams sym a :> api) m = [a] -> ServerT api m - 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 r = filter looksLikeParam (querytext r)- values r = mapMaybe (convert . snd) (parameters r)- in route (Proxy :: Proxy api) context (passToServer subserver values)- where paramname = cs $ symbolVal (Proxy :: Proxy sym)- looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")- convert Nothing = Nothing- convert (Just v) = parseQueryParamMaybe v+ route Proxy context subserver = route (Proxy :: Proxy api) context $+ subserver `addParameterCheck` withRequest paramsCheck+ where+ paramname = cs $ symbolVal (Proxy :: Proxy sym)+ paramsCheck req =+ case partitionEithers $ fmap parseQueryParam params of+ ([], parsed) -> return parsed+ (errs, _) -> delayedFailFatal err400+ { errBody = cs $ "Error parsing query parameter(s) " <> paramname <> " failed: " <> T.intercalate ", " errs+ }+ where+ params :: [T.Text]+ params = mapMaybe snd+ . filter (looksLikeParam . fst)+ . parseQueryText+ . rawQueryString+ $ req + looksLikeParam name = name == paramname || name == (paramname <> "[]")+ -- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type 'Bool'.@@ -397,13 +417,18 @@ type ServerT Raw m = Application - route Proxy _ rawApplication = RawRouter $ \ env request respond -> do+ route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do+ -- note: a Raw application doesn't register any cleanup+ -- but for the sake of consistency, we nonetheless run+ -- the cleanup once its done r <- runDelayed rawApplication env request- case r of- Route app -> app request (respond . Route)- Fail a -> respond $ Fail a- FailFatal e -> respond $ FailFatal e+ liftIO $ go r request respond + where go r request respond = case r of+ Route app -> app request (respond . Route)+ Fail a -> respond $ Fail a+ FailFatal e -> respond $ FailFatal e+ -- | If you use 'ReqBody' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by 'ReqBody'.@@ -431,22 +456,28 @@ type ServerT (ReqBody list a :> api) m = a -> ServerT api m - route Proxy context subserver =- route (Proxy :: Proxy api) context (addBodyCheck subserver bodyCheck)+ route Proxy context subserver+ = route (Proxy :: Proxy api) context $+ addBodyCheck subserver ctCheck bodyCheck where- bodyCheck = withRequest $ \ request -> do+ -- Content-Type check, we only lookup we can try to parse the request body+ ctCheck = 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" -- http://www.w3.org/2001/tag/2002/0129-mime let contentTypeH = fromMaybe "application/octet-stream" $ lookup hContentType $ requestHeaders request- mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)- <$> liftIO (lazyRequestBody request)+ case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of+ Nothing -> delayedFailFatal err415+ Just f -> return f++ -- Body check, we get a body parsing functions as the first argument.+ bodyCheck f = withRequest $ \ request -> do+ mrqbody <- f <$> liftIO (lazyRequestBody request) case mrqbody of- Nothing -> delayedFailFatal err415- Just (Left e) -> delayedFailFatal err400 { errBody = cs e }- Just (Right v) -> return v+ Left e -> delayedFailFatal err400 { errBody = cs e }+ Right v -> return v -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @api@.
+ src/Servant/Server/Internal/Handler.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Servant.Server.Internal.Handler where++import Prelude ()+import Prelude.Compat++import Control.Monad.Base (MonadBase (..))+import Control.Monad.Catch (MonadCatch, MonadThrow)+import Control.Monad.Error.Class (MonadError)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Control (MonadBaseControl (..))+import Control.Monad.Trans.Except (ExceptT, runExceptT)+import GHC.Generics (Generic)+import Servant.Server.Internal.ServantErr (ServantErr)++newtype Handler a = Handler { runHandler' :: ExceptT ServantErr IO a }+ deriving+ ( Functor, Applicative, Monad, MonadIO, Generic+ , MonadError ServantErr+ , MonadThrow, MonadCatch+ )++instance MonadBase IO Handler where+ liftBase = Handler . liftBase++instance MonadBaseControl IO Handler where+ type StM Handler a = Either ServantErr a++ -- liftBaseWith :: (RunInBase Handler IO -> IO a) -> Handler a+ liftBaseWith f = Handler (liftBaseWith (\g -> f (g . runHandler')))++ -- restoreM :: StM Handler a -> Handler a+ restoreM st = Handler (restoreM st)++runHandler :: Handler a -> IO (Either ServantErr a)+runHandler = runExceptT . runHandler'
src/Servant/Server/Internal/RoutingApplication.hs view
@@ -1,20 +1,31 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.RoutingApplication where import Control.Monad (ap, liftM)-import Control.Monad.Trans (MonadIO(..))-import Control.Monad.Trans.Except (runExceptT)-import Network.Wai (Application, Request,- Response, ResponseReceived)+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, runResourceT, transResourceT)+import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude () import Prelude.Compat+import Servant.Server.Internal.Handler import Servant.Server.Internal.ServantErr type RoutingApplication =@@ -29,6 +40,55 @@ | 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@@ -72,14 +132,14 @@ -- 405 (bad method) -- 401 (unauthorized) -- 415 (unsupported media type)--- 400 (bad request) -- 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 three delayed blocks of tests, and+-- A 'Delayed' contains many delayed blocks of tests, and -- the actual handler: -- -- 1. Delayed captures. These can actually cause 404, and@@ -92,23 +152,36 @@ -- it does not provide an input for the handler. Method checks -- are comparatively cheap. ----- 3. Body and accept header checks. The request body check can--- cause both 400 and 415. This provides an input to the handler.--- The accept header check can be performed as the final--- computation in this block. It can cause a 406.+-- 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. Body check. The request body check can cause 400.+-- 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+ , acceptD :: DelayedIO ()+ , contentD :: DelayedIO contentType+ , paramsD :: DelayedIO params+ , bodyD :: contentType -> DelayedIO body+ , serverD :: captures+ -> params+ -> auth+ -> body+ -> Request+ -> RouteResult c } -> Delayed env c instance Functor (Delayed env) where fmap f Delayed{..} = Delayed- { serverD = \ c a b req -> f <$> serverD c a b req+ { serverD = \ c p a b req -> f <$> serverD c p a b req , .. } -- Note [Existential Record Update] @@ -117,46 +190,46 @@ -- '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+newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }+ deriving+ ( Functor, Applicative, Monad+ , MonadIO, MonadReader Request+ , MonadBase IO+ , MonadThrow+ , MonadResource+ ) -instance Applicative DelayedIO where- pure = return- (<*>) = ap+liftRouteResult :: RouteResult a -> DelayedIO a+liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x -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 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 -instance MonadIO DelayedIO where- liftIO m = DelayedIO (const $ Route <$> m)+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 (\ _ _ _ _ -> result)+ Delayed (const r) r r r r r (const r) (\ _ _ _ _ _ -> result) where r = return () -- | Fail with the option to recover. delayedFail :: ServantErr -> DelayedIO a-delayedFail err = DelayedIO (const $ return $ Fail err)+delayedFail err = liftRouteResult $ Fail err -- | Fail fatally, i.e., without any option to recover. delayedFailFatal :: ServantErr -> DelayedIO a-delayedFailFatal err = DelayedIO (const $ return $ FailFatal err)+delayedFailFatal err = liftRouteResult $ FailFatal err -- | Gain access to the incoming request. withRequest :: (Request -> DelayedIO a) -> DelayedIO a-withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)+withRequest f = do+ req <- ask+ f req -- | Add a capture to the end of the capture block. addCapture :: Delayed env (a -> b)@@ -165,10 +238,21 @@ addCapture Delayed{..} new = Delayed { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt- , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req+ , serverD = \ (x, v) p a b req -> ($ v) <$> serverD x p 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) a b req -> ($ pNew) <$> serverD c p a b req+ , ..+ }+ -- | Add a method check to the end of the method block. addMethodCheck :: Delayed env a -> DelayedIO ()@@ -186,24 +270,29 @@ addAuthCheck Delayed{..} new = Delayed { authD = (,) <$> authD <*> new- , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req+ , serverD = \ c p (y, v) b req -> ($ v) <$> serverD c p y b req , .. } -- Note [Existential Record Update] --- | Add a body check to the end of the body block.+-- | 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 a+ -> DelayedIO c -- ^ content type check+ -> (c -> DelayedIO a) -- ^ body check -> Delayed env b-addBodyCheck Delayed{..} new =+addBodyCheck Delayed{..} newContentD newBodyD = Delayed- { bodyD = (,) <$> bodyD <*> new- , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req+ { contentD = (,) <$> contentD <*> newContentD+ , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c+ , serverD = \ c p a (z, v) req -> ($ v) <$> serverD c p a z req , .. } -- 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+-- | 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.@@ -217,7 +306,7 @@ -> Delayed env a addAcceptCheck Delayed{..} new = Delayed- { bodyD = new *> bodyD+ { acceptD = acceptD *> new , .. } -- Note [Existential Record Update] @@ -227,7 +316,7 @@ 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+ { serverD = \ c p a b req -> ($ x req) <$> serverD c p a b req , .. } -- Note [Existential Record Update] @@ -240,13 +329,17 @@ runDelayed :: Delayed env a -> env -> Request- -> IO (RouteResult a)+ -> ResourceT IO (RouteResult a) runDelayed Delayed{..} env = runDelayedIO $ do- c <- capturesD env- methodD- a <- authD- b <- bodyD- DelayedIO (\ req -> return $ serverD c a b req)+ r <- ask+ c <- capturesD env+ methodD+ a <- authD+ acceptD+ content <- contentD+ p <- paramsD -- Has to be before body parsing, but after content-type checks+ b <- bodyD content+ liftRouteResult (serverD c p a b r) -- | Runs a delayed server and the resulting action. -- Takes a continuation that lets us send a response.@@ -258,13 +351,13 @@ -> (RouteResult Response -> IO r) -> (a -> RouteResult Response) -> IO r-runAction action env req respond k =- runDelayed action env req >>= go >>= respond+runAction action env req respond k = runResourceT $ do+ runDelayed action env req >>= go >>= liftIO . respond where go (Fail e) = return $ Fail e go (FailFatal e) = return $ FailFatal e- go (Route a) = do- e <- runExceptT a+ go (Route a) = liftIO $ do+ e <- runHandler a case e of Left err -> return . Route $ responseServantErr err Right x -> return $! k x
src/Servant/Server/Internal/ServantErr.hs view
@@ -4,7 +4,6 @@ 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)@@ -19,8 +18,6 @@ instance Exception ServantErr -type Handler = ExceptT ServantErr IO- responseServantErr :: ServantErr -> Response responseServantErr ServantErr{..} = responseLBS status errHeaders errBody where@@ -372,6 +369,20 @@ 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 = [] }
src/Servant/Utils/StaticFiles.hs view
@@ -1,20 +1,29 @@ {-# LANGUAGE CPP #-}--- | This module defines a sever-side handler that lets you serve static files.+-- | This module defines server-side handlers that lets you serve static files. ----- - 'serveDirectory' lets you serve anything that lives under a particular--- directory on your filesystem.-module Servant.Utils.StaticFiles (- serveDirectory,- ) where+-- The most common needs for a web application are covered by+-- 'serveDirectoryWebApp`, but the other variants allow you to use+-- different `StaticSettings` and 'serveDirectoryWith' even allows you+-- to specify arbitrary 'StaticSettings' to be used for serving static files.+module Servant.Utils.StaticFiles+ ( serveDirectoryWebApp+ , serveDirectoryWebAppLookup+ , serveDirectoryFileServer+ , serveDirectoryEmbedded+ , serveDirectoryWith+ , -- * Deprecated+ serveDirectory+ ) where -import Network.Wai.Application.Static (defaultFileServerSettings,- staticApp)+import Data.ByteString (ByteString)+import Network.Wai.Application.Static import Servant.API.Raw (Raw) import Servant.Server (Server) import System.FilePath (addTrailingPathSeparator) #if !MIN_VERSION_wai_app_static(3,1,0) import Filesystem.Path.CurrentOS (decodeString) #endif+import WaiAppStatic.Storage.Filesystem (ETagLookup) -- | Serve anything under the specified directory as a 'Raw' endpoint. --@@ -22,7 +31,7 @@ -- type MyApi = "static" :> Raw -- -- server :: Server MyApi--- server = serveDirectory "\/var\/www"+-- server = serveDirectoryWebApp "\/var\/www" -- @ -- -- would capture any request to @\/static\/\<something>@ and look for@@ -33,13 +42,45 @@ -- -- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API -- as a webapp backend, you will most likely not want the static files to be hidden--- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectory'+-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectoryWebApp' -- handler in the last position, because /servant/ will try to match the handlers -- in order.+--+-- Corresponds to the `defaultWebAppSettings` `StaticSettings` value.+serveDirectoryWebApp :: FilePath -> Server Raw+serveDirectoryWebApp = staticApp . defaultWebAppSettings . fixPath++-- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`.+serveDirectoryFileServer :: FilePath -> Server Raw+serveDirectoryFileServer = staticApp . defaultFileServerSettings . fixPath++-- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'.+serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> Server Raw+serveDirectoryWebAppLookup etag =+ staticApp . flip webAppSettingsWithLookup etag . fixPath++-- | Uses 'embeddedSettings'.+serveDirectoryEmbedded :: [(FilePath, ByteString)] -> Server Raw+serveDirectoryEmbedded files = staticApp (embeddedSettings files)++-- | Alias for 'staticApp'. Lets you serve a directory+-- with arbitrary 'StaticSettings'. Useful when you want+-- particular settings not covered by the four other+-- variants. This is the most flexible method.+serveDirectoryWith :: StaticSettings -> Server Raw+serveDirectoryWith = staticApp++-- | Same as 'serveDirectoryFileServer'. It used to be the only+-- file serving function in servant pre-0.10 and will be kept+-- around for a few versions, but is deprecated. serveDirectory :: FilePath -> Server Raw-serveDirectory =+serveDirectory = serveDirectoryFileServer+{-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-}++fixPath :: FilePath -> FilePath+fixPath = #if MIN_VERSION_wai_app_static(3,1,0)- staticApp . defaultFileServerSettings . addTrailingPathSeparator+ addTrailingPathSeparator #else- staticApp . defaultFileServerSettings . decodeString . addTrailingPathSeparator+ decodeString . addTrailingPathSeparator #endif
− test/Doctests.hs
@@ -1,41 +0,0 @@-module Main where--import Data.List (isPrefixOf)-import System.Directory-import System.FilePath-import System.FilePath.Find-import Test.DocTest--main :: IO ()-main = do- files <- find always (extension ==? ".hs") "src"- mCabalMacrosFile <- getCabalMacrosFile- doctest $ "-isrc" : "-Iinclude" :- (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++- "-XOverloadedStrings" :- "-XFlexibleInstances" :- "-XMultiParamTypeClasses" :- "-XDataKinds" :- "-XTypeOperators" :- files--getCabalMacrosFile :: IO (Maybe FilePath)-getCabalMacrosFile = do- exists <- doesDirectoryExist "dist"- if exists- then do- contents <- getDirectoryContents "dist"- let rest = "build" </> "autogen" </> "cabal_macros.h"- whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of- [x] -> "dist" </> x </> rest- [] -> "dist" </> rest- xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"- ++ show xs ++ "\nTry cabal clean"- else return Nothing- where- whenExists :: FilePath -> IO (Maybe FilePath)- whenExists file = do- exists <- doesFileExist file- return $ if exists- then Just file- else Nothing
test/Servant/Server/ErrorSpec.hs view
@@ -6,10 +6,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Server.ErrorSpec (spec) where -import Control.Monad.Trans.Except (throwE)+import Control.Monad (when) import Data.Aeson (encode) import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BCL+import Data.Monoid ((<>)) import Data.Proxy import Network.HTTP.Types (hAccept, hAuthorization, hContentType, methodGet,@@ -45,13 +46,14 @@ :> BasicAuth "error-realm" () :> ReqBody '[JSON] Int :> Capture "t" Int+ :> QueryParam "param" Int :> Post '[JSON] Int errorOrderApi :: Proxy ErrorOrderApi errorOrderApi = Proxy errorOrderServer :: Server ErrorOrderApi-errorOrderServer = \_ _ _ -> throwE err402+errorOrderServer = \_ _ _ _ -> throwError err402 -- On error priorities: --@@ -86,7 +88,8 @@ goodContentType = (hContentType, "application/json") goodAccept = (hAccept, "application/json") goodMethod = methodPost- goodUrl = "home/2"+ goodUrl = "home/2?param=55"+ badParams = goodUrl <> "?param=foo" goodBody = encode (5 :: Int) -- username:password = servant:server goodAuth = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")@@ -96,25 +99,36 @@ `shouldRespondWith` 404 it "has 405 as its second highest priority error" $ do- request badMethod goodUrl [badAuth, badContentType, badAccept] badBody+ request badMethod badParams [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 405 it "has 401 as its third highest priority error (auth)" $ do- request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody+ request goodMethod badParams [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 401 it "has 406 as its fourth highest priority error" $ do- request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody+ request goodMethod badParams [goodAuth, badContentType, badAccept] badBody `shouldRespondWith` 406 it "has 415 as its fifth highest priority error" $ do- request goodMethod goodUrl [goodAuth, badContentType, goodAccept] badBody+ request goodMethod badParams [goodAuth, badContentType, goodAccept] badBody `shouldRespondWith` 415 it "has 400 as its sixth highest priority error" $ do- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody- `shouldRespondWith` 400+ badParamsRes <- request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody+ badBodyRes <- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody + -- Both bad body and bad params result in 400+ return badParamsRes `shouldRespondWith` 400+ return badBodyRes `shouldRespondWith` 400++ -- Param check should occur before body checks+ both <- request goodMethod badParams [goodAuth, goodContentType, goodAccept ] badBody+ when (both /= badParamsRes) $ liftIO $+ expectationFailure $ "badParams + badBody /= badParams: " ++ show both ++ ", " ++ show badParamsRes+ when (both == badBodyRes) $ liftIO $+ expectationFailure $ "badParams + badBody == badBody: " ++ show both+ it "has handler-level errors as last priority" $ do request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody `shouldRespondWith` 402@@ -187,7 +201,7 @@ errorRetryServer :: Server ErrorRetryApi errorRetryServer- = (\_ -> throwE err402)+ = (\_ -> throwError err402) :<|> (\_ -> return 1) :<|> (\_ -> return 2) :<|> (\_ -> return 3)@@ -211,11 +225,16 @@ it "should continue when URLs don't match" $ do request methodPost "" [jsonCT, jsonAccept] jsonBody- `shouldRespondWith` 200 { matchBody = Just $ encode (8 :: Int) }+ `shouldRespondWith` 200 { matchBody = mkBody $ encode (8 :: Int) } it "should continue when methods don't match" $ do request methodGet "a" [jsonCT, jsonAccept] jsonBody- `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }+ `shouldRespondWith` 200 { matchBody = mkBody $ encode (4 :: Int) }+ where+ mkBody b = MatchBody $ \_ b' ->+ if b == b'+ then Nothing+ else Just "body not correct\n" -- }}} ------------------------------------------------------------------------------
+ test/Servant/Server/Internal/RoutingApplicationSpec.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Servant.Server.Internal.RoutingApplicationSpec (spec) where++import Prelude ()+import Prelude.Compat++import Control.Exception hiding (Handler)+import Control.Monad.Trans.Resource (register)+import Control.Monad.IO.Class+import Data.IORef+import Data.Proxy+import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)+import Servant+import Servant.Server.Internal.RoutingApplication+import Network.Wai (defaultRequest)+import Test.Hspec+import Test.Hspec.Wai (request, shouldRespondWith, with)++import qualified Data.Text as T++import System.IO.Unsafe (unsafePerformIO)++data TestResource x+ = TestResourceNone+ | TestResource x+ | TestResourceFreed+ | TestResourceError+ deriving (Eq, Show)++-- Let's not write to the filesystem+delayedTestRef :: IORef (TestResource String)+delayedTestRef = unsafePerformIO $ newIORef TestResourceNone++fromTestResource :: a -> (b -> a) -> TestResource b -> a+fromTestResource _ f (TestResource x) = f x+fromTestResource x _ _ = x++initTestResource :: IO ()+initTestResource = writeIORef delayedTestRef TestResourceNone++writeTestResource :: String -> IO ()+writeTestResource x = modifyIORef delayedTestRef $ \r -> case r of+ TestResourceNone -> TestResource x+ _ -> TestResourceError++freeTestResource :: IO ()+freeTestResource = modifyIORef delayedTestRef $ \r -> case r of+ TestResource _ -> TestResourceFreed+ _ -> TestResourceError++delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())+delayed body srv = Delayed+ { capturesD = \() -> return ()+ , methodD = return ()+ , authD = return ()+ , acceptD = return ()+ , contentD = return ()+ , paramsD = return ()+ , bodyD = \() -> do+ liftIO (writeTestResource "hia" >> putStrLn "garbage created")+ _ <- register (freeTestResource >> putStrLn "garbage collected")+ body+ , serverD = \() () () _body _req -> srv+ }++simpleRun :: Delayed () (Handler ())+ -> IO ()+simpleRun d = fmap (either ignoreE id) . try $+ runAction d () defaultRequest (\_ -> return ()) (\_ -> FailFatal err500)++ where ignoreE :: SomeException -> ()+ ignoreE = const ()++-------------------------------------------------------------------------------+-- Combinator example+-------------------------------------------------------------------------------++-- | This data types writes 'sym' to 'delayedTestRef'.+data Res (sym :: Symbol)++instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where+ type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m+ route Proxy ctx server = route (Proxy :: Proxy api) ctx $+ addBodyCheck server (return ()) check+ where+ sym = symbolVal (Proxy :: Proxy sym)+ check () = do+ liftIO $ writeTestResource sym+ _ <- register freeTestResource+ return delayedTestRef++type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text++resApi :: Proxy ResApi+resApi = Proxy++resServer :: Server ResApi+resServer ref = liftIO $ fmap (fromTestResource "<wrong>" T.pack) $ readIORef ref++-------------------------------------------------------------------------------+-- Spec+-------------------------------------------------------------------------------++spec :: Spec+spec = do+ describe "Delayed" $ do+ it "actually runs clean up actions" $ do+ liftIO initTestResource+ _ <- simpleRun $ delayed (return ()) (Route $ return ())+ res <- readIORef delayedTestRef+ res `shouldBe` TestResourceFreed+ it "even with exceptions in serverD" $ do+ liftIO initTestResource+ _ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)+ res <- readIORef delayedTestRef+ res `shouldBe` TestResourceFreed+ it "even with routing failure in bodyD" $ do+ liftIO initTestResource+ _ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())+ res <- readIORef delayedTestRef+ res `shouldBe` TestResourceFreed+ it "even with exceptions in bodyD" $ do+ liftIO initTestResource+ _ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())+ res <- readIORef delayedTestRef+ res `shouldBe` TestResourceFreed+ describe "ResApi" $+ with (return $ serve resApi resServer) $ do+ it "writes and cleanups resources" $ do+ liftIO initTestResource+ request "GET" "foobar" [] "" `shouldRespondWith` "foobar"+ liftIO $ do+ res <- readIORef delayedTestRef+ res `shouldBe` TestResourceFreed
test/Servant/Server/RouterSpec.hs view
@@ -49,6 +49,8 @@ dynamic `shouldHaveSameStructureAs` dynamicRef it "properly reorders permuted static paths" $ do permute `shouldHaveSameStructureAs` permuteRef+ it "properly reorders permuted static paths in the presence of QueryParams" $ do+ permuteQuery `shouldHaveSameStructureAs` permuteRef it "properly reorders permuted static paths in the presence of Raw in end" $ do permuteRawEnd `shouldHaveSameStructureAs` permuteRawEndRef it "properly reorders permuted static paths in the presence of Raw in beginning" $ do@@ -153,6 +155,19 @@ permuteRef :: Proxy PermuteRef permuteRef = Proxy++-- Adding a "QueryParam" should not affect structure++type PermuteQuery =+ QueryParam "1" Int :> "a" :> "b" :> "c" :> End+ :<|> QueryParam "2" Int :> "b" :> "a" :> "c" :> End+ :<|> QueryParam "3" Int :> "a" :> "c" :> "b" :> End+ :<|> QueryParam "4" Int :> "c" :> "a" :> "b" :> End+ :<|> QueryParam "5" Int :> "b" :> "c" :> "a" :> End+ :<|> QueryParam "6" Int :> "c" :> "b" :> "a" :> End++permuteQuery :: Proxy PermuteQuery+permuteQuery = Proxy -- Adding a 'Raw' in one of the ends should have minimal -- effect on the grouping.
test/Servant/ServerSpec.hs view
@@ -14,7 +14,7 @@ module Servant.ServerSpec where import Control.Monad (forM_, when, unless)-import Control.Monad.Trans.Except (throwE)+import Control.Monad.Error.Class (MonadError (..)) import Data.Aeson (FromJSON, ToJSON, decode', encode) import qualified Data.ByteString.Base64 as Base64 import Data.Char (toUpper)@@ -173,7 +173,7 @@ it "sets the Content-Type header" $ do response <- THW.request method "" [] "" liftIO $ simpleHeaders response `shouldContain`- [("Content-Type", "application/json")]+ [("Content-Type", "application/json;charset=utf-8")] test "GET 200" get200 methodGet 200 test "POST 210" post210 methodPost 210@@ -194,7 +194,7 @@ captureServer legs = case legs of 4 -> return jerry 2 -> return tweety- _ -> throwE err404+ _ -> throwError err404 captureSpec :: Spec captureSpec = do@@ -228,7 +228,7 @@ 4 -> return jerry 2 -> return tweety 0 -> return beholder- _ -> throwE err404+ _ -> throwError err404 captureAllSpec :: Spec captureAllSpec = do@@ -275,12 +275,14 @@ type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person+ :<|> "param" :> QueryParam "age" Integer :> Get '[JSON] Person+ :<|> "multiparam" :> QueryParams "ages" Integer :> Get '[JSON] Person queryParamApi :: Proxy QueryParamApi queryParamApi = Proxy qpServer :: Server QueryParamApi-qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize+qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges where qpNames (_:name2:_) = return alice { name = name2 } qpNames _ = return alice@@ -288,6 +290,11 @@ qpCapitalize False = return alice qpCapitalize True = return alice { name = map toUpper (name alice) } + qpAge Nothing = return alice+ qpAge (Just age') = return alice{ age = age'}++ qpAges ages = return alice{ age = sum ages}+ queryParamServer (Just name_) = return alice{name = name_} queryParamServer Nothing = return alice @@ -319,7 +326,55 @@ name = "john" } + it "parses a query parameter" $+ (flip runSession) (serve queryParamApi qpServer) $ do+ let params = "?age=55"+ response <- Network.Wai.Test.request defaultRequest{+ rawQueryString = params,+ queryString = parseQuery params,+ pathInfo = ["param"]+ }+ liftIO $+ decode' (simpleBody response) `shouldBe` Just alice{+ age = 55+ } + it "generates an error on query parameter parse failure" $+ (flip runSession) (serve queryParamApi qpServer) $ do+ let params = "?age=foo"+ response <- Network.Wai.Test.request defaultRequest{+ rawQueryString = params,+ queryString = parseQuery params,+ pathInfo = ["param"]+ }+ liftIO $ statusCode (simpleStatus response) `shouldBe` 400+ return ()++ it "parses multiple query parameters" $+ (flip runSession) (serve queryParamApi qpServer) $ do+ let params = "?ages=10&ages=22"+ response <- Network.Wai.Test.request defaultRequest{+ rawQueryString = params,+ queryString = parseQuery params,+ pathInfo = ["multiparam"]+ }+ liftIO $+ decode' (simpleBody response) `shouldBe` Just alice{+ age = 32+ }++ it "generates an error on parse failures of multiple parameters" $+ (flip runSession) (serve queryParamApi qpServer) $ do+ let params = "?ages=2&ages=foo"+ response <- Network.Wai.Test.request defaultRequest{+ rawQueryString = params,+ queryString = parseQuery params,+ pathInfo = ["multiparam"]+ }+ liftIO $ statusCode (simpleStatus response) `shouldBe` 400+ return ()++ it "allows retrieving value-less GET parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params3 = "?capitalize"@@ -642,8 +697,8 @@ genAuthContext = let authHandler = \req -> case lookup "Auth" (requestHeaders req) of Just "secret" -> return ()- Just _ -> throwE err403- Nothing -> throwE err401+ Just _ -> throwError err403+ Nothing -> throwError err401 in mkAuthHandler authHandler :. EmptyContext genAuthSpec :: Spec
test/Servant/Utils/StaticFilesSpec.hs view
@@ -18,7 +18,7 @@ import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON) import Servant.Server (Server, serve) import Servant.ServerSpec (Person (Person))-import Servant.Utils.StaticFiles (serveDirectory)+import Servant.Utils.StaticFiles (serveDirectoryFileServer) type Api = "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person@@ -34,7 +34,7 @@ server :: Server Api server = (\ name_ -> return (Person name_ 42))- :<|> serveDirectory "static"+ :<|> serveDirectoryFileServer "static" withStaticFiles :: IO () -> IO () withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->
+ test/doctests.hsc view
@@ -0,0 +1,61 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module : Main (doctests)+-- Copyright : (C) 2012-14 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+-----------------------------------------------------------------------------+module Main where++import Build_doctests (flags, pkgs, module_sources)+import Data.Foldable (traverse_)+import Test.DocTest++##if defined(mingw32_HOST_OS)+##if defined(i386_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+ cp <- c_GetConsoleCP+ (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ do+ traverse_ putStrLn args+ doctest args+ where+ args = + "-XOverloadedStrings" :+ "-XFlexibleInstances" :+ "-XMultiParamTypeClasses" :+ "-XDataKinds" :+ "-XTypeOperators" :+ flags ++ pkgs ++ module_sources