servant-server 0.20 → 0.20.2
raw patch · 19 files changed
+590/−384 lines, 19 filesdep −QuickCheckdep −network-uridep −string-conversionsdep ~basedep ~base-compatdep ~containersnew-uploader
Dependencies removed: QuickCheck, network-uri, string-conversions, transformers-compat
Dependency ranges changed: base, base-compat, containers, filepath, servant, sop-core, transformers
Files
- CHANGELOG.md +20/−0
- servant-server.cabal +130/−87
- src/Servant/Server.hs +3/−0
- src/Servant/Server/Experimental/Auth.hs +3/−1
- src/Servant/Server/Generic.hs +4/−2
- src/Servant/Server/Internal.hs +142/−62
- src/Servant/Server/Internal/Context.hs +5/−3
- src/Servant/Server/Internal/DelayedIO.hs +1/−1
- src/Servant/Server/Internal/ErrorFormatter.hs +6/−7
- src/Servant/Server/Internal/Handler.hs +12/−7
- src/Servant/Server/Internal/RouteResult.hs +5/−5
- src/Servant/Server/Internal/Router.hs +4/−4
- src/Servant/Server/Internal/RoutingApplication.hs +0/−2
- src/Servant/Server/Internal/ServerError.hs +14/−0
- src/Servant/Server/UVerb.hs +8/−8
- test/Servant/Server/ErrorSpec.hs +5/−7
- test/Servant/Server/StreamingSpec.hs +2/−2
- test/Servant/Server/UsingContextSpec/TestCombinators.hs +4/−3
- test/Servant/ServerSpec.hs +222/−183
CHANGELOG.md view
@@ -3,6 +3,26 @@ Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions. +0.20.2+----++- Fix build of examples/greet.hs. Add "429 Too Many Requests" error. [#1591](https://github.com/haskell-servant/servant/pull/1591)+- Full query string helpers [#1604](https://github.com/haskell-servant/servant/pull/1604)+ This involves a new instance `HasServer (QueryString :> api) context`.+- Add `MkHandler` pattern synonym [#1732](https://github.com/haskell-servant/servant/issues/1732) [#1733](https://github.com/haskell-servant/servant/pull/1733)++ Add a bidirectional pattern synonym to construct `Handler a` values from `IO+ (Either ServerError a)` ones, and match in the other direction.+- Add instance `HasServer (EmptyAPI :> api) context` [#1775](https://github.com/haskell-servant/servant/pull/1775)+- Bugfix - CaptureAll produces [""] for empty paths due to trailing slash. [#1243](https://github.com/haskell-servant/servant/issues/1243) [#1516](https://github.com/haskell-servant/servant/pull/1516)++ CaptureAll resulted in `[""]` for empty paths due to trailing slash. Similar+ oddities occurred around these edge cases like `"/"` resulted in `[]` correctly,+ but `"//"` resulted in `["", ""]`. This patch simply eliminates the first `""`+ in the pathinfo list as taken from the wai response. This might break user+ code that relies on personal shims to solve the problem, however simply removing their+ workarounds should fix their code as the behavior is now sane.+ 0.20 ----
servant-server.cabal view
@@ -1,9 +1,10 @@-cabal-version: 2.2-name: servant-server-version: 0.20+cabal-version: 3.0+name: servant-server+version: 0.20.2+synopsis:+ A family of combinators for defining webservices APIs and serving them -synopsis: A family of combinators for defining webservices APIs and serving them-category: Servant, Web+category: Servant, Web description: A family of combinators for defining webservices APIs and serving them .@@ -15,25 +16,81 @@ . <https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md CHANGELOG> -homepage: http://docs.servant.dev/-bug-reports: http://github.com/haskell-servant/servant/issues-license: BSD-3-Clause-license-file: LICENSE-author: Servant Contributors-maintainer: haskell-servant-maintainers@googlegroups.com-copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors-build-type: Simple-tested-with: GHC==8.6.5, GHC==8.8.4, GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.7, GHC ==9.4.4+homepage: http://docs.servant.dev/+bug-reports: http://github.com/haskell-servant/servant/issues+license: BSD-3-Clause+license-file: LICENSE+author: Servant Contributors+maintainer: haskell-servant-maintainers@googlegroups.com+copyright:+ 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors +build-type: Simple+tested-with:+ GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.4 || ==9.8.2 || ==9.10.1+ extra-source-files: CHANGELOG.md README.md source-repository head- type: git+ type: git location: http://github.com/haskell-servant/servant.git +common extensions+ default-extensions:+ AllowAmbiguousTypes+ ConstraintKinds+ DataKinds+ DeriveAnyClass+ DeriveDataTypeable+ DeriveFunctor+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ EmptyDataDecls+ ExplicitNamespaces+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ NamedFieldPuns+ NoStarIsType+ OverloadedLabels+ OverloadedStrings+ PackageImports+ PolyKinds+ QuantifiedConstraints+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StrictData+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ ViewPatterns++ default-language: Haskell2010++common ghc-options+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ -fhide-source-paths -Wno-unused-do-bind -fdicts-strict+ -Wno-unticked-promoted-constructors -Werror=unused-imports+ -Wunused-packages+ library+ import: extensions+ import: ghc-options exposed-modules: Servant Servant.Server@@ -46,99 +103,91 @@ Servant.Server.Internal.DelayedIO Servant.Server.Internal.ErrorFormatter Servant.Server.Internal.Handler- Servant.Server.Internal.RouteResult Servant.Server.Internal.Router+ Servant.Server.Internal.RouteResult Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServerError Servant.Server.StaticFiles Servant.Server.UVerb -- deprecated- exposed-modules:- Servant.Utils.StaticFiles+ exposed-modules: Servant.Utils.StaticFiles -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 build-depends:- base >= 4.9 && < 4.19- , bytestring >= 0.10.8.1 && < 0.12- , constraints >= 0.2 && < 0.14- , containers >= 0.5.7.1 && < 0.7- , mtl ^>= 2.2.2 || ^>= 2.3.1- , text >= 1.2.3.0 && < 2.1- , transformers >= 0.5.2.0 && < 0.7- , filepath >= 1.4.1.1 && < 1.5+ , base >=4.14 && <4.21+ , bytestring >=0.10.8.1 && <0.13+ , constraints >=0.2 && <0.15+ , containers >=0.5.7.1 && <0.8+ , filepath >=1.4.1.1 && <1.6+ , mtl ^>=2.2.2 || ^>=2.3.1+ , text >=1.2.3.0 && <2.2+ , transformers >=0.5.2.0 && <0.7 -- Servant dependencies -- strict dependency as we re-export 'servant' things. build-depends:- servant >= 0.20 && < 0.21- , http-api-data >= 0.4.1 && < 0.6+ , http-api-data >=0.4.1 && <0.7+ , servant >=0.20.2 && <0.21 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends:- base-compat >= 0.10.5 && < 0.14- , base64-bytestring >= 1.0.0.1 && < 1.3- , exceptions >= 0.10.0 && < 0.11- , http-media >= 0.7.1.3 && < 0.9- , http-types >= 0.12.2 && < 0.13- , network-uri >= 2.6.1.0 && < 2.8- , monad-control >= 1.0.2.3 && < 1.1- , network >= 2.8 && < 3.2- , sop-core >= 0.4.0.0 && < 0.6- , string-conversions >= 0.4.0.1 && < 0.5- , resourcet >= 1.2.2 && < 1.4- , tagged >= 0.8.6 && < 0.9- , transformers-base >= 0.4.5.2 && < 0.5- , wai >= 3.2.2.1 && < 3.3- , wai-app-static >= 3.1.6.2 && < 3.2- , word8 >= 0.1.3 && < 0.2-- hs-source-dirs: src- default-language: Haskell2010+ , base64-bytestring >=1.0.0.1 && <1.3+ , exceptions >=0.10.0 && <0.11+ , http-media >=0.7.1.3 && <0.9+ , http-types >=0.12.2 && <0.13+ , monad-control >=1.0.2.3 && <1.1+ , network >=2.8 && <3.3+ , resourcet >=1.2.2 && <1.4+ , sop-core >=0.4.0.0 && <0.6+ , tagged >=0.8.6 && <0.9+ , transformers-base >=0.4.5.2 && <0.5+ , wai >=3.2.2.1 && <3.3+ , wai-app-static >=3.1.6.2 && <3.2+ , word8 >=0.1.3 && <0.2 - ghc-options: -Wall -Wno-redundant-constraints+ hs-source-dirs: src executable greet- main-is: greet.hs+ import: extensions+ import: ghc-options+ main-is: greet.hs hs-source-dirs: example- ghc-options: -Wall- default-language: Haskell2010 build-depends:- base+ , base , base-compat- , servant , servant-server- , wai , text+ , wai build-depends:- aeson >= 1.4.1.0 && < 3- , warp >= 3.2.25 && < 3.4+ , aeson >=1.4.1.0 && <3+ , warp >=3.2.25 && <3.5 test-suite spec- type: exitcode-stdio-1.0- ghc-options: -Wall- default-language: Haskell2010- hs-source-dirs: test- main-is: Spec.hs+ import: extensions+ import: ghc-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs other-modules:- Servant.ArbitraryMonadServerSpec- Servant.Server.ErrorSpec- Servant.Server.Internal.ContextSpec- Servant.Server.Internal.RoutingApplicationSpec- Servant.Server.RouterSpec- Servant.Server.StaticFilesSpec- Servant.Server.StreamingSpec- Servant.Server.UsingContextSpec- Servant.Server.UsingContextSpec.TestCombinators- Servant.HoistSpec- Servant.ServerSpec+ Servant.ArbitraryMonadServerSpec+ Servant.HoistSpec+ Servant.Server.ErrorSpec+ Servant.Server.Internal.ContextSpec+ Servant.Server.Internal.RoutingApplicationSpec+ Servant.Server.RouterSpec+ Servant.Server.StaticFilesSpec+ Servant.Server.StreamingSpec+ Servant.Server.UsingContextSpec+ Servant.Server.UsingContextSpec.TestCombinators+ Servant.ServerSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends:- base+ , base , base-compat , base64-bytestring , bytestring@@ -148,23 +197,17 @@ , safe , servant , servant-server- , sop-core- , string-conversions , text- , transformers- , transformers-compat , wai -- Additional dependencies build-depends:- aeson >= 1.4.1.0 && < 3- , directory >= 1.3.0.0 && < 1.4- , hspec >= 2.6.0 && < 2.11- , hspec-wai >= 0.10.1 && < 0.12- , QuickCheck >= 2.12.6.1 && < 2.15- , should-not-typecheck >= 2.1.0 && < 2.2- , temporary >= 1.3 && < 1.4- , wai-extra >= 3.0.24.3 && < 3.2+ , aeson >=1.4.1.0 && <3+ , directory >=1.3.0.0 && <1.4+ , hspec >=2.6.0 && <2.12+ , hspec-wai >=0.10.1 && <0.12+ , should-not-typecheck >=2.1.0 && <2.2+ , temporary >=1.3 && <1.4+ , wai-extra >=3.0.24.3 && <3.2 - build-tool-depends:- hspec-discover:hspec-discover >= 2.6.0 && <2.11+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12
src/Servant/Server.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PatternSynonyms #-} -- | This module lets you implement 'Server's for defined APIs. You'll -- most likely just need 'serve'.@@ -25,6 +26,7 @@ , emptyServer , Handler (..) , runHandler+ , pattern MkHandler -- * Debugging the server layout , layout@@ -84,6 +86,7 @@ , err417 , err418 , err422+ , err429 -- ** 5XX , err500 , err501
src/Servant/Server/Experimental/Auth.hs view
@@ -15,6 +15,8 @@ import Control.Monad.Trans (liftIO)+import Data.Kind+ (Type) import Data.Proxy (Proxy (Proxy)) import Data.Typeable@@ -38,7 +40,7 @@ -- quite often this is some `User` datatype. -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE-type family AuthServerData a :: *+type family AuthServerData a :: Type -- | Handlers for AuthProtected resources --
src/Servant/Server/Generic.hs view
@@ -16,6 +16,8 @@ genericServerT ) where +import Data.Kind+ (Type) import Data.Proxy (Proxy (..)) @@ -37,7 +39,7 @@ -- by providing a transformation to bring each handler back in the 'Handler' -- monad. genericServeT- :: forall (routes :: * -> *) (m :: * -> *).+ :: forall (routes :: Type -> Type) (m :: Type -> Type). ( GenericServant routes (AsServerT m) , GenericServant routes AsApi , HasServer (ToServantApi routes) '[]@@ -55,7 +57,7 @@ -- used by auth-related combinators in servant, e.g to hold auth checks) and the given -- transformation to map all the handlers back to the 'Handler' monad. genericServeTWithContext- :: forall (routes :: * -> *) (m :: * -> *) (ctx :: [*]).+ :: forall (routes :: Type -> Type) (m :: Type -> Type) (ctx :: [Type]). ( GenericServant routes (AsServerT m) , GenericServant routes AsApi , HasServer (ToServantApi routes) ctx
src/Servant/Server/Internal.hs view
@@ -1,23 +1,4 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal ( module Servant.Server.Internal@@ -43,23 +24,22 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BC8-import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy as BSL import Data.Constraint (Constraint, Dict(..)) import Data.Either (partitionEithers)+import Data.Kind+ (Type) import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) import Data.String (IsString (..))-import Data.String.Conversions- (cs) import Data.Tagged (Tagged (..), retag, untag) import qualified Data.Text as T import Data.Typeable import GHC.Generics-import GHC.TypeLits- (KnownNat, KnownSymbol, TypeError, symbolVal)+import GHC.TypeLits (KnownNat, KnownSymbol, TypeError, ErrorMessage (..), symbolVal) import qualified Network.HTTP.Media as NHM import Network.HTTP.Types hiding (Header, ResponseHeaders)@@ -69,14 +49,12 @@ (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody, queryString, remoteHost, getRequestBodyChunk, requestHeaders, requestMethod, responseLBS, responseStream, vault)-import Prelude ()-import Prelude.Compat import Servant.API ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',- CaptureAll, Description, EmptyAPI, Fragment,+ CaptureAll, DeepQuery, Description, EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..), FromSourceIO (..), Header', If, IsSecure (..), NoContentVerb, QueryFlag,- QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),+ QueryParam', QueryParams, QueryString, Raw, RawM, ReflectMethod (reflectMethod), RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, WithNamedContext, WithResource, NamedRoutes)@@ -88,6 +66,7 @@ import Servant.API.Modifiers (FoldLenient, FoldRequired, RequestArgument, unfoldRequestArgument)+import Servant.API.QueryString (FromDeepQuery(..)) import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) import Servant.API.Status@@ -97,8 +76,6 @@ import Web.HttpApiData (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece, parseUrlPieces)-import Data.Kind- (Type) import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context@@ -111,17 +88,14 @@ import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError -import GHC.TypeLits- (ErrorMessage (..), TypeError)-import Servant.API.TypeLevel- (AtLeastOneFragment, FragmentUnique)+import Servant.API.TypeLevel (AtMostOneFragment, FragmentUnique) class HasServer api context where -- | The type of a server for this API, given a monad to run effects in. -- -- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike -- what the @T@ in the name might suggest.- type ServerT api (m :: * -> *) :: *+ type ServerT api (m :: Type -> Type) :: Type route :: Proxy api@@ -200,9 +174,9 @@ (addCapture d $ \ txt -> withRequest $ \ request -> case ( sbool :: SBool (FoldLenient mods) , parseUrlPiece txt :: Either T.Text a) of- (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e+ (SFalse, Left e) -> delayedFail $ formatError rep request $ T.unpack e (SFalse, Right v) -> return v- (STrue, piece) -> return $ (either (Left . cs) Right) piece)+ (STrue, piece) -> return $ either (Left . T.unpack) Right piece) where rep = typeRep (Proxy :: Proxy Capture') formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)@@ -242,7 +216,7 @@ context (addCapture d $ \ txts -> withRequest $ \ request -> case parseUrlPieces txts of- Left e -> delayedFail $ formatError rep request $ cs e+ Left e -> delayedFail $ formatError rep request $ T.unpack e Right v -> return v ) where@@ -326,7 +300,7 @@ Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does Just (contentT, body) -> let bdy = if allowedMethodHead method request then "" else body- in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy+ in Route $ responseLBS status ((hContentType, BSL.toStrict contentT) : headers) bdy noContentRouter :: Method -> Status@@ -416,7 +390,7 @@ ) env request respond $ \ output -> let (headers, fa) = splitHeaders output sourceT = toSourceIO fa- S.SourceT kStepLBS = framingRender framingproxy (mimeRender ctypeproxy :: chunk -> BL.ByteString) sourceT+ S.SourceT kStepLBS = framingRender framingproxy (mimeRender ctypeproxy :: chunk -> BSL.ByteString) sourceT in Route $ responseStream status (contentHeader : headers) $ \write flush -> do let loop S.Stop = flush loop (S.Error err) = fail err -- TODO: throw better error@@ -481,7 +455,7 @@ $ "Header " <> headerName <> " is required" errSt e = delayedFailFatal $ formatError rep req- $ cs $ "Error parsing header "+ $ T.unpack $ "Error parsing header " <> headerName <> " failed: " <> e @@ -520,7 +494,7 @@ route Proxy context subserver = let querytext = queryToQueryText . queryString- paramname = cs $ symbolVal (Proxy :: Proxy sym)+ paramname = T.pack $ symbolVal (Proxy :: Proxy sym) rep = typeRep (Proxy :: Proxy QueryParam') formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)@@ -533,10 +507,10 @@ mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req errReq = delayedFailFatal $ formatError rep req- $ cs $ "Query parameter " <> paramname <> " is required"+ $ T.unpack $ "Query parameter " <> paramname <> " is required" errSt e = delayedFailFatal $ formatError rep req- $ cs $ "Error parsing query parameter "+ $ T.unpack $ "Error parsing query parameter " <> paramname <> " failed: " <> e delayed = addParameterCheck subserver . withRequest $ \req ->@@ -578,12 +552,12 @@ rep = typeRep (Proxy :: Proxy QueryParams) formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) - paramname = cs $ symbolVal (Proxy :: Proxy sym)+ paramname = T.pack $ symbolVal (Proxy :: Proxy sym) paramsCheck req = case partitionEithers $ fmap parseQueryParam params of ([], parsed) -> return parsed (errs, _) -> delayedFailFatal $ formatError rep req- $ cs $ "Error parsing query parameter(s) "+ $ T.unpack $ "Error parsing query parameter(s) " <> paramname <> " failed: " <> T.intercalate ", " errs where@@ -623,10 +597,109 @@ Just (Just v) -> examine v -- param with a value Nothing -> False -- param not in the query string in route (Proxy :: Proxy api) context (passToServer subserver param)- where paramname = cs $ symbolVal (Proxy :: Proxy sym)+ where paramname = T.pack $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False +-- | If you use @'QueryString'@ 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 @Query@ (@[('ByteString', 'Maybe' 'ByteString')]@).+--+-- This lets you extract the whole query string. This is useful when the query string+-- can contain parameters with dynamic names, that you can't access with @'QueryParam'@.+--+-- Example:+--+-- > type MyApi = "books" :> QueryString :> Get '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooksBy+-- > where getBooksBy :: Query -> Handler [Book]+-- > getBooksBy filters = ...filter books based on the dynamic filters provided...+instance+ ( HasServer api context+ )+ => HasServer (QueryString :> api) context where+------+ type ServerT (QueryString :> api) m =+ Query -> ServerT api m++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++ route Proxy context subserver =+ route (Proxy :: Proxy api) context (passToServer subserver queryString)++-- | If you use @'DeepQuery' "symbol" a@ 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 @a@.+--+-- This lets you extract an object from multiple parameters in the query string,+-- with its fields enclosed in brackets: `/books?filter[author][name]=value`. When+-- all the fields are known in advance, it can be done with @'QueryParam'@ (it can+-- still be tedious if you the object has many fields). When some fields are dynamic,+-- it cannot be done with @'QueryParam'.+--+-- The way the object is constructed from the extracted fields can be controlled by+-- providing an instance on @'FromDeepQuery'@+--+-- Example:+--+-- > type MyApi = "books" :> DeepQuery "filter" BookQuery :> Get '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooksBy+-- > where getBooksBy :: BookQuery -> Handler [Book]+-- > getBooksBy query = ...filter books based on the dynamic filters provided...+instance+ ( KnownSymbol sym, FromDeepQuery a, HasServer api context+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters+ )+ => HasServer (DeepQuery sym a :> api) context where+------+ type ServerT (DeepQuery sym a :> api) m =+ a -> ServerT api m++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++ route Proxy context subserver = route (Proxy :: Proxy api) context $+ subserver `addParameterCheck` withRequest paramsCheck+ where+ rep = typeRep (Proxy :: Proxy DeepQuery)+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)++ paramname = T.pack $ symbolVal (Proxy :: Proxy sym)+ paramsCheck req =+ let relevantParams :: [(T.Text, Maybe T.Text)]+ relevantParams = mapMaybe isRelevantParam+ . queryToQueryText+ . queryString+ $ req+ isRelevantParam (name, value) = (, value) <$>+ case T.stripPrefix paramname name of+ Just "" -> Just ""+ Just x | "[" `T.isPrefixOf` x -> Just x+ _ -> Nothing+ in case fromDeepQuery =<< traverse parseDeepParam relevantParams of+ Left e -> delayedFailFatal $ formatError rep req+ $ T.unpack $ "Error parsing deep query parameter(s) "+ <> paramname <> T.pack " failed: "+ <> T.pack e+ Right parsed -> return parsed++parseDeepParam :: (T.Text, Maybe T.Text) -> Either String ([T.Text], Maybe T.Text)+parseDeepParam (paramname, value) =+ let parseParam "" = return []+ parseParam n = reverse <$> go [] n+ go parsed remaining = case T.take 1 remaining of+ "[" -> case T.breakOn "]" remaining of+ (_ , "") -> Left $ "Error parsing deep param, missing closing ']': " <> T.unpack remaining+ (name, "]") -> return $ T.drop 1 name : parsed+ (name, remaining') -> case T.take 2 remaining' of+ "][" -> go (T.drop 1 name : parsed) (T.drop 1 remaining')+ _ -> Left $ "Error parsing deep param, incorrect brackets: " <> T.unpack remaining+ _ -> Left $ "Error parsing deep param, missing opening '[': " <> T.unpack remaining+ in (, value) <$> parseParam paramname+ -- | Just pass the request to the underlying application and serve its response. -- -- Example:@@ -727,7 +800,7 @@ -- http://www.w3.org/2001/tag/2002/0129-mime let contentTypeH = fromMaybe "application/octet-stream" $ lookup hContentType $ requestHeaders request- case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of+ case canHandleCTypeH (Proxy :: Proxy list) (BSL.fromStrict contentTypeH) :: Maybe (BSL.ByteString -> Either String a) of Nothing -> delayedFail err415 Just f -> return f @@ -758,7 +831,7 @@ bodyCheck :: (SourceIO chunk -> IO a) -> DelayedIO a bodyCheck fromRS = withRequest $ \req -> do- let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk+ let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BSL.ByteString -> Either String chunk let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk let body = getRequestBodyChunk req let rs = S.fromAction B.null body@@ -772,7 +845,7 @@ route Proxy context subserver = pathRouter- (cs (symbolVal proxyPath))+ (T.pack (symbolVal proxyPath)) (route (Proxy :: Proxy api) context subserver) where proxyPath = Proxy :: Proxy path hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s@@ -841,6 +914,13 @@ hoistServerWithContext _ _ _ = retag +-- | Ignore @'EmptyAPI'@ as part of route in server handlers.+instance HasServer api context => HasServer (EmptyAPI :> api) context where+ type ServerT (EmptyAPI :> api) m = ServerT api m++ route _ = route (Proxy :: Proxy api)+ hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)+ -- | Basic Authentication instance ( KnownSymbol realm , HasServer api context@@ -894,13 +974,13 @@ ------------------------------------------------------------------------------- -- Erroring instance for 'HasServer' when a combinator is not fully applied-instance TypeError (PartialApplication -#if __GLASGOW_HASKELL__ >= 904- @(Type -> [Type] -> Constraint) -#endif+instance TypeError (PartialApplication++ @(Type -> [Type] -> Constraint)+ HasServer arr) => HasServer ((arr :: a -> b) :> sub) context where- type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)+ type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: Type -> [Type] -> Constraint) arr) route = error "unreachable" hoistServerWithContext _ _ _ _ = error "unreachable" @@ -942,10 +1022,10 @@ -- XXX: This omits the @context@ parameter, e.g.: -- -- "There is no instance for HasServer (Bool :> …)". Do we care ?-instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub -#if __GLASGOW_HASKELL__ >= 904- @(Type -> [Type] -> Constraint) -#endif+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub++ @(Type -> [Type] -> Constraint)+ HasServer ty) => HasServer (ty :> sub) context instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context@@ -961,7 +1041,7 @@ -- > server = getBooks -- > where getBooks :: Handler [Book] -- > getBooks = ...return all books...-instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)+instance (AtMostOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context) => HasServer (Fragment a1 :> api) context where type ServerT (Fragment a1 :> api) m = ServerT api m @@ -973,7 +1053,7 @@ -- >>> import Servant -- | A type that specifies that an API record contains a server implementation.-data AsServerT (m :: * -> *)+data AsServerT (m :: Type -> Type) instance GenericMode (AsServerT m) where type AsServerT m :- api = ServerT api m @@ -999,7 +1079,7 @@ -- Users shouldn't have to worry about this class, as the only possible instance -- is provided in this module for all record APIs. -class GServer (api :: * -> *) (m :: * -> *) where+class GServer (api :: Type -> Type) (m :: Type -> Type) where gServerProof :: Dict (GServerConstraints api m) instance
src/Servant/Server/Internal/Context.hs view
@@ -10,6 +10,8 @@ module Servant.Server.Internal.Context where +import Data.Kind+ (Type) import Data.Proxy import GHC.TypeLits @@ -51,7 +53,7 @@ -- Hint: import it as -- -- > import Servant.Server (type (.++))-type family (.++) (l1 :: [*]) (l2 :: [*]) where+type family (.++) (l1 :: [Type]) (l2 :: [Type]) where '[] .++ a = a (a ': as) .++ b = a ': (as .++ b) @@ -73,7 +75,7 @@ -- ... -- ...No instance for ...HasContextEntry '[] [Char]... -- ...-class HasContextEntry (context :: [*]) (val :: *) where+class HasContextEntry (context :: [Type]) (val :: Type) where getContextEntry :: Context context -> val instance {-# OVERLAPPABLE #-}@@ -90,7 +92,7 @@ -- to have multiple values of the same type in your 'Context' and need to access -- them, we provide 'NamedContext'. You can think of it as sub-namespaces for -- 'Context's.-data NamedContext (name :: Symbol) (subContext :: [*])+data NamedContext (name :: Symbol) (subContext :: [Type]) = NamedContext (Context subContext) -- | 'descendIntoNamedContext' allows you to access `NamedContext's. Usually you
src/Servant/Server/Internal/DelayedIO.hs view
@@ -28,7 +28,7 @@ -- (with the possibility to recover), or fail fatally. -- newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }- deriving+ deriving newtype ( Functor, Applicative, Monad , MonadIO, MonadReader Request , MonadThrow
src/Servant/Server/Internal/ErrorFormatter.hs view
@@ -15,11 +15,10 @@ , mkContextWithErrorFormatter ) where -import Data.String.Conversions- (cs)+import Data.Kind (Type) import Data.Typeable-import Network.Wai.Internal- (Request)+import Network.Wai.Internal (Request)+import qualified Data.ByteString.Lazy.Char8 as BSL8 import Servant.API (Capture, ReqBody)@@ -67,15 +66,15 @@ -- | This formatter does not get neither 'TypeRep' nor error message. type NotFoundErrorFormatter = Request -> ServerError -type MkContextWithErrorFormatter (ctx :: [*]) = ctx .++ DefaultErrorFormatters+type MkContextWithErrorFormatter (ctx :: [Type]) = ctx .++ DefaultErrorFormatters -mkContextWithErrorFormatter :: forall (ctx :: [*]). Context ctx -> Context (MkContextWithErrorFormatter ctx)+mkContextWithErrorFormatter :: forall (ctx :: [Type]). Context ctx -> Context (MkContextWithErrorFormatter ctx) mkContextWithErrorFormatter ctx = ctx .++ (defaultErrorFormatters :. EmptyContext) -- Internal err400Formatter :: ErrorFormatter-err400Formatter _ _ e = err400 { errBody = cs e }+err400Formatter _ _ e = err400 { errBody = BSL8.pack e } -- These definitions suppress "unused import" warning. -- The imorts are needed for Haddock to correctly link to them.
src/Servant/Server/Internal/Handler.hs view
@@ -1,13 +1,10 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PatternSynonyms #-} module Servant.Server.Internal.Handler where -import Prelude ()-import Prelude.Compat- import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch@@ -19,7 +16,7 @@ import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Except- (ExceptT, runExceptT)+ (ExceptT(ExceptT), runExceptT) import Data.String (fromString) import GHC.Generics@@ -28,8 +25,9 @@ (ServerError, errBody, err500) newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }- deriving- ( Functor, Applicative, Monad, MonadIO, Generic+ deriving stock (Generic)+ deriving newtype+ ( Functor, Applicative, Monad, MonadIO , MonadError ServerError , MonadThrow, MonadCatch, MonadMask )@@ -51,3 +49,10 @@ runHandler :: Handler a -> IO (Either ServerError a) runHandler = runExceptT . runHandler'++-- | Pattern synonym that matches directly on the inner 'IO' action.+--+-- To lift 'IO' actions that don't carry a 'ServerError', use 'Control.Monad.IO.Class.liftIO' instead.+pattern MkHandler :: IO (Either ServerError a) -> Handler a+pattern MkHandler ioe = Handler (ExceptT ioe)+{-# COMPLETE MkHandler #-}
src/Servant/Server/Internal/RouteResult.hs view
@@ -28,11 +28,11 @@ deriving (Eq, Show, Read, Functor) instance Applicative RouteResult where- pure = return+ pure = Route (<*>) = ap instance Monad RouteResult where- return = Route+ return = pure Route a >>= f = f a Fail e >>= _ = Fail e FailFatal e >>= _ = FailFatal e@@ -41,14 +41,14 @@ deriving (Functor) instance MonadTrans RouteResultT where- lift = RouteResultT . liftM Route+ lift = RouteResultT . fmap Route instance (Functor m, Monad m) => Applicative (RouteResultT m) where- pure = return+ pure = RouteResultT . return . Route (<*>) = ap instance Monad m => Monad (RouteResultT m) where- return = RouteResultT . return . Route+ return = pure m >>= k = RouteResultT $ do a <- runRouteResultT m case a of
src/Servant/Server/Internal/Router.hs view
@@ -4,9 +4,6 @@ {-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where -import Prelude ()-import Prelude.Compat- import Data.Function (on) import Data.List@@ -213,7 +210,10 @@ -> let request' = request { pathInfo = rest } in runRouterEnv fmt router' (first, env) request' respond CaptureAllRouter _ router' ->- let segments = pathInfo request+ let segments = case pathInfo request of+ -- this case is to handle trailing slashes.+ ("":xs) -> xs+ xs -> xs request' = request { pathInfo = [] } in runRouterEnv fmt router' (segments, env) request' respond RawRouter app ->
src/Servant/Server/Internal/RoutingApplication.hs view
@@ -2,8 +2,6 @@ import Network.Wai (Application, Request, Response, ResponseReceived)-import Prelude ()-import Prelude.Compat import Servant.Server.Internal.RouteResult import Servant.Server.Internal.ServerError
src/Servant/Server/Internal/ServerError.hs view
@@ -392,6 +392,20 @@ , errHeaders = [] } +-- | 'err429' Too Many Requests+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err429 { errBody = "You have sent too many requests in a short period of time." }+--+err429 :: ServerError+err429 = ServerError { errHTTPCode = 429+ , errReasonPhrase = "Too Many Requests"+ , errBody = ""+ , errHeaders = []+ }+ -- | 'err500' Internal Server Error -- -- Example:
src/Servant/Server/UVerb.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -23,10 +22,11 @@ where import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BSL+import Data.Kind (Type) import Data.Proxy (Proxy (Proxy)) import Data.SOP (I (I)) import Data.SOP.Constraint (All, And)-import Data.String.Conversions (LBS, cs) import Network.HTTP.Types (Status, HeaderName, hContentType) import Network.Wai (responseLBS, Request) import Servant.API (ReflectMethod, reflectMethod)@@ -39,14 +39,14 @@ -- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union, -- and will construct a union value in an 'Applicative' (eg. 'Server'). respond ::- forall (x :: *) (xs :: [*]) (f :: * -> *).+ forall (x :: Type) (xs :: [Type]) (f :: Type -> Type). (Applicative f, HasStatus x, IsMember x xs) => x -> f (Union xs) respond = pure . inject . I -class IsServerResource (cts :: [*]) a where- resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)+class IsServerResource (cts :: [Type]) a where+ resourceResponse :: Request -> Proxy cts -> a -> Maybe (BSL.ByteString, BSL.ByteString) resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)] instance {-# OVERLAPPABLE #-} AllCTRender cts a@@ -66,7 +66,7 @@ encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a) => Request -> Proxy cts -> a- -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])+ -> (Status, Maybe (BSL.ByteString, BSL.ByteString), [(HeaderName, B.ByteString)]) encodeResource request cts res = (statusOf (Proxy @a), resourceResponse request cts res, resourceHeaders cts res)@@ -107,10 +107,10 @@ runAction action' env request cont $ \(output :: Union as) -> do let cts = Proxy @contentTypes- pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])+ pickResource :: Union as -> (Status, Maybe (BSL.ByteString, BSL.ByteString), [(HeaderName, B.ByteString)]) pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts) case pickResource output of (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does (status, Just (contentT, body), headers) -> let bdy = if allowedMethodHead method request then "" else body- in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy+ in Route $ responseLBS status ((hContentType, BSL.toStrict contentT) : headers) bdy
test/Servant/Server/ErrorSpec.hs view
@@ -11,10 +11,8 @@ import Data.Aeson (encode) import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy.Char8 as BCL+import qualified Data.ByteString.Lazy.Char8 as BSL8 import Data.Proxy-import Data.String.Conversions- (cs) import Network.HTTP.Types (hAccept, hAuthorization, hContentType, methodGet, methodPost, methodPut)@@ -299,7 +297,7 @@ -- * Custom errors {{{ customFormatter :: ErrorFormatter-customFormatter _ _ err = err400 { errBody = "CUSTOM! " <> cs err }+customFormatter _ _ err = err400 { errBody = "CUSTOM! " <> BSL8.pack err } customFormatters :: ErrorFormatters customFormatters = defaultErrorFormatters@@ -328,7 +326,7 @@ let startsWithCustom = ResponseMatcher { matchStatus = 400 , matchHeaders = []- , matchBody = MatchBody $ \_ body -> if "CUSTOM!" `BCL.isPrefixOf` body+ , matchBody = MatchBody $ \_ body -> if "CUSTOM!" `BSL8.isPrefixOf` body then Nothing else Just $ show body <> " does not start with \"CUSTOM!\"" }@@ -354,8 +352,8 @@ -- * Instances {{{ instance MimeUnrender PlainText Int where- mimeUnrender _ x = maybe (Left "no parse") Right (readMay $ BCL.unpack x)+ mimeUnrender _ x = maybe (Left "no parse") Right (readMay $ BSL8.unpack x) instance MimeRender PlainText Int where- mimeRender _ = BCL.pack . show+ mimeRender _ = BSL8.pack . show -- }}}
test/Servant/Server/StreamingSpec.hs view
@@ -81,10 +81,10 @@ executeRequest :: Application -> Request -> IO Response executeRequest app request = do responseMVar <- newEmptyMVar- let respond response = do+ let respondToRequest response = do putMVar responseMVar response return ResponseReceived- ResponseReceived <- app request respond+ ResponseReceived <- app request respondToRequest takeMVar responseMVar timeout :: IO a -> IO a
test/Servant/Server/UsingContextSpec/TestCombinators.hs view
@@ -20,6 +20,7 @@ import GHC.TypeLits import Servant+import Data.Kind (Type) data ExtractFromContext @@ -32,12 +33,12 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy subApi) pc nt . s route Proxy context delayed =- route subProxy context (fmap inject delayed)+ route subProxy context (fmap injectContext delayed) where subProxy :: Proxy subApi subProxy = Proxy - inject f = f (getContextEntry context)+ injectContext f = f (getContextEntry context) data InjectIntoContext @@ -58,7 +59,7 @@ newContext = ("injected" :: String) :. context -data NamedContextWithBirdface (name :: Symbol) (subContext :: [*])+data NamedContextWithBirdface (name :: Symbol) (subContext :: [Type]) instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) => HasServer (NamedContextWithBirdface name subContext :> subApi) context where
test/Servant/ServerSpec.hs view
@@ -16,7 +16,7 @@ import Prelude.Compat import Control.Monad- (forM_, unless, when)+ (forM_, join, unless, when) import Control.Monad.Reader (runReaderT, ask) import Control.Monad.Error.Class (MonadError (..))@@ -26,6 +26,8 @@ import Data.Acquire (Acquire, mkAcquire) import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Data.ByteString.Base64 as Base64 import Data.Char (toUpper)@@ -35,8 +37,6 @@ (Proxy (Proxy)) import Data.String (fromString)-import Data.String.Conversions- (cs) import qualified Data.Text as T import GHC.Generics (Generic)@@ -53,12 +53,18 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,- Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,- Headers, HttpVersion, IsSecure (..), JSON, Lenient,- NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,+ Delete, Description, EmptyAPI, Fragment, Get, HasStatus (StatusOf),+ Header, Header', Headers, HttpVersion, IsSecure (..), JSON, Lenient,+ NoContent (..), NoContentVerb, NoFraming, OctetStream, Optional, Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM,+ DeepQuery, Delete, EmptyAPI, Fragment, Get,+ HasStatus (StatusOf), Header, Headers, HttpVersion,+ IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb,+ NoFraming, OctetStream, Patch, PlainText, Post, Put,+ QueryFlag, QueryParam, QueryParams, QueryString, Raw, RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,- UVerb, Union, Verb, WithStatus (..), addHeader)+ UVerb, Union, Verb, WithStatus (..), addHeader, addHeader')+import Servant.API.QueryString (FromDeepQuery(..)) import Servant.Server (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..), emptyServer, err401, err403, err404, hoistServer, respond, serve,@@ -71,6 +77,7 @@ (get, matchHeaders, matchStatus, shouldRespondWith, with, (<:>)) import qualified Test.Hspec.Wai as THW+import Text.Read (readMaybe) import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler)@@ -121,6 +128,7 @@ :<|> "noContent" :> NoContentVerb method :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person) :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)+ :<|> "headerD" :> Verb method status '[JSON] (Headers '[Header' '[Description "desc", Optional, Strict] "H" Int] Person) :<|> "accept" :> ( Verb method status '[JSON] Person :<|> Verb method status '[PlainText] String )@@ -133,6 +141,7 @@ :<|> return NoContent :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent)+ :<|> return (addHeader' 5 alice) :<|> (return alice :<|> return "B") :<|> return (S.source ["bytestring"]) @@ -164,9 +173,8 @@ response <- THW.request method "/" [] "" liftIO $ simpleBody response `shouldBe` "" - it "throws 405 on wrong method " $ do- THW.request (wrongMethod method) "/" [] ""- `shouldRespondWith` 405+ it "throws 405 on wrong method " $ THW.request (wrongMethod method) "/" [] ""+ `shouldRespondWith` 405 it "returns headers" $ do response1 <- THW.request method "/header" [] ""@@ -177,13 +185,16 @@ liftIO $ statusCode (simpleStatus response2) `shouldBe` status liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")] + response3 <- THW.request method "/headerD" [] ""+ liftIO $ statusCode (simpleStatus response3) `shouldBe` status+ liftIO $ simpleHeaders response3 `shouldContain` [("H", "5")]+ it "handles trailing '/' gracefully" $ do response <- THW.request method "/headerNC/" [] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status - it "returns 406 if the Accept header is not supported" $ do- THW.request method "" [(hAccept, "crazy/mime")] ""- `shouldRespondWith` 406+ it "returns 406 if the Accept header is not supported" $ THW.request method "" [(hAccept, "crazy/mime")] ""+ `shouldRespondWith` 406 it "responds if the Accept header is supported" $ do response <- THW.request method ""@@ -242,103 +253,140 @@ getEyes _ = throwError err404 captureSpec :: Spec-captureSpec = do- describe "Servant.API.Capture" $ do- with (return (serve captureApi captureServer)) $ do+captureSpec = describe "Servant.API.Capture" $ do+ with (return (serve captureApi captureServer)) $ do - it "can capture parts of the 'pathInfo'" $ do- response <- get "/2"- liftIO $ decode' (simpleBody response) `shouldBe` Just tweety+ it "can capture parts of the 'pathInfo'" $ do+ response <- get "/2"+ liftIO $ decode' (simpleBody response) `shouldBe` Just tweety - it "returns 400 if the decoding fails" $ do- get "/notAnInt" `shouldRespondWith` 400+ it "returns 400 if the decoding fails" $ get "/notAnInt" `shouldRespondWith` 400 - it "returns an animal if eyes or ears are 2" $ do- get "/ears/2" `shouldRespondWith` 200- get "/eyes/2" `shouldRespondWith` 200+ it "returns an animal if eyes or ears are 2" $ do+ get "/ears/2" `shouldRespondWith` 200+ get "/eyes/2" `shouldRespondWith` 200 - it "returns a weird animal on Lenient Capture" $ do- response <- get "/ears/bla"- liftIO $ decode' (simpleBody response) `shouldBe` Just chimera+ it "returns a weird animal on Lenient Capture" $ do+ response <- get "/ears/bla"+ liftIO $ decode' (simpleBody response) `shouldBe` Just chimera - it "returns 400 if parsing integer fails on Strict Capture" $ do- get "/eyes/bla" `shouldRespondWith` 400+ it "returns 400 if parsing integer fails on Strict Capture" $ get "/eyes/bla" `shouldRespondWith` 400 - with (return (serve- (Proxy :: Proxy (Capture "captured" String :> Raw))- (\ "captured" -> Tagged $ \request_ sendResponse ->- sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do- it "strips the captured path snippet from pathInfo" $ do- get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))+ with (return (serve+ (Proxy :: Proxy (Capture "captured" String :> Raw))+ (\ "captured" -> Tagged $ \request_ sendResponse ->+ sendResponse $ responseLBS ok200 [] (BSL8.pack $ show $ pathInfo request_))))+ $ it "strips the captured path snippet from pathInfo" $ get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) -- }}} ------------------------------------------------------------------------------ -- * captureAllSpec {{{ ------------------------------------------------------------------------------ -type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal+type CaptureAllApi = "legs" :> CaptureAll "legs" Integer :> Get '[JSON] Animal+ :<|> "arms" :> CaptureAll "arms" String :> Get '[JSON] [String] captureAllApi :: Proxy CaptureAllApi captureAllApi = Proxy-captureAllServer :: [Integer] -> Handler Animal-captureAllServer legs = case sum legs of- 4 -> return jerry- 2 -> return tweety- 0 -> return beholder- _ -> throwError err404+captureAllServer :: Server CaptureAllApi+captureAllServer = handleLegs :<|> return+ where+ handleLegs [] = return beholder+ handleLegs legs = case sum legs of+ 4 -> return jerry+ 2 -> return tweety+ _ -> throwError err404 +type RootedCaptureAllApi = CaptureAll "xs" String :> Get '[JSON] [String]+ captureAllSpec :: Spec captureAllSpec = do+ let getStringList = decode' @[String] . simpleBody+ describe "Servant.API.CaptureAll" $ do with (return (serve captureAllApi captureAllServer)) $ do it "can capture a single element of the 'pathInfo'" $ do- response <- get "/2"+ response <- get "/legs/2" liftIO $ decode' (simpleBody response) `shouldBe` Just tweety it "can capture multiple elements of the 'pathInfo'" $ do- response <- get "/2/2"+ response <- get "/legs/2/2" liftIO $ decode' (simpleBody response) `shouldBe` Just jerry it "can capture arbitrarily many elements of the 'pathInfo'" $ do- response <- get "/1/1/0/1/0/1"+ response <- get "/legs/1/1/0/1/0/1" liftIO $ decode' (simpleBody response) `shouldBe` Just jerry it "can capture when there are no elements in 'pathInfo'" $ do- response <- get "/"+ response <- get "/legs/" liftIO $ decode' (simpleBody response) `shouldBe` Just beholder - it "returns 400 if the decoding fails" $ do- get "/notAnInt" `shouldRespondWith` 400+ it "returns 400 if the decoding fails" $ get "/legs/notAnInt" `shouldRespondWith` 400 - it "returns 400 if the decoding fails, regardless of which element" $ do- get "/1/0/0/notAnInt/3/" `shouldRespondWith` 400+ it "returns 400 if the decoding fails, regardless of which element" $ get "/legs/1/0/0/notAnInt/3/" `shouldRespondWith` 400 - it "returns 400 if the decoding fails, even when it's multiple elements" $ do- get "/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400+ it "returns 400 if the decoding fails, even when it's multiple elements" $ get "/legs/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400 + it "can capture single String" $ do+ response <- get "/arms/jerry"+ liftIO $ getStringList response `shouldBe` Just ["jerry"]++ it "can capture when there are no elements in 'pathinfo'" $ do+ response <- get "/arms/"+ liftIO $ getStringList response `shouldBe` Just []++ it "can capture empty string from captureall" $ do+ response <- get "/arms//"+ liftIO $ getStringList response `shouldBe` Just [""]++ with (return (serve (Proxy :: Proxy RootedCaptureAllApi) return)) $ do+ it "can capture empty rooted capture all" $ do+ response <- get "/"+ liftIO $ getStringList response `shouldBe` Just []++ it "can capture empty string from rooted capture all" $ do+ response <- get "//"+ liftIO $ getStringList response `shouldBe` Just [""]+ with (return (serve (Proxy :: Proxy (CaptureAll "segments" String :> Raw)) (\ _captured -> Tagged $ \request_ sendResponse ->- sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do- it "consumes everything from pathInfo" $ do- get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))+ sendResponse $ responseLBS ok200 [] (BSL8.pack $ show $ pathInfo request_))))+ $ it "consumes everything from pathInfo"+ $ get "/captured/foo/bar/baz" `shouldRespondWith` fromString (show ([] :: [Int])) -- }}} ------------------------------------------------------------------------------ -- * queryParamSpec {{{ ------------------------------------------------------------------------------ +data Filter = Filter+ { ageFilter :: Integer+ , nameFilter :: String+ }+ deriving Show++instance FromDeepQuery Filter where+ fromDeepQuery params = do+ let maybeToRight l = maybe (Left l) Right+ age' <- maybeToRight "missing age" $ readMaybe . T.unpack =<< join (lookup ["age"] params)+ name' <- maybeToRight "missing name" $ join $ lookup ["name"] params+ return $ Filter age' (T.unpack name')++ 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+ :<|> "raw-query-string" :> QueryString :> Get '[JSON] Person+ :<|> "deep-query" :> DeepQuery "filter" Filter :> Get '[JSON] Person queryParamApi :: Proxy QueryParamApi queryParamApi = Proxy qpServer :: Server QueryParamApi-qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges+qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges :<|> qpRaw :<|> qpDeep where qpNames (_:name2:_) = return alice { name = name2 } qpNames _ = return alice@@ -351,6 +399,15 @@ qpAges ages = return alice{ age = sum ages} + qpRaw q = return alice { name = maybe mempty BS8.unpack $ join (lookup "name" q)+ , age = fromMaybe 0 (readMaybe . BS8.unpack =<< join (lookup "age" q))+ }++ qpDeep filter' =+ return alice { name = nameFilter filter'+ , age = ageFilter filter'+ }+ queryParamServer (Just name_) = return alice{name = name_} queryParamServer Nothing = return alice @@ -422,11 +479,27 @@ { name = "Alice" } + it "allows retrieving a full query string" $+ flip runSession (serve queryParamApi qpServer) $ do+ response <- mkRequest "?age=32&name=john" ["raw-query-string"]+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice+ { name = "john"+ , age = 32+ }++ it "allows retrieving a query string deep object" $+ flip runSession (serve queryParamApi qpServer) $ do+ response <- mkRequest "?filter[age]=32&filter[name]=john" ["deep-query"]+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice+ { name = "john"+ , age = 32+ }+ describe "Uses queryString instead of rawQueryString" $ do -- test query parameters rewriter let queryRewriter :: Middleware queryRewriter app req = app req- { queryString = fmap rewrite $ queryString req+ { queryString = rewrite <$> queryString req } where rewrite :: QueryItem -> QueryItem@@ -497,11 +570,9 @@ , pathInfo = pinfo } - describe "Servant.API.Fragment" $ do- it "ignores fragment even if it is present in query" $ do- flip runSession (serve fragmentApi fragServer) $ do- response1 <- mkRequest "#Alice" ["name"]- liftIO $ decode' (simpleBody response1) `shouldBe` Just alice+ describe "Servant.API.Fragment" $ it "ignores fragment even if it is present in query" $ flip runSession (serve fragmentApi fragServer) $ do+ response1 <- mkRequest "#Alice" ["name"]+ liftIO $ decode' (simpleBody response1) `shouldBe` Just alice -- }}} ------------------------------------------------------------------------------@@ -527,12 +598,10 @@ response <- mkReq methodPost "" (encode alice) liftIO $ decode' (simpleBody response) `shouldBe` Just alice - it "rejects invalid request bodies with status 400" $ do- mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400+ it "rejects invalid request bodies with status 400" $ mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400 - it "responds with 415 if the request body media type is unsupported" $ do- THW.request methodPost "/"- [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415+ it "responds with 415 if the request body media type is unsupported" $ THW.request methodPost "/"+ [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415 -- }}} ------------------------------------------------------------------------------@@ -590,26 +659,21 @@ rawApplication :: Show a => (Request -> a) -> Tagged m Application rawApplication f = Tagged $ \request_ sendResponse -> sendResponse $ responseLBS ok200 []- (cs $ show $ f request_)+ (BSL8.pack $ show $ f request_) rawSpec :: Spec-rawSpec = do- describe "Servant.API.Raw" $ do- it "runs applications" $ do- flip runSession (serve rawApi (rawApplication (const (42 :: Integer)))) $ do- response <- Network.Wai.Test.request defaultRequest{- pathInfo = ["foo"]- }- liftIO $ do- simpleBody response `shouldBe` "42"+rawSpec = describe "Servant.API.Raw" $ do+ it "runs applications" $ flip runSession (serve rawApi (rawApplication (const (42 :: Integer)))) $ do+ response <- Network.Wai.Test.request defaultRequest{+ pathInfo = ["foo"]+ }+ liftIO $ simpleBody response `shouldBe` "42" - it "gets the pathInfo modified" $ do- flip runSession (serve rawApi (rawApplication pathInfo)) $ do- response <- Network.Wai.Test.request defaultRequest{- pathInfo = ["foo", "bar"]- }- liftIO $ do- simpleBody response `shouldBe` cs (show ["bar" :: String])+ it "gets the pathInfo modified" $ flip runSession (serve rawApi (rawApplication pathInfo)) $ do+ response <- Network.Wai.Test.request defaultRequest{+ pathInfo = ["foo", "bar"]+ }+ liftIO $ simpleBody response `shouldBe` BSL8.pack (show ["bar" :: String]) -- }}} ------------------------------------------------------------------------------@@ -621,36 +685,29 @@ rawMApi :: Proxy RawMApi rawMApi = Proxy -rawMServer :: (Monad m, MonadIO m, Show a) => (Request -> m a) -> ServerT RawMApi m-rawMServer f req resp = liftIO . resp . responseLBS ok200 [] . cs . show =<< f req+rawMServer :: (MonadIO m, Show a) => (Request -> m a) -> ServerT RawMApi m+rawMServer f req resp = liftIO . resp . responseLBS ok200 [] . BSL8.pack . show =<< f req rawMSpec :: Spec-rawMSpec = do- describe "Servant.API.RawM" $ do- it "gives access to monadic context" $ do- flip runSession (serve rawMApi- (hoistServer rawMApi (flip runReaderT (42 :: Integer)) (rawMServer (const ask)))) $ do- response <- Network.Wai.Test.request defaultRequest{- pathInfo = ["foo"]- }- liftIO $ do- simpleBody response `shouldBe` "42"+rawMSpec = describe "Servant.API.RawM" $ do+ it "gives access to monadic context" $ flip runSession (serve rawMApi+ (hoistServer rawMApi (`runReaderT` (42 :: Integer)) (rawMServer (const ask)))) $ do+ response <- Network.Wai.Test.request defaultRequest{+ pathInfo = ["foo"]+ }+ liftIO $ simpleBody response `shouldBe` "42" - it "lets users throw servant errors" $ do- flip runSession (serve rawMApi (rawMServer (const $ throwError err404 >> pure (42 :: Integer)))) $ do- response <- Network.Wai.Test.request defaultRequest{- pathInfo = ["foo"]- }- liftIO $ do- statusCode (simpleStatus response) `shouldBe` 404+ it "lets users throw servant errors" $ flip runSession (serve rawMApi (rawMServer (const $ throwError err404 >> pure (42 :: Integer)))) $ do+ response <- Network.Wai.Test.request defaultRequest{+ pathInfo = ["foo"]+ }+ liftIO $ statusCode (simpleStatus response) `shouldBe` 404 - it "gets the pathInfo modified" $ do- flip runSession (serve rawMApi (rawMServer (pure . pathInfo))) $ do- response <- Network.Wai.Test.request defaultRequest{- pathInfo = ["foo", "bar"]- }- liftIO $ do- simpleBody response `shouldBe` cs (show ["bar" :: String])+ it "gets the pathInfo modified" $ flip runSession (serve rawMApi (rawMServer (pure . pathInfo))) $ do+ response <- Network.Wai.Test.request defaultRequest{+ pathInfo = ["foo", "bar"]+ }+ liftIO $ simpleBody response `shouldBe` BSL8.pack (show ["bar" :: String]) -- }}} ------------------------------------------------------------------------------ -- * alternativeSpec {{{@@ -676,25 +733,19 @@ :<|> return NoContent alternativeSpec :: Spec-alternativeSpec = do- describe "Servant.API.Alternative" $ do- with (return $ serve alternativeApi alternativeServer) $ do+alternativeSpec = describe "Servant.API.Alternative" $ with (return $ serve alternativeApi alternativeServer) $ do - it "unions endpoints" $ do- response <- get "/foo"- liftIO $ do- decode' (simpleBody response) `shouldBe`- Just alice- response_ <- get "/bar"- liftIO $ do- decode' (simpleBody response_) `shouldBe`- Just jerry+ it "unions endpoints" $ do+ response <- get "/foo"+ liftIO $ decode' (simpleBody response) `shouldBe`+ Just alice+ response_ <- get "/bar"+ liftIO $ decode' (simpleBody response_) `shouldBe`+ Just jerry - it "checks all endpoints before returning 415" $ do- get "/foo" `shouldRespondWith` 200+ it "checks all endpoints before returning 415" $ get "/foo" `shouldRespondWith` 200 - it "returns 404 if the path does not exist" $ do- get "/nonexistent" `shouldRespondWith` 404+ it "returns 404 if the path does not exist" $ get "/nonexistent" `shouldRespondWith` 404 -- }}} ------------------------------------------------------------------------------ -- * responseHeaderSpec {{{@@ -712,27 +763,26 @@ responseHeadersSpec :: Spec-responseHeadersSpec = describe "ResponseHeaders" $ do- with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do+responseHeadersSpec = describe "ResponseHeaders" $ with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do - let methods = [methodGet, methodPost, methodPut, methodPatch]+ let methods = [methodGet, methodPost, methodPut, methodPatch] - it "includes the headers in the response" $- forM_ methods $ \method ->- THW.request method "/" [] ""- `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]- , matchStatus = 200- }+ it "includes the headers in the response" $+ forM_ methods $ \method ->+ THW.request method "/" [] ""+ `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]+ , matchStatus = 200+ } - it "responds with not found for non-existent endpoints" $- forM_ methods $ \method ->- THW.request method "blahblah" [] ""- `shouldRespondWith` 404+ it "responds with not found for non-existent endpoints" $+ forM_ methods $ \method ->+ THW.request method "blahblah" [] ""+ `shouldRespondWith` 404 - it "returns 406 if the Accept header is not supported" $- forM_ methods $ \method ->- THW.request method "" [(hAccept, "crazy/mime")] ""- `shouldRespondWith` 406+ it "returns 406 if the Accept header is not supported" $+ forM_ methods $ \method ->+ THW.request method "" [(hAccept, "crazy/mime")] ""+ `shouldRespondWith` 406 -- }}} ------------------------------------------------------------------------------@@ -750,14 +800,11 @@ uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String) uverbResponseHeadersSpec :: Spec-uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do- with (return $ serve (Proxy :: Proxy UVerbResponseHeadersApi) uverbResponseHeadersServer) $ do-- it "includes the headers in the response" $- THW.request methodGet "/true" [] ""- `shouldRespondWith` "\"foo\"" { matchHeaders = ["H1" <:> "5"]- , matchStatus = 200- }+uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ with (return $ serve (Proxy :: Proxy UVerbResponseHeadersApi) uverbResponseHeadersServer) $ it "includes the headers in the response" $+ THW.request methodGet "/true" [] ""+ `shouldRespondWith` "\"foo\"" { matchHeaders = ["H1" <:> "5"]+ , matchStatus = 200+ } -- }}} ------------------------------------------------------------------------------@@ -815,7 +862,7 @@ basicAuthServer :: Server BasicAuthAPI basicAuthServer = const (return jerry) :<|>- (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")+ Tagged (\ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext =@@ -826,26 +873,22 @@ in basicHandler :. EmptyContext basicAuthSpec :: Spec-basicAuthSpec = do- describe "Servant.API.BasicAuth" $ do- with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do-- context "Basic Authentication" $ do- let basicAuthHeaders user password =- [("Authorization", "Basic " <> Base64.encode (user <> ":" <> password))]- it "returns 401 when no credentials given" $ do- get "/basic" `shouldRespondWith` 401+basicAuthSpec = describe "Servant.API.BasicAuth" $ with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ context "Basic Authentication" $ do+ let basicAuthHeaders user password =+ [("Authorization", "Basic " <> Base64.encode (user <> ":" <> password))]+ it "returns 401 when no credentials given" $ do+ get "/basic" `shouldRespondWith` 401 - it "returns 403 when invalid credentials given" $ do- THW.request methodGet "/basic" (basicAuthHeaders "servant" "wrong") ""- `shouldRespondWith` 403+ it "returns 403 when invalid credentials given" $ do+ THW.request methodGet "/basic" (basicAuthHeaders "servant" "wrong") ""+ `shouldRespondWith` 403 - it "returns 200 with the right password" $ do- THW.request methodGet "/basic" (basicAuthHeaders "servant" "server") ""- `shouldRespondWith` 200+ it "returns 200 with the right password" $ do+ THW.request methodGet "/basic" (basicAuthHeaders "servant" "server") ""+ `shouldRespondWith` 200 - it "plays nice with subsequent Raw endpoints" $ do- get "/foo" `shouldRespondWith` 418+ it "plays nice with subsequent Raw endpoints" $ do+ get "/foo" `shouldRespondWith` 418 -- }}} ------------------------------------------------------------------------------@@ -860,7 +903,7 @@ genAuthServer :: Server GenAuthAPI genAuthServer = const (return tweety)- :<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")+ :<|> Tagged (\ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") type instance AuthServerData (AuthProtect "auth") = () @@ -873,22 +916,18 @@ in mkAuthHandler authHandler :. EmptyContext genAuthSpec :: Spec-genAuthSpec = do- describe "Servant.API.Auth" $ do- with (return (serveWithContext genAuthApi genAuthContext genAuthServer)) $ do-- context "Custom Auth Protection" $ do- it "returns 401 when missing headers" $ do- get "/auth" `shouldRespondWith` 401+genAuthSpec = describe "Servant.API.Auth" $ with (return (serveWithContext genAuthApi genAuthContext genAuthServer)) $ context "Custom Auth Protection" $ do+ it "returns 401 when missing headers" $ do+ get "/auth" `shouldRespondWith` 401 - it "returns 403 on wrong passwords" $ do- THW.request methodGet "/auth" [("Auth","wrong")] "" `shouldRespondWith` 403+ it "returns 403 on wrong passwords" $ do+ THW.request methodGet "/auth" [("Auth","wrong")] "" `shouldRespondWith` 403 - it "returns 200 with the right header" $ do- THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200+ it "returns 200 with the right header" $ do+ THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200 - it "plays nice with subsequent Raw endpoints" $ do- get "/foo" `shouldRespondWith` 418+ it "plays nice with subsequent Raw endpoints" $ do+ get "/foo" `shouldRespondWith` 418 -- }}} ------------------------------------------------------------------------------