servant-server 0.10 → 0.11
raw patch · 12 files changed
+182/−256 lines, 12 filesdep +taggeddep ~basedep ~servantsetup-changed
Dependencies added: tagged
Dependency ranges changed: base, servant
Files
- CHANGELOG.md +16/−1
- Setup.lhs +14/−148
- servant-server.cabal +9/−4
- src/Servant/Server.hs +15/−4
- src/Servant/Server/Internal.hs +45/−11
- src/Servant/Server/Internal/RoutingApplication.hs +25/−9
- src/Servant/Utils/StaticFiles.hs +6/−6
- test/Servant/ArbitraryMonadServerSpec.hs +2/−1
- test/Servant/Server/Internal/RoutingApplicationSpec.hs +2/−1
- test/Servant/ServerSpec.hs +23/−10
- test/doctests.hs +25/−0
- test/doctests.hsc +0/−61
CHANGELOG.md view
@@ -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))
Setup.lhs view
@@ -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}
servant-server.cabal view
@@ -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
src/Servant/Server.hs view
@@ -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
src/Servant/Server/Internal.hs view
@@ -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
src/Servant/Server/Internal/RoutingApplication.hs view
@@ -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.
src/Servant/Utils/StaticFiles.hs view
@@ -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
test/Servant/ArbitraryMonadServerSpec.hs view
@@ -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'
test/Servant/Server/Internal/RoutingApplicationSpec.hs view
@@ -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 ())
test/Servant/ServerSpec.hs view
@@ -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") = ()
+ test/doctests.hs view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+-- |+-- 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++main :: IO ()+main = do+ traverse_ putStrLn args+ doctest args+ where+ args = flags ++ pkgs ++ module_sources
− test/doctests.hsc
@@ -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 <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