diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,18 @@ +0.11 +---- + +### Breaking changes + +* Changed `HasServer` instances for `Header` to throw 400 when parsing fails + ([#724](https://github.com/haskell-servant/servant/pull/724)) +* Added `headersD` block to `Delayed` + ([#724](https://github.com/haskell-servant/servant/pull/724)) + +### Other changes + +* Add `err418`, `err422` error codes + ([#739](https://github.com/haskell-servant/servant/pull/739)) + 0.10 ---- @@ -12,7 +27,7 @@ ### Other changes -* Added `paramD` block to `Delayed` +* Added `paramsD` block to `Delayed` * Add `err422` Unprocessable Entity ([#646](https://github.com/haskell-servant/servant/pull/646)) diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,165 +1,31 @@ \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 +{-# OPTIONS_GHC -Wall #-} 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 ) +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 #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 +#if MIN_VERSION_cabal_doctest(1,0,0) +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) 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 +main = defaultMainWithDoctests "doctests" - -- 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 +#ifdef MIN_VERSION_Cabal +#warning You are configuring this package without cabal-doctest installed. \ + The doctests test-suite will not work as a result. \ + To fix this, install cabal-doctest before configuring. #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 +import Distribution.Simple - -- 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 +main :: IO () +main = defaultMain -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys +#endif \end{code} diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -1,5 +1,5 @@ name: servant-server -version: 0.10 +version: 0.11 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them @@ -33,7 +33,9 @@ custom-setup setup-depends: - Cabal >=1.14, base, filepath, directory + base >= 4 && <5, + Cabal, + cabal-doctest >= 1.0.1 && <1.1 library exposed-modules: @@ -51,7 +53,7 @@ build-depends: base >= 4.7 && < 4.10 , base-compat >= 0.9 && < 0.10 - , aeson >= 0.7 && < 1.2 + , aeson >= 0.7 && < 1.3 , attoparsec >= 0.12 && < 0.14 , base64-bytestring >= 1.0 && < 1.1 , bytestring >= 0.10 && < 0.11 @@ -64,12 +66,13 @@ , mtl >= 2 && < 2.3 , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4 - , servant == 0.10.* + , servant == 0.11.* , 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 + , tagged >= 0.7.3 && <0.9 , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 , transformers-base >= 0.4.4 && < 0.5 @@ -158,4 +161,6 @@ buildable: True default-language: Haskell2010 ghc-options: -Wall -threaded + if impl(ghc >= 8.2) + x-doctest-options: -fdiagnostics-color=never include-dirs: include diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -17,6 +17,8 @@ , -- * Handlers for all standard combinators HasServer(..) , Server + , EmptyServer + , emptyServer , Handler (..) , runHandler @@ -88,6 +90,8 @@ , err415 , err416 , err417 + , err418 + , err422 -- ** 5XX , err500 , err501 @@ -98,10 +102,12 @@ -- * Re-exports , Application + , Tagged (..) ) where import Data.Proxy (Proxy) +import Data.Tagged (Tagged (..)) import Data.Text (Text) import Network.Wai (Application) import Servant.Server.Internal @@ -207,17 +213,22 @@ -- monad. Or have your types ensure that your handlers don't do any IO. Enter -- `enter`. -- --- With `enter`, you can provide a function, wrapped in the `(:~>)` / `Nat` +-- With `enter`, you can provide a function, wrapped in the `(:~>)` / `NT` -- newtype, to convert any number of endpoints from one type constructor to -- another. For example -- +-- /Note:/ 'Server' 'Raw' can also be entered. It will be retagged. +-- -- >>> import Control.Monad.Reader -- >>> import qualified Control.Category as C --- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String --- >>> let readerServer = return 1797 :<|> ask :: ServerT ReaderAPI (Reader String) --- >>> let mainServer = enter (generalizeNat C.. (runReaderTNat "hi")) readerServer :: Server ReaderAPI +-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String :<|> Raw :<|> EmptyAPI +-- >>> let readerServer = return 1797 :<|> ask :<|> Tagged (error "raw server") :<|> emptyServer :: ServerT ReaderAPI (Reader String) +-- >>> let nt = generalizeNat C.. (runReaderTNat "hi") :: Reader String :~> Handler +-- >>> let mainServer = enter nt readerServer :: Server ReaderAPI -- -- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeOperators -- >>> import Servant.API -- >>> import Servant.Server diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -15,8 +16,8 @@ module Servant.Server.Internal ( module Servant.Server.Internal - , module Servant.Server.Internal.Context , module Servant.Server.Internal.BasicAuth + , module Servant.Server.Internal.Context , module Servant.Server.Internal.Handler , module Servant.Server.Internal.Router , module Servant.Server.Internal.RoutingApplication @@ -32,6 +33,7 @@ import Data.Either (partitionEithers) import Data.String (fromString) import Data.String.Conversions (cs, (<>)) +import Data.Tagged (Tagged(..), untag) import qualified Data.Text as T import Data.Typeable import GHC.TypeLits (KnownNat, KnownSymbol, natVal, @@ -46,12 +48,12 @@ responseLBS, vault) import Prelude () import Prelude.Compat -import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe, +import Web.HttpApiData (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPieceMaybe, parseUrlPieces) import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture, - CaptureAll, Verb, + CaptureAll, Verb, EmptyAPI, ReflectMethod(reflectMethod), IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, Raw, @@ -280,10 +282,21 @@ type ServerT (Header sym a :> api) m = Maybe a -> ServerT api m - route Proxy context subserver = - let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req) - in route (Proxy :: Proxy api) context (passToServer subserver mheader) - where str = fromString $ symbolVal (Proxy :: Proxy sym) + route Proxy context subserver = route (Proxy :: Proxy api) context $ + subserver `addHeaderCheck` withRequest headerCheck + where + headerName = symbolVal (Proxy :: Proxy sym) + headerCheck req = + case lookup (fromString headerName) (requestHeaders req) of + Nothing -> return Nothing + Just txt -> + case parseHeader txt of + Left e -> delayedFailFatal err400 + { errBody = cs $ "Error parsing header " + <> fromString headerName + <> " failed: " <> e + } + Right header -> return $ Just header -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -321,7 +334,8 @@ Just (Just v) -> case parseQueryParam v of Left e -> delayedFailFatal err400 - { errBody = cs $ "Error parsing query parameter " <> paramname <> " failed: " <> e + { errBody = cs $ "Error parsing query parameter " + <> paramname <> " failed: " <> e } Right param -> return $ Just param @@ -364,7 +378,9 @@ case partitionEithers $ fmap parseQueryParam params of ([], parsed) -> return parsed (errs, _) -> delayedFailFatal err400 - { errBody = cs $ "Error parsing query parameter(s) " <> paramname <> " failed: " <> T.intercalate ", " errs + { errBody = cs $ "Error parsing query parameter(s) " + <> paramname <> " failed: " + <> T.intercalate ", " errs } where params :: [T.Text] @@ -415,7 +431,7 @@ -- > server = serveDirectory "/var/www/images" instance HasServer Raw context where - type ServerT Raw m = Application + type ServerT Raw m = Tagged m Application route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do -- note: a Raw application doesn't register any cleanup @@ -425,7 +441,7 @@ liftIO $ go r request respond where go r request respond = case r of - Route app -> app request (respond . Route) + Route app -> untag app request (respond . Route) Fail a -> respond $ Fail a FailFatal e -> respond $ FailFatal e @@ -516,6 +532,24 @@ route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver httpVersion) + +-- | Singleton type representing a server that serves an empty API. +data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum) + +-- | Server for `EmptyAPI` +emptyServer :: ServerT EmptyAPI m +emptyServer = Tagged EmptyServer + +-- | The server for an `EmptyAPI` is `emptyAPIServer`. +-- +-- > type MyApi = "nothing" :> EmptyApi +-- > +-- > server :: Server MyApi +-- > server = emptyAPIServer +instance HasServer EmptyAPI context where + type ServerT EmptyAPI m = Tagged m EmptyServer + + route Proxy _ _ = StaticRouter mempty mempty -- | Basic Authentication instance ( KnownSymbol realm diff --git a/src/Servant/Server/Internal/RoutingApplication.hs b/src/Servant/Server/Internal/RoutingApplication.hs --- a/src/Servant/Server/Internal/RoutingApplication.hs +++ b/src/Servant/Server/Internal/RoutingApplication.hs @@ -160,8 +160,10 @@ -- 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. +-- 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 () @@ -169,9 +171,11 @@ , acceptD :: DelayedIO () , contentD :: DelayedIO contentType , paramsD :: DelayedIO params + , headersD :: DelayedIO headers , bodyD :: contentType -> DelayedIO body , serverD :: captures -> params + -> headers -> auth -> body -> Request @@ -181,7 +185,7 @@ instance Functor (Delayed env) where fmap f Delayed{..} = Delayed - { serverD = \ c p a b req -> f <$> serverD c p a b req + { serverD = \ c p h a b req -> f <$> serverD c p h a b req , .. } -- Note [Existential Record Update] @@ -213,7 +217,7 @@ -- | A 'Delayed' without any stored checks. emptyDelayed :: RouteResult a -> Delayed env a emptyDelayed result = - Delayed (const r) r r r r r (const r) (\ _ _ _ _ _ -> result) + Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result) where r = return () @@ -238,7 +242,7 @@ addCapture Delayed{..} new = Delayed { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt - , serverD = \ (x, v) p a b req -> ($ v) <$> serverD x p a b req + , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req , .. } -- Note [Existential Record Update] @@ -249,10 +253,21 @@ addParameterCheck Delayed {..} new = Delayed { paramsD = (,) <$> paramsD <*> new - , serverD = \c (p, pNew) a b req -> ($ pNew) <$> serverD c p a b req + , 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 () @@ -270,7 +285,7 @@ addAuthCheck Delayed{..} new = Delayed { authD = (,) <$> authD <*> new - , serverD = \ c p (y, v) b req -> ($ v) <$> serverD c p y b req + , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req , .. } -- Note [Existential Record Update] @@ -286,7 +301,7 @@ Delayed { contentD = (,) <$> contentD <*> newContentD , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c - , serverD = \ c p a (z, v) req -> ($ v) <$> serverD c p a z req + , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req , .. } -- Note [Existential Record Update] @@ -316,7 +331,7 @@ passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b passToServer Delayed{..} x = Delayed - { serverD = \ c p a b req -> ($ x req) <$> serverD c p a b req + { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req , .. } -- Note [Existential Record Update] @@ -338,8 +353,9 @@ 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 a b r) + 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. diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs --- a/src/Servant/Utils/StaticFiles.hs +++ b/src/Servant/Utils/StaticFiles.hs @@ -18,7 +18,7 @@ import Data.ByteString (ByteString) import Network.Wai.Application.Static import Servant.API.Raw (Raw) -import Servant.Server (Server) +import Servant.Server (Server, Tagged (..)) import System.FilePath (addTrailingPathSeparator) #if !MIN_VERSION_wai_app_static(3,1,0) import Filesystem.Path.CurrentOS (decodeString) @@ -48,27 +48,27 @@ -- -- Corresponds to the `defaultWebAppSettings` `StaticSettings` value. serveDirectoryWebApp :: FilePath -> Server Raw -serveDirectoryWebApp = staticApp . defaultWebAppSettings . fixPath +serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath -- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`. serveDirectoryFileServer :: FilePath -> Server Raw -serveDirectoryFileServer = staticApp . defaultFileServerSettings . fixPath +serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath -- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'. serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> Server Raw serveDirectoryWebAppLookup etag = - staticApp . flip webAppSettingsWithLookup etag . fixPath + serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath -- | Uses 'embeddedSettings'. serveDirectoryEmbedded :: [(FilePath, ByteString)] -> Server Raw -serveDirectoryEmbedded files = staticApp (embeddedSettings files) +serveDirectoryEmbedded files = serveDirectoryWith (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 +serveDirectoryWith = Tagged . staticApp -- | Same as 'serveDirectoryFileServer'. It used to be the only -- file serving function in servant pre-0.10 and will be kept diff --git a/test/Servant/ArbitraryMonadServerSpec.hs b/test/Servant/ArbitraryMonadServerSpec.hs --- a/test/Servant/ArbitraryMonadServerSpec.hs +++ b/test/Servant/ArbitraryMonadServerSpec.hs @@ -5,6 +5,7 @@ import qualified Control.Category as C import Control.Monad.Reader +import Data.Functor.Identity import Data.Proxy import Servant.API import Servant.Server @@ -40,7 +41,7 @@ readerServer = enter fReader readerServer' combinedReaderServer' :: ServerT CombinedAPI (Reader String) -combinedReaderServer' = readerServer' :<|> enter generalizeNat (return True) +combinedReaderServer' = readerServer' :<|> enter (generalizeNat :: Identity :~> Reader String) (return True) combinedReaderServer :: Server CombinedAPI combinedReaderServer = enter fReader combinedReaderServer' diff --git a/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/test/Servant/Server/Internal/RoutingApplicationSpec.hs --- a/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -63,11 +63,12 @@ , acceptD = return () , contentD = return () , paramsD = return () + , headersD = return () , bodyD = \() -> do liftIO (writeTestResource "hia" >> putStrLn "garbage created") _ <- register (freeTestResource >> putStrLn "garbage collected") body - , serverD = \() () () _body _req -> srv + , serverD = \() () () () _body _req -> srv } simpleRun :: Delayed () (Handler ()) diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -42,14 +42,14 @@ Headers, HttpVersion, IsSecure (..), JSON, NoContent (..), Patch, PlainText, - Post, Put, + Post, Put, EmptyAPI, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI -import Servant.Server (Server, Handler, err401, err403, +import Servant.Server (Server, Handler, Tagged (..), err401, err403, err404, serve, serveWithContext, - Context((:.), EmptyContext)) + Context((:.), EmptyContext), emptyServer) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import qualified Test.Hspec.Wai as THW @@ -210,7 +210,7 @@ with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) - (\ "captured" request_ respond -> + (\ "captured" -> Tagged $ \request_ respond -> respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) @@ -262,7 +262,7 @@ with (return (serve (Proxy :: Proxy (CaptureAll "segments" String :> Raw)) - (\ _captured request_ respond -> + (\ _captured -> Tagged $ \request_ respond -> respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "consumes everything from pathInfo" $ do get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int]))) @@ -477,6 +477,13 @@ it "passes the header to the handler (String)" $ delete' "/" "" `shouldRespondWith` 200 + with (return (serve headerApi expectsInt)) $ do + let delete' x = THW.request methodDelete x [("MyHeader", "not a number")] + + it "checks for parse errors" $ + delete' "/" "" `shouldRespondWith` 400 + + -- }}} ------------------------------------------------------------------------------ -- * rawSpec {{{ @@ -487,9 +494,10 @@ rawApi :: Proxy RawApi rawApi = Proxy -rawApplication :: Show a => (Request -> a) -> Application -rawApplication f request_ respond = respond $ responseLBS ok200 [] - (cs $ show $ f request_) +rawApplication :: Show a => (Request -> a) -> Tagged m Application +rawApplication f = Tagged $ \request_ respond -> + respond $ responseLBS ok200 [] + (cs $ show $ f request_) rawSpec :: Spec rawSpec = do @@ -601,6 +609,7 @@ = "version" :> HttpVersion :> Get '[JSON] String :<|> "secure" :> IsSecure :> Get '[JSON] String :<|> "host" :> RemoteHost :> Get '[JSON] String + :<|> "empty" :> EmptyAPI miscApi :: Proxy MiscCombinatorsAPI miscApi = Proxy @@ -609,6 +618,7 @@ miscServ = versionHandler :<|> secureHandler :<|> hostHandler + :<|> emptyServer where versionHandler = return . show secureHandler Secure = return "secure" @@ -627,6 +637,9 @@ it "Checks that hspec-wai issues request from 0.0.0.0" $ go "/host" "\"0.0.0.0:0\"" + it "Doesn't serve anything from the empty API" $ + Test.Hspec.Wai.get "empty" `shouldRespondWith` 404 + where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res -- }}} @@ -644,7 +657,7 @@ basicAuthServer :: Server BasicAuthAPI basicAuthServer = const (return jerry) :<|> - (\ _ respond -> respond $ responseLBS imATeaPot418 [] "") + (Tagged $ \ _ respond -> respond $ responseLBS imATeaPot418 [] "") basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext = @@ -689,7 +702,7 @@ genAuthServer :: Server GenAuthAPI genAuthServer = const (return tweety) - :<|> (\ _ respond -> respond $ responseLBS imATeaPot418 [] "") + :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeaPot418 [] "") type instance AuthServerData (AuthProtect "auth") = () diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (doctests) +-- Copyright : (C) 2012-14 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- 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 + +main :: IO () +main = do + traverse_ putStrLn args + doctest args + where + args = flags ++ pkgs ++ module_sources diff --git a/test/doctests.hsc b/test/doctests.hsc deleted file mode 100644 --- a/test/doctests.hsc +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- 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