servant-server 0.8.1 → 0.20.3.0
raw patch · 39 files changed
Files
- CHANGELOG.md +380/−0
- LICENSE +1/−1
- README.md +1/−1
- example/greet.hs +19/−3
- include/overlapping-compat.h +0/−8
- servant-server.cabal +164/−104
- src/Servant.hs +6/−5
- src/Servant/Server.hs +111/−52
- src/Servant/Server/Experimental/Auth.hs +34/−29
- src/Servant/Server/Generic.hs +94/−0
- src/Servant/Server/Internal.hs +1193/−530
- src/Servant/Server/Internal/BasicAuth.hs +23/−16
- src/Servant/Server/Internal/Context.hs +28/−19
- src/Servant/Server/Internal/Delayed.hs +272/−0
- src/Servant/Server/Internal/DelayedIO.hs +71/−0
- src/Servant/Server/Internal/ErrorFormatter.hs +86/−0
- src/Servant/Server/Internal/Handler.hs +58/−0
- src/Servant/Server/Internal/ResponseRender.hs +184/−0
- src/Servant/Server/Internal/RouteResult.hs +76/−0
- src/Servant/Server/Internal/Router.hs +95/−45
- src/Servant/Server/Internal/RoutingApplication.hs +6/−265
- src/Servant/Server/Internal/ServantErr.hs +0/−447
- src/Servant/Server/Internal/ServerError.hs +491/−0
- src/Servant/Server/StaticFiles.hs +83/−0
- src/Servant/Server/UVerb.hs +116/−0
- src/Servant/Utils/StaticFiles.hs +5/−44
- test/Doctests.hs +0/−41
- test/Servant/ArbitraryMonadServerSpec.hs +13/−9
- test/Servant/HoistSpec.hs +39/−0
- test/Servant/Server/ErrorSpec.hs +108/−22
- test/Servant/Server/Internal/ContextSpec.hs +9/−6
- test/Servant/Server/Internal/RoutingApplicationSpec.hs +151/−0
- test/Servant/Server/RouterSpec.hs +194/−26
- test/Servant/Server/StaticFilesSpec.hs +71/−0
- test/Servant/Server/StreamingSpec.hs +10/−9
- test/Servant/Server/UsingContextSpec.hs +4/−3
- test/Servant/Server/UsingContextSpec/TestCombinators.hs +21/−12
- test/Servant/ServerSpec.hs +594/−259
- test/Servant/Utils/StaticFilesSpec.hs +0/−62
CHANGELOG.md view
@@ -1,3 +1,383 @@+[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md)+[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)++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.3.0+--------++### Significant changes++- Remove -XStrictData from servant{,-server}'s cabal files [#1780](https://github.com/haskell-servant/servant/issues/1780) [#1781](https://github.com/haskell-servant/servant/pull/1781)++ The addition of -XStrictData to servant.cabal and servant-server.cabal reduced the laziness+ of routing, which would trigger unimplemented endpoints using `error` or `undefined`,+ despite the fact that these endpoints themselves were not queried.++### Other changes++- Server-sent events (SSE) for client-side [#1811](https://github.com/haskell-servant/servant/issues/1811)++ Implement Server-sent events (SSE) for the Servant client using a new+ combinator "ServerSentEvents". The raw event messages, accumulated events and+ JSON-processed events can be exposed.++- Integrate MultiVerb [#1766](https://github.com/haskell-servant/servant/pull/1766) [#1804](https://github.com/haskell-servant/servant/pull/1804)++ Expose MultiVerb, a more ergonomic way of defining endpoints that return+ many kinds of responses. Read the cookbook https://docs.servant.dev/en/master/cookbook/multiverb/MultiVerb.html++- Add Host API combinator [#1800](https://github.com/haskell-servant/servant/pull/1800)++ Adding a Host combinator allows servant users to select APIs according+ to the Host header provided by clients.++- Add public re-export of renderCurlBasePath lens [#1706](https://github.com/haskell-servant/servant/pull/1706)+- Remove GHC <= 8.10.7 from the support window [#1778](https://github.com/haskell-servant/servant/pull/1778)+- Add Servant.API.Range type [#1805](https://github.com/haskell-servant/servant/pull/1805)+- Add missing HasLink instance for DeepQuery [#1784](https://github.com/haskell-servant/servant/issues/1784)++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+----++- Add API docs for ServerT [#1573](https://github.com/haskell-servant/servant/pull/1573)+- Add Functor instance to AuthHandler. [#1638](https://github.com/haskell-servant/servant/pull/1638)+- Compatibility with GHC 9.6. [#1680](https://github.com/haskell-servant/servant/pull/1680)++0.19.2+------++Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).++0.19.1+------++- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)+- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)+- Add capture hints in `Router` type for debug and display purposes [PR #1556] (https://github.com/haskell-servant/servant/pull/1556)++0.19+----++### Significant changes++- Drop support for GHC < 8.6.+- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).+- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),+ which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)+ related to hash collisions.+- Add `NamedRoutes` combinator, making support for records first-class in Servant+ ([#1388](https://github.com/haskell-servant/servant/pull/1388)).+- Add custom type errors for partially applied combinators+ ([#1289](https://github.com/haskell-servant/servant/pull/1289),+ [#1486](https://github.com/haskell-servant/servant/pull/1486)).++0.18.3+------++### Significant changes++- Add response header support to UVerb (#1420)++### Other changes++- Support GHC-9.0.1.+- Bump `bytestring`, `hspec` and `base64-bytestring` dependencies.++0.18.2+------++### Significant changes++- Support `Fragment` combinator.++0.18.1+------++### Significant changes++- Union verbs++### Other changes++- Bump "tested-with" ghc versions+- Allow newer dependencies++0.18+----++### Significant changes++- Support for ghc8.8 (#1318, #1326, #1327)++- Configurable error messages for automatic errors thrown by servant,+ like "no route" or "could not parse json body" (#1312, #1326, #1327)+++0.17+----++### Significant changes++- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)++ The `NoContent` API endpoints should now use `NoContentVerb` combinator.+ The API type changes are usually of the kind++ ```diff+ - :<|> PostNoContent '[JSON] NoContent+ + :<|> PostNoContent+ ```++ i.e. one doesn't need to specify the content-type anymore. There is no content.++- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)++ You can specify a lenient capture as++ ```haskell+ :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET+ ```++ which will make the capture always succeed. Handlers will be of the+ type `Either String CapturedType`, where `Left err` represents+ the possible parse failure.++- *servant-server* use queryString to parse QueryParam, QueryParams and QueryFlag [#1249](https://github.com/haskell-servant/servant/pull/1249) [#1262](https://github.com/haskell-servant/servant/pull/1262)++ Some APIs need query parameters rewriting, e.g. in order to support+ for multiple casing (camel, snake, etc) or something to that effect.++ This could be easily achieved by using WAI Middleware and modifying+ request's `Query`. But QueryParam, QueryParams and QueryFlag use+ `rawQueryString`. By using `queryString` rather then `rawQueryString`+ we can enable such rewritings.++- *servant* *servant-server* Make packages `build-type: Simple` [#1263](https://github.com/haskell-servant/servant/pull/1263)++ We used `build-type: Custom`, but it's problematic e.g.+ for cross-compiling. The benefit is small, as the doctests+ can be run other ways too (though not so conveniently).++0.16.2+------++* `singleton-bool-0.1.5` (`SBool` is re-exported)+ - Add `discreteBool :: Dec (a :~: b)` (GHC-7.8+)+ - Add `Show`, `Eq`, `Ord` `SBool b` instances.+* dependencies update++0.16.1+------++* Use `http-api-data-0.4.1` (a part of its API is re-exported)+ [#1181](https://github.com/haskell-servant/servant/pull/1181)++0.16+----++- Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError`+ [#1131](https://github.com/haskell-servant/servant/pull/1131)+- *servant-server* Reorder HTTP failure code priorities+ [#1103](https://github.com/haskell-servant/servant/pull/1103)+- *servant-server* Re-organise internal modules+ [#1139](https://github.com/haskell-servant/servant/pull/1139)+- Allow `network-3.0`+ [#1107](https://github.com/haskell-servant/servant/pull/1107)++0.15+----++- Streaming refactoring.+ [#991](https://github.com/haskell-servant/servant/pull/991)+ [#1076](https://github.com/haskell-servant/servant/pull/1076)+ [#1077](https://github.com/haskell-servant/servant/pull/1077)++ The streaming functionality (`Servant.API.Stream`) is refactored to use+ `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation),+ which replaces both `StreamGenerator` and `ResultStream` types.++ New conversion type-classes are `ToSourceIO` and `FromSourceIO`+ (replacing `ToStreamGenerator` and `BuildFromStream`).+ There are instances for *conduit*, *pipes* and *machines* in new packages:+ [servant-conduit](https://hackage.haskell.org/package/servant-conduit)+ [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and+ [servant-machines](https://hackage.haskell.org/package/servant-machines)+ respectively.++ Writing new framing strategies is simpler. Check existing strategies for examples.++ This change shouldn't affect you, if you don't use streaming endpoints.++- Drop support for GHC older than 8.0+ [#1008](https://github.com/haskell-servant/servant/pull/1008)+ [#1009](https://github.com/haskell-servant/servant/pull/1009)++- *servant* NewlineFraming encodes newline after each element (i.e last)+ [#1079](https://github.com/haskell-servant/servant/pull/1079)+ [#1011](https://github.com/haskell-servant/servant/issues/1011)++- *servant* Add `lookupResponseHeader :: ... => Headers headers r -> ResponseHeader h a`+ [#1064](https://github.com/haskell-servant/servant/pull/1064)++- *servant-server* Add `MonadMask Handler`+ [#1068](https://github.com/haskell-servant/servant/pull/1068)++- *servant* Export `GetHeaders'`+ [#1052](https://github.com/haskell-servant/servant/pull/1052)++- *servant* Add `Bitraversable` and other `Bi-` instances for `:<|>`+ [#1032](https://github.com/haskell-servant/servant/pull/1032)++- *servant* Add `PutCreated` method type alias+ [#1024](https://github.com/haskell-servant/servant/pull/1024)++- *servant* Add `ToSourceIO (NonEmpty a)` instance+ [#988](https://github.com/haskell-servant/servant/pull/988)++0.14.1+------++- Merge in `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick))+ into `servant` (`Servant.API.Generic`),+ `servant-client-code` (`Servant.Client.Generic`)+ and `servant-server` (`Servant.Server.Generic`).++- *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`.++0.14+----++- `Stream` takes a status code argument++ ```diff+ -Stream method framing ctype a+ +Stream method status framing ctype a+ ```++ ([#966](https://github.com/haskell-servant/servant/pull/966)+ [#972](https://github.com/haskell-servant/servant/pull/972))++- `ToStreamGenerator` definition changed, so it's possible to write an instance+ for conduits.++ ```diff+ -class ToStreamGenerator f a where+ - toStreamGenerator :: f a -> StreamGenerator a+ +class ToStreamGenerator a b | a -> b where+ + toStreamGenerator :: a -> StreamGenerator b+ ```++ ([#959](https://github.com/haskell-servant/servant/pull/959))++- Added `NoFraming` streaming strategy+ ([#959](https://github.com/haskell-servant/servant/pull/959))++- *servant-server* File serving in polymorphic monad.+ i.e. Generalised types of `serveDirectoryFileServer` etc functions in+ `Servant.Utils.StaticFiles`+ ([#953](https://github.com/haskell-servant/servant/pull/953))++- *servant-server* `ReqBody` content type check is recoverable.+ This allows writing APIs like:++ ```haskell+ ReqBody '[JSON] Int :> Post '[PlainText] Int+ :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int+ ```++ which is useful when handlers are subtly different,+ for example may do less work.+ ([#937](https://github.com/haskell-servant/servant/pull/937))+++0.13.0.1+--------++- Support `base-compat-0.10`++0.13+----++- Streaming endpoint support.+ ([#836](https://github.com/haskell-servant/servant/pull/836))+- *servant* Add `Servant.API.Modifiers`+ ([#873](https://github.com/haskell-servant/servant/pull/873))++0.12+----++### Breaking changes++* Added `hoistServer` member to the `HasServer` class, which is `HasServer`+ specific `enter`.+ ([#804](https://github.com/haskell-servant/servant/pull/804))++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+----++### Breaking changes++* `Handler` is now an abstract datatype. Migration hint: change `throwE` to `throwError`.+ ([#641](https://github.com/haskell-servant/servant/issues/641))++* Changed `HasServer` instances for `QueryParam` and `QueryParam` to throw 400+ when parsing fails+ ([#649](https://github.com/haskell-servant/servant/pull/649))++### Other changes++* Added `paramsD` block to `Delayed`++* Add `err422` Unprocessable Entity+ ([#646](https://github.com/haskell-servant/servant/pull/646))++* Deprecate `serveDirectory` and introduce `serveDirectoryFileServer`,+ `serveDirectoryWebApp`, `serveDirectoryWebAppLookup`, `serveDirectoryEmbedded`+ and `serveDirectoryWith` which offer 4 default options and a more flexible+ one for serving static files.+ ([#658](https://github.com/haskell-servant/servant/pull/658))++* `DelayedIO` is an instance of `MonadResource`, allowing safe resource handling.+ ([#622](https://github.com/haskell-servant/servant/pull/622)+ , [#674](https://github.com/haskell-servant/servant/pull/674)+ , [#675](https://github.com/haskell-servant/servant/pull/675))+ 0.7.1 ------
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors All rights reserved.
README.md view
@@ -6,4 +6,4 @@ ## Getting started -We've written a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples.+We've written a [tutorial](http://docs.servant.dev/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples.
example/greet.hs view
@@ -1,12 +1,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +import Prelude ()+import Prelude.Compat+ import Data.Aeson-import Data.Monoid import Data.Proxy import Data.Text import GHC.Generics@@ -14,6 +17,7 @@ import Network.Wai.Handler.Warp import Servant+import Servant.Server.Generic () -- * Example @@ -36,6 +40,14 @@ -- DELETE /greet/:greetid :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent + :<|> NamedRoutes OtherRoutes++data OtherRoutes mode = OtherRoutes+ { version :: mode :- Get '[JSON] Int+ , bye :: mode :- "bye" :> Capture "name" Text :> Get '[JSON] Text+ }+ deriving Generic+ testApi :: Proxy TestApi testApi = Proxy @@ -46,9 +58,13 @@ -- -- Each handler runs in the 'Handler' monad. server :: Server TestApi-server = helloH :<|> postGreetH :<|> deleteGreetH+server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes+ where otherRoutes = OtherRoutes {..} - where helloH name Nothing = helloH name (Just False)+ bye name = pure $ "Bye, " <> name <> " !"+ version = pure 42++ helloH name Nothing = helloH name (Just False) helloH name (Just False) = return . Greet $ "Hello, " <> name helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
− include/overlapping-compat.h
@@ -1,8 +0,0 @@-#if __GLASGOW_HASKELL__ >= 710-#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}-#define OVERLAPPING_ {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPPABLE_-#define OVERLAPPING_-#endif
servant-server.cabal view
@@ -1,152 +1,212 @@-name: servant-server-version: 0.8.1-synopsis: A family of combinators for defining webservices APIs and serving them+cabal-version: 3.0+name: servant-server+version: 0.20.3.0+synopsis:+ A family of combinators for defining webservices APIs and serving them++category: Servant, Web description: A family of combinators for defining webservices APIs and serving them .- You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>.+ You can learn about the basics in the <http://docs.servant.dev/en/stable/tutorial/index.html tutorial>. . <https://github.com/haskell-servant/servant/blob/master/servant-server/example/greet.hs Here> is a runnable example, with comments, that defines a dummy API and implements a webserver that serves this API, using this package. . <https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md CHANGELOG>-homepage: http://haskell-servant.readthedocs.org/-Bug-reports: http://github.com/haskell-servant/servant/issues-license: BSD3-license-file: LICENSE-author: Servant Contributors-maintainer: haskell-servant-maintainers@googlegroups.com-copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors-category: Web-build-type: Simple-cabal-version: >=1.10-tested-with: GHC >= 7.8++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 ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1+ extra-source-files:- include/*.h CHANGELOG.md README.md-bug-reports: http://github.com/haskell-servant/servant/issues+ 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+ 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 Servant.Server.Experimental.Auth+ Servant.Server.Generic Servant.Server.Internal Servant.Server.Internal.BasicAuth Servant.Server.Internal.Context+ Servant.Server.Internal.Delayed+ Servant.Server.Internal.DelayedIO+ Servant.Server.Internal.ErrorFormatter+ Servant.Server.Internal.Handler+ Servant.Server.Internal.ResponseRender+ Servant.Server.Internal.RouteResult Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication- Servant.Server.Internal.ServantErr- Servant.Utils.StaticFiles+ Servant.Server.Internal.ServerError+ Servant.Server.StaticFiles+ Servant.Server.UVerb++ -- deprecated+ 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.7 && < 4.10- , base-compat >= 0.9 && < 0.10- , aeson >= 0.7 && < 1.1- , attoparsec >= 0.12 && < 0.14- , base64-bytestring >= 1.0 && < 1.1- , bytestring >= 0.10 && < 0.11- , containers >= 0.5 && < 0.6- , http-api-data >= 0.1 && < 0.3- , http-types >= 0.8 && < 0.10- , network-uri >= 2.6 && < 2.7- , mtl >= 2 && < 2.3- , network >= 2.6 && < 2.7- , safe >= 0.3 && < 0.4- , servant == 0.8.*- , split >= 0.2 && < 0.3- , string-conversions >= 0.3 && < 0.5- , system-filepath >= 0.4 && < 0.5- , filepath >= 1 && < 1.5- , text >= 1.2 && < 1.3- , transformers >= 0.3 && < 0.6- , transformers-compat>= 0.4 && < 0.6- , wai >= 3.0 && < 3.3- , wai-app-static >= 3.1 && < 3.2- , warp >= 3.0 && < 3.3- , word8 >= 0.1 && < 0.2+ , base >= 4.16.4.0 && < 4.22+ , bytestring >=0.11 && <0.13+ , constraints >=0.2 && <0.15+ , containers >=0.6.5.1 && <0.9+ , 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 - hs-source-dirs: src- default-language: Haskell2010- ghc-options: -Wall- if impl(ghc >= 8.0)- ghc-options: -Wno-redundant-constraints- include-dirs: include+ -- Servant dependencies+ -- strict dependency as we re-export 'servant' things.+ build-depends:+ , 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:+ , 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++ 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- , servant+ , base+ , base-compat , servant-server- , aeson- , warp- , wai , text+ , wai + build-depends:+ , 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.RouterSpec- Servant.Server.StreamingSpec- Servant.Server.UsingContextSpec- Servant.Server.UsingContextSpec.TestCombinators- Servant.ServerSpec- Servant.Utils.StaticFilesSpec+ 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 == 4.*+ , base , base-compat- , aeson , base64-bytestring , bytestring- , bytestring-conversion- , directory- , exceptions- , hspec == 2.*- , hspec-wai , http-types- , network >= 2.6- , QuickCheck- , parsec+ , mtl+ , resourcet , safe , servant , servant-server- , string-conversions- , should-not-typecheck == 2.1.*- , temporary , text- , transformers- , transformers-compat- , mtl , wai- , wai-extra- , warp -test-suite doctests- build-depends: base- , servant- , doctest- , filemanip- , directory- , filepath- type: exitcode-stdio-1.0- main-is: test/Doctests.hs- buildable: True- default-language: Haskell2010- ghc-options: -Wall -threaded- include-dirs: include+ -- Additional dependencies+ build-depends:+ , 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.12
src/Servant.hs view
@@ -6,16 +6,17 @@ -- | For implementing servers for servant APIs. module Servant.Server, -- | Utilities on top of the servant core- module Servant.Utils.Links,- module Servant.Utils.StaticFiles,+ module Servant.Links,+ module Servant.Server.StaticFiles, -- | Useful re-exports Proxy(..), throwError ) where -import Control.Monad.Error.Class (throwError)+import Control.Monad.Error.Class+ (throwError) import Data.Proxy import Servant.API+import Servant.Links import Servant.Server-import Servant.Utils.Links-import Servant.Utils.StaticFiles+import Servant.Server.StaticFiles
src/Servant/Server.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# 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'.@@ -10,6 +13,8 @@ ( -- * Run a wai application from an API serve , serveWithContext+ , serveWithContextT+ , ServerContext , -- * Construct a wai Application from an API toApplication@@ -17,35 +22,27 @@ , -- * Handlers for all standard combinators HasServer(..) , Server- , Handler+ , EmptyServer+ , emptyServer+ , Handler (..)+ , runHandler+ , pattern MkHandler -- * Debugging the server layout , layout , layoutWithContext - -- * Enter- -- $enterDoc+ -- * Enter / hoisting server+ , hoistServer - -- ** Basic functions and datatypes- , enter- , (:~>)(..)- -- ** `Nat` utilities- , liftNat- , runReaderTNat- , evalStateTLNat- , evalStateTSNat- , logWriterTLNat- , logWriterTSNat -- ** Functions based on <https://hackage.haskell.org/package/mmorph mmorph>- , hoistNat- , embedNat- , squashNat- , generalizeNat , tweakResponse -- * Context , Context(..) , HasContextEntry(getContextEntry)+ , type (.++)+ , (.++) -- ** NamedContext , NamedContext(..) , descendIntoNamedContext@@ -60,7 +57,7 @@ -- , mkAuthHandler -- * Default error type- , ServantErr(..)+ , ServerError(..) -- ** 3XX , err300 , err301@@ -87,6 +84,9 @@ , err415 , err416 , err417+ , err418+ , err422+ , err429 -- ** 5XX , err500 , err501@@ -95,26 +95,60 @@ , err504 , err505 + -- * Formatting of errors from combinators+ --+ -- | You can configure how Servant will render errors that occur while parsing the request.++ , ErrorFormatter+ , NotFoundErrorFormatter+ , ErrorFormatters++ , bodyParserErrorFormatter+ , urlParseErrorFormatter+ , headerParseErrorFormatter+ , notFoundErrorFormatter++ , DefaultErrorFormatters+ , defaultErrorFormatters++ , getAcceptHeader+ -- * Re-exports , Application+ , Tagged (..)+ , module Servant.Server.UVerb ) where -import Data.Proxy (Proxy)-import Data.Text (Text)-import Network.Wai (Application)+import Data.Proxy+ (Proxy (..))+import Data.Tagged+ (Tagged (..))+import Data.Text+ (Text)+import Network.Wai+ (Application) import Servant.Server.Internal-import Servant.Utils.Enter+import Servant.Server.UVerb -- * Implementing Servers +-- | Constraints that need to be satisfied on a context for it to be passed to 'serveWithContext'.+--+-- Typically, this will add default context entries to the context. You shouldn't typically+-- need to worry about these constraints, but if you write a helper function that wraps+-- 'serveWithContext', you might need to include this constraint.+type ServerContext context =+ ( HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters+ )+ -- | 'serve' allows you to implement an API and produce a wai 'Application'. -- -- Example: -- -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books--- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books -- > -- > server :: Server MyApi -- > server = listAllBooks :<|> postBook@@ -133,11 +167,52 @@ serve :: (HasServer api '[]) => Proxy api -> Server api -> Application serve p = serveWithContext p EmptyContext -serveWithContext :: (HasServer api context)+-- | Like 'serve', but allows you to pass custom context.+--+-- 'defaultErrorFormatters' will always be appended to the end of the passed context,+-- but if you pass your own formatter, it will override the default one.+serveWithContext :: ( HasServer api context+ , ServerContext context+ ) => Proxy api -> Context context -> Server api -> Application-serveWithContext p context server =- toApplication (runRouter (route p context (emptyDelayed (Route server))))+serveWithContext p context = serveWithContextT p context id +-- | A general 'serve' function that allows you to pass a custom context and hoisting function to+-- apply on all routes.+serveWithContextT ::+ forall api context m.+ (HasServer api context, ServerContext context) =>+ Proxy api -> Context context -> (forall x. m x -> Handler x) -> ServerT api m -> Application+serveWithContextT p context toHandler server =+ toApplication (runRouter format404 (route p context (emptyDelayed router)))+ where+ router = Route $ hoistServerWithContext p (Proxy :: Proxy context) toHandler server+ format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context++-- | Hoist server implementation.+--+-- Sometimes our cherished `Handler` monad isn't quite the type you'd like for+-- your handlers. Maybe you want to thread some configuration in a @Reader@+-- monad. Or have your types ensure that your handlers don't do any IO. Use+-- `hoistServer` (a successor of now deprecated @enter@).+--+-- With `hoistServer`, you can provide a function,+-- 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+-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String :<|> Raw :<|> EmptyAPI+-- >>> let readerApi = Proxy :: Proxy ReaderAPI+-- >>> let readerServer = return 1797 :<|> ask :<|> Tagged (error "raw server") :<|> emptyServer :: ServerT ReaderAPI (Reader String)+-- >>> let nt x = return (runReader x "hi")+-- >>> let mainServer = hoistServer readerApi nt readerServer :: Server ReaderAPI+--+hoistServer :: (HasServer api '[]) => Proxy api+ -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n+hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])+ -- | The function 'layout' produces a textual description of the internal -- router layout for debugging purposes. Note that the router layout is -- determined just by the API, not by the handlers.@@ -163,7 +238,7 @@ -- > │ └─ e/ -- > │ └─• -- > ├─ b/--- > │ └─ <capture>/+-- > │ └─ <x::Int>/ -- > │ ├─• -- > │ ┆ -- > │ └─•@@ -180,7 +255,8 @@ -- -- [@─•@] Leaves reflect endpoints. ----- [@\<capture\>/@] This is a delayed capture of a path component.+-- [@\<x::Int\>/@] This is a delayed capture of a single+-- path component named @x@, of expected type @Int@. -- -- [@\<raw\>@] This is a part of the API we do not know anything about. --@@ -198,25 +274,8 @@ layoutWithContext p context = routerLayout (route p context (emptyDelayed (FailFatal err501))) --- Documentation---- $enterDoc--- Sometimes our cherished `ExceptT` monad isn't quite the type you'd like for--- your handlers. Maybe you want to thread some configuration in a @Reader@--- 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`--- newtype, to convert any number of endpoints from one type constructor to--- another. For example------ >>> 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---- -- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeOperators -- >>> import Servant.API -- >>> import Servant.Server
src/Servant/Server/Experimental/Auth.hs view
@@ -1,35 +1,38 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module Servant.Server.Experimental.Auth where -import Control.Monad.Trans (liftIO)-import Control.Monad.Trans.Except (runExceptT)-import Data.Proxy (Proxy (Proxy))-import Data.Typeable (Typeable)-import GHC.Generics (Generic)-import Network.Wai (Request)+import Control.Monad.Trans+ (liftIO)+import Data.Kind+ (Type)+import Data.Proxy+ (Proxy (Proxy))+import Data.Typeable+ (Typeable)+import GHC.Generics+ (Generic)+import Network.Wai+ (Request) -import Servant ((:>))+import Servant+ ((:>)) import Servant.API.Experimental.Auth-import Servant.Server.Internal (HasContextEntry,- HasServer, ServerT,- getContextEntry,- route)-import Servant.Server.Internal.RoutingApplication (addAuthCheck,- delayedFailFatal,- DelayedIO,- withRequest)-import Servant.Server.Internal.ServantErr (Handler)+import Servant.Server.Internal+ (DelayedIO, Handler, HasContextEntry, HasServer (..),+ addAuthCheck, delayedFailFatal, getContextEntry, runHandler,+ withRequest) -- * General Auth @@ -37,14 +40,14 @@ -- 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 -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE newtype AuthHandler r usr = AuthHandler { unAuthHandler :: r -> Handler usr }- deriving (Generic, Typeable)+ deriving (Functor, Generic, Typeable) -- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr@@ -59,10 +62,12 @@ type ServerT (AuthProtect tag :> api) m = AuthServerData (AuthProtect tag) -> ServerT api m + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s+ route Proxy context subserver = route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck) where authHandler :: Request -> Handler (AuthServerData (AuthProtect tag)) authHandler = unAuthHandler (getContextEntry context) authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag))- authCheck = (>>= either delayedFailFatal return) . liftIO . runExceptT . authHandler+ authCheck = (>>= either delayedFailFatal return) . liftIO . runHandler . authHandler
+ src/Servant/Server/Generic.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | @since 0.14.1+module Servant.Server.Generic (+ AsServerT,+ AsServer,+ genericServe,+ genericServeT,+ genericServeTWithContext,+ genericServer,+ genericServerT+ ) where++import Data.Kind+ (Type)+import Data.Proxy+ (Proxy (..))++import Servant.Server+import Servant.API.Generic+import Servant.Server.Internal++-- | Transform a record of routes into a WAI 'Application'.+genericServe+ :: forall routes.+ ( HasServer (ToServantApi routes) '[]+ , GenericServant routes AsServer+ , Server (ToServantApi routes) ~ ToServant routes AsServer+ )+ => routes AsServer -> Application+genericServe = serve (Proxy :: Proxy (ToServantApi routes)) . genericServer++-- | Transform a record of routes with custom monad into a WAI 'Application',+-- by providing a transformation to bring each handler back in the 'Handler'+-- monad.+genericServeT+ :: forall (routes :: Type -> Type) (m :: Type -> Type).+ ( GenericServant routes (AsServerT m)+ , GenericServant routes AsApi+ , HasServer (ToServantApi routes) '[]+ , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)+ )+ => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler'+ -> routes (AsServerT m) -- ^ your record full of request handlers+ -> Application+genericServeT f server = serve p $ hoistServer p f (genericServerT server)+ where+ p = genericApi (Proxy :: Proxy routes)++-- | Transform a record of routes with custom monad into a WAI 'Application',+-- while using the given 'Context' to serve the application (contexts are typically+-- 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 :: Type -> Type) (m :: Type -> Type) (ctx :: [Type]).+ ( GenericServant routes (AsServerT m)+ , GenericServant routes AsApi+ , HasServer (ToServantApi routes) ctx+ , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters+ , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)+ )+ => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler'+ -> routes (AsServerT m) -- ^ your record full of request handlers+ -> Context ctx -- ^ the 'Context' to serve the application with+ -> Application+genericServeTWithContext f server ctx =+ serveWithContext p ctx $+ hoistServerWithContext p pctx f (genericServerT server)+ where+ p = genericApi (Proxy :: Proxy routes)+ pctx = Proxy :: Proxy ctx++-- | Transform a record of endpoints into a 'Server'.+genericServer+ :: GenericServant routes AsServer+ => routes AsServer+ -> ToServant routes AsServer+genericServer = toServant++-- | Transform a record of endpoints into a @'ServerT' m@.+--+-- You can see an example usage of this function+-- <https://docs.servant.dev/en/stable/cookbook/generic/Generic.html#using-generics-together-with-a-custom-monad in the Servant Cookbook>.+genericServerT+ :: GenericServant routes (AsServerT m)+ => routes (AsServerT m)+ -> ToServant routes (AsServerT m)+genericServerT = toServant+
src/Servant/Server/Internal.hs view
@@ -1,530 +1,1193 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--#include "overlapping-compat.h"--module Servant.Server.Internal- ( module Servant.Server.Internal- , module Servant.Server.Internal.Context- , module Servant.Server.Internal.BasicAuth- , module Servant.Server.Internal.Router- , module Servant.Server.Internal.RoutingApplication- , module Servant.Server.Internal.ServantErr- ) where--import Control.Monad.Trans (liftIO)-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC8-import qualified Data.ByteString.Lazy as BL-import Data.Maybe (fromMaybe, mapMaybe)-import Data.String (fromString)-import Data.String.Conversions (cs, (<>))-import Data.Typeable-import GHC.TypeLits (KnownNat, KnownSymbol, natVal,- symbolVal)-import Network.HTTP.Types hiding (Header, ResponseHeaders)-import Network.Socket (SockAddr)-import Network.Wai (Application, Request, Response,- httpVersion, isSecure,- lazyRequestBody,- rawQueryString, remoteHost,- requestHeaders, requestMethod,- responseLBS, vault)-import Prelude ()-import Prelude.Compat-import Web.HttpApiData (FromHttpApiData)-import Web.HttpApiData.Internal (parseHeaderMaybe,- parseQueryParamMaybe,- parseUrlPieceMaybe,- parseUrlPieces)--import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,- CaptureAll, Verb,- ReflectMethod(reflectMethod),- IsSecure(..), Header, QueryFlag,- QueryParam, QueryParams, Raw,- RemoteHost, ReqBody, Vault,- WithNamedContext)-import Servant.API.ContentTypes (AcceptHeader (..),- AllCTRender (..),- AllCTUnrender (..),- AllMime,- canHandleAcceptH)-import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,- getResponse)--import Servant.Server.Internal.Context-import Servant.Server.Internal.BasicAuth-import Servant.Server.Internal.Router-import Servant.Server.Internal.RoutingApplication-import Servant.Server.Internal.ServantErr---class HasServer api context where- type ServerT api (m :: * -> *) :: *-- route ::- Proxy api- -> Context context- -> Delayed env (Server api)- -> Router env--type Server api = ServerT api Handler---- * Instances---- | A server for @a ':<|>' b@ first tries to match the request against the route--- represented by @a@ and if it fails tries @b@. You must provide a request--- handler for each route.------ > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books--- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books--- >--- > server :: Server MyApi--- > server = listAllBooks :<|> postBook--- > where listAllBooks = ...--- > postBook book = ...-instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) context where-- type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m-- route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server))- (route pb context ((\ (_ :<|> b) -> b) <$> server))- where pa = Proxy :: Proxy a- pb = Proxy :: Proxy b---- | If you use 'Capture' in one of the endpoints for your API,--- this automatically requires your server-side handler to be a function--- that takes an argument of the type specified by the 'Capture'.--- This lets servant worry about getting it from the URL and turning--- it into a value of the type you specify.------ You can control how it'll be converted from 'Text' to your type--- by simply providing an instance of 'FromHttpApiData' for your type.------ Example:------ > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book--- >--- > server :: Server MyApi--- > server = getBook--- > where getBook :: Text -> Handler Book--- > getBook isbn = ...-instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)- => HasServer (Capture capture a :> api) context where-- type ServerT (Capture capture a :> api) m =- a -> ServerT api m-- route Proxy context d =- CaptureRouter $- route (Proxy :: Proxy api)- context- (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of- Nothing -> delayedFail err400- Just v -> return v- )---- | If you use 'CaptureAll' in one of the endpoints for your API,--- this automatically requires your server-side handler to be a--- function that takes an argument of a list of the type specified by--- the 'CaptureAll'. This lets servant worry about getting values from--- the URL and turning them into values of the type you specify.------ You can control how they'll be converted from 'Text' to your type--- by simply providing an instance of 'FromHttpApiData' for your type.------ Example:------ > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile--- >--- > server :: Server MyApi--- > server = getSourceFile--- > where getSourceFile :: [Text] -> Handler Book--- > getSourceFile pathSegments = ...-instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)- => HasServer (CaptureAll capture a :> sublayout) context where-- type ServerT (CaptureAll capture a :> sublayout) m =- [a] -> ServerT sublayout m-- route Proxy context d =- CaptureAllRouter $- route (Proxy :: Proxy sublayout)- context- (addCapture d $ \ txts -> case parseUrlPieces txts of- Left _ -> delayedFail err400- Right v -> return v- )---allowedMethodHead :: Method -> Request -> Bool-allowedMethodHead method request = method == methodGet && requestMethod request == methodHead--allowedMethod :: Method -> Request -> Bool-allowedMethod method request = allowedMethodHead method request || requestMethod request == method--processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method- -> Maybe [(HeaderName, B.ByteString)]- -> Request -> RouteResult Response-processMethodRouter handleA status method headers request = case handleA of- Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does- Just (contentT, body) -> Route $ responseLBS status hdrs bdy- where- bdy = if allowedMethodHead method request then "" else body- hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)--methodCheck :: Method -> Request -> DelayedIO ()-methodCheck method request- | allowedMethod method request = return ()- | otherwise = delayedFail err405---- This has switched between using 'Fail' and 'FailFatal' a number of--- times. If the 'acceptCheck' is run after the body check (which would--- be morally right), then we have to set this to 'FailFatal', because--- the body check is not reversible, and therefore backtracking after the--- body check is no longer an option. However, we now run the accept--- check before the body check and can therefore afford to make it--- recoverable.-acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()-acceptCheck proxy accH- | canHandleAcceptH proxy (AcceptHeader accH) = return ()- | otherwise = delayedFail err406--methodRouter :: (AllCTRender ctypes a)- => Method -> Proxy ctypes -> Status- -> Delayed env (Handler a)- -> Router env-methodRouter method proxy status action = leafRouter route'- where- route' env request respond =- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request- in runAction (action `addMethodCheck` methodCheck method request- `addAcceptCheck` acceptCheck proxy accH- ) env request respond $ \ output -> do- let handleA = handleAcceptH proxy (AcceptHeader accH) output- processMethodRouter handleA status method Nothing request--methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)- => Method -> Proxy ctypes -> Status- -> Delayed env (Handler (Headers h v))- -> Router env-methodRouterHeaders method proxy status action = leafRouter route'- where- route' env request respond =- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request- in runAction (action `addMethodCheck` methodCheck method request- `addAcceptCheck` acceptCheck proxy accH- ) env request respond $ \ output -> do- let headers = getHeaders output- handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)- processMethodRouter handleA status method (Just headers) request--instance OVERLAPPABLE_- ( AllCTRender ctypes a, ReflectMethod method, KnownNat status- ) => HasServer (Verb method status ctypes a) context where-- type ServerT (Verb method status ctypes a) m = m a-- route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status- where method = reflectMethod (Proxy :: Proxy method)- status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)--instance OVERLAPPING_- ( AllCTRender ctypes a, ReflectMethod method, KnownNat status- , GetHeaders (Headers h a)- ) => HasServer (Verb method status ctypes (Headers h a)) context where-- type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)-- route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status- where method = reflectMethod (Proxy :: Proxy method)- status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)---- | If you use 'Header' in one of the endpoints for your API,--- this automatically requires your server-side handler to be a function--- that takes an argument of the type specified by 'Header'.--- This lets servant worry about extracting it from the request and turning--- it into a value of the type you specify.------ All it asks is for a 'FromHttpApiData' instance.------ Example:------ > newtype Referer = Referer Text--- > deriving (Eq, Show, FromHttpApiData)--- >--- > -- GET /view-my-referer--- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer--- >--- > server :: Server MyApi--- > server = viewReferer--- > where viewReferer :: Referer -> Handler referer--- > viewReferer referer = return referer-instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)- => HasServer (Header sym a :> api) context where-- 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)---- | 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--- that takes an argument of type @'Maybe' 'Text'@.------ This lets servant worry about looking it up in the query string--- and turning it into a value of the type you specify, enclosed--- in 'Maybe', because it may not be there and servant would then--- hand you 'Nothing'.------ You can control how it'll be converted from 'Text' to your type--- by simply providing an instance of 'FromHttpApiData' for your type.------ Example:------ > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]--- >--- > server :: Server MyApi--- > server = getBooksBy--- > where getBooksBy :: Maybe Text -> Handler [Book]--- > getBooksBy Nothing = ...return all books...--- > getBooksBy (Just author) = ...return books by the given author...-instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)- => HasServer (QueryParam sym a :> api) context where-- type ServerT (QueryParam sym a :> api) m =- Maybe a -> ServerT api m-- route Proxy context subserver =- let querytext r = parseQueryText $ rawQueryString r- param r =- case lookup paramname (querytext r) of- Nothing -> Nothing -- param absent from the query string- Just Nothing -> Nothing -- param present with no value -> Nothing- Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to- -- the right type- in route (Proxy :: Proxy api) context (passToServer subserver param)- where paramname = cs $ symbolVal (Proxy :: Proxy sym)---- | If you use @'QueryParams' "authors" Text@ 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 @['Text']@.------ This lets servant worry about looking up 0 or more values in the query string--- associated to @authors@ and turning each of them into a value of--- the type you specify.------ You can control how the individual values are converted from 'Text' to your type--- by simply providing an instance of 'FromHttpApiData' for your type.------ Example:------ > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]--- >--- > server :: Server MyApi--- > server = getBooksBy--- > where getBooksBy :: [Text] -> Handler [Book]--- > getBooksBy authors = ...return all books by these authors...-instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)- => HasServer (QueryParams sym a :> api) context where-- type ServerT (QueryParams sym a :> api) m =- [a] -> ServerT api m-- route Proxy context subserver =- let querytext r = parseQueryText $ rawQueryString r- -- if sym is "foo", we look for query string parameters- -- named "foo" or "foo[]" and call parseQueryParam on the- -- corresponding values- parameters r = filter looksLikeParam (querytext r)- values r = mapMaybe (convert . snd) (parameters r)- in route (Proxy :: Proxy api) context (passToServer subserver values)- where paramname = cs $ symbolVal (Proxy :: Proxy sym)- looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")- convert Nothing = Nothing- convert (Just v) = parseQueryParamMaybe v---- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,--- this automatically requires your server-side handler to be a function--- that takes an argument of type 'Bool'.------ Example:------ > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]--- >--- > server :: Server MyApi--- > server = getBooks--- > where getBooks :: Bool -> Handler [Book]--- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...-instance (KnownSymbol sym, HasServer api context)- => HasServer (QueryFlag sym :> api) context where-- type ServerT (QueryFlag sym :> api) m =- Bool -> ServerT api m-- route Proxy context subserver =- let querytext r = parseQueryText $ rawQueryString r- param r = case lookup paramname (querytext r) of- Just Nothing -> True -- param is there, with no value- 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)- examine v | v == "true" || v == "1" || v == "" = True- | otherwise = False---- | Just pass the request to the underlying application and serve its response.------ Example:------ > type MyApi = "images" :> Raw--- >--- > server :: Server MyApi--- > server = serveDirectory "/var/www/images"-instance HasServer Raw context where-- type ServerT Raw m = Application-- route Proxy _ rawApplication = RawRouter $ \ env request respond -> do- r <- runDelayed rawApplication env request- case r of- Route app -> app request (respond . Route)- Fail a -> respond $ Fail a- FailFatal e -> respond $ FailFatal e---- | If you use 'ReqBody' in one of the endpoints for your API,--- this automatically requires your server-side handler to be a function--- that takes an argument of the type specified by 'ReqBody'.--- The @Content-Type@ header is inspected, and the list provided is used to--- attempt deserialization. If the request does not have a @Content-Type@--- header, it is treated as @application/octet-stream@ (as specified in--- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.--- This lets servant worry about extracting it from the request and turning--- it into a value of the type you specify.--------- All it asks is for a 'FromJSON' instance.------ Example:------ > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book--- >--- > server :: Server MyApi--- > server = postBook--- > where postBook :: Book -> Handler Book--- > postBook book = ...insert into your db...-instance ( AllCTUnrender list a, HasServer api context- ) => HasServer (ReqBody list a :> api) context where-- type ServerT (ReqBody list a :> api) m =- a -> ServerT api m-- route Proxy context subserver =- route (Proxy :: Proxy api) context (addBodyCheck subserver bodyCheck)- where- bodyCheck = withRequest $ \ request -> do- -- See HTTP RFC 2616, section 7.2.1- -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1- -- See also "W3C Internet Media Type registration, consistency of use"- -- http://www.w3.org/2001/tag/2002/0129-mime- let contentTypeH = fromMaybe "application/octet-stream"- $ lookup hContentType $ requestHeaders request- mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)- <$> liftIO (lazyRequestBody request)- case mrqbody of- Nothing -> delayedFailFatal err415- Just (Left e) -> delayedFailFatal err400 { errBody = cs e }- Just (Right v) -> return v---- | Make sure the incoming request starts with @"/path"@, strip it and--- pass the rest of the request path to @api@.-instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where-- type ServerT (path :> api) m = ServerT api m-- route Proxy context subserver =- pathRouter- (cs (symbolVal proxyPath))- (route (Proxy :: Proxy api) context subserver)- where proxyPath = Proxy :: Proxy path--instance HasServer api context => HasServer (RemoteHost :> api) context where- type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m-- route Proxy context subserver =- route (Proxy :: Proxy api) context (passToServer subserver remoteHost)--instance HasServer api context => HasServer (IsSecure :> api) context where- type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m-- route Proxy context subserver =- route (Proxy :: Proxy api) context (passToServer subserver secure)-- where secure req = if isSecure req then Secure else NotSecure--instance HasServer api context => HasServer (Vault :> api) context where- type ServerT (Vault :> api) m = Vault -> ServerT api m-- route Proxy context subserver =- route (Proxy :: Proxy api) context (passToServer subserver vault)--instance HasServer api context => HasServer (HttpVersion :> api) context where- type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m-- route Proxy context subserver =- route (Proxy :: Proxy api) context (passToServer subserver httpVersion)---- | Basic Authentication-instance ( KnownSymbol realm- , HasServer api context- , HasContextEntry context (BasicAuthCheck usr)- )- => HasServer (BasicAuth realm usr :> api) context where-- type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m-- route Proxy context subserver =- route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck)- where- realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)- basicAuthContext = getContextEntry context- authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext---- * helpers--ct_wildcard :: B.ByteString-ct_wildcard = "*" <> "/" <> "*" -- Because CPP---- * General Authentication----- * contexts--instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext)- => HasServer (WithNamedContext name subContext subApi) context where-- type ServerT (WithNamedContext name subContext subApi) m =- ServerT subApi m-- route Proxy context delayed =- route subProxy subContext delayed- where- subProxy :: Proxy subApi- subProxy = Proxy-- subContext :: Context subContext- subContext = descendIntoNamedContext (Proxy :: Proxy name) context+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-}++module Servant.Server.Internal+ ( module Servant.Server.Internal+ , module Servant.Server.Internal.BasicAuth+ , module Servant.Server.Internal.Context+ , module Servant.Server.Internal.Delayed+ , module Servant.Server.Internal.DelayedIO+ , module Servant.Server.Internal.ErrorFormatter+ , module Servant.Server.Internal.Handler+ , module Servant.Server.Internal.Router+ , module Servant.Server.Internal.RouteResult+ , module Servant.Server.Internal.RoutingApplication+ , module Servant.Server.Internal.ServerError+ ) where++import Control.Monad+ (join, when, unless)+import Control.Monad.Trans+ (liftIO, lift)+import Control.Monad.Trans.Resource+ (runResourceT, ReleaseKey)+import Data.Acquire+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 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.Tagged+ (Tagged (..), retag, untag)+import qualified Data.Text as T+import Data.Typeable+import GHC.Generics+import GHC.TypeLits (KnownNat, KnownSymbol, TypeError, ErrorMessage (..), symbolVal)+import qualified Network.HTTP.Media as NHM+import Network.HTTP.Types hiding+ (statusCode, Header, ResponseHeaders)+import Network.Socket+ (SockAddr)+import Network.Wai+ (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,+ queryString, remoteHost, getRequestBodyChunk, requestHeaders, requestHeaderHost,+ requestMethod, responseLBS, responseStream, vault)+import Servant.API+ ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',+ CaptureAll, DeepQuery, Description, EmptyAPI, Fragment,+ FramingRender (..), FramingUnrender (..), FromSourceIO (..),+ Host, Header', If, IsSecure (..), NoContentVerb, QueryFlag,+ QueryParam', QueryParams, QueryString, Raw, RawM, ReflectMethod (reflectMethod),+ RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,+ Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,+ WithNamedContext, WithResource, NamedRoutes)+import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)+import Servant.API.ContentTypes+ (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),+ AllMime, MimeRender (..), MimeUnrender (..), NoContent,+ canHandleAcceptH)+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+ (statusFromNat)+import qualified Servant.Types.SourceT as S+import Servant.API.TypeErrors+import Web.HttpApiData+ (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,+ parseUrlPieces)++import Servant.Server.Internal.BasicAuth+import Servant.Server.Internal.Context+import Servant.Server.Internal.Delayed+import Servant.Server.Internal.DelayedIO+import Servant.Server.Internal.ErrorFormatter+import Servant.Server.Internal.Handler+import Servant.Server.Internal.Router+import Servant.Server.Internal.RouteResult+import Servant.Server.Internal.RoutingApplication+import Servant.Server.Internal.ServerError+import Servant.Server.Internal.ResponseRender+import Servant.API.MultiVerb+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 -> Type) :: Type++ route ::+ Proxy api+ -> Context context+ -> Delayed env (Server api)+ -> Router env++ hoistServerWithContext+ :: Proxy api+ -> Proxy context+ -> (forall x. m x -> n x)+ -> ServerT api m+ -> ServerT api n++type Server api = ServerT api Handler++-- * Instances++-- | A server for @a ':<|>' b@ first tries to match the request against the route+-- represented by @a@ and if it fails tries @b@. You must provide a request+-- handler for each route.+--+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books+-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books+-- >+-- > server :: Server MyApi+-- > server = listAllBooks :<|> postBook+-- > where listAllBooks = ...+-- > postBook book = ...+instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) context where++ type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m++ route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server))+ (route pb context ((\ (_ :<|> b) -> b) <$> server))+ where pa = Proxy :: Proxy a+ pb = Proxy :: Proxy b++ -- | This is better than 'enter', as it's tailor made for 'HasServer'.+ hoistServerWithContext _ pc nt (a :<|> b) =+ hoistServerWithContext (Proxy :: Proxy a) pc nt a :<|>+ hoistServerWithContext (Proxy :: Proxy b) pc nt b++-- | If you use 'Capture' in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of the type specified by the 'Capture'.+-- This lets servant worry about getting it from the URL and turning+-- it into a value of the type you specify.+--+-- You can control how it'll be converted from 'Text' to your type+-- by simply providing an instance of 'FromHttpApiData' for your type.+--+-- Example:+--+-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book+-- >+-- > server :: Server MyApi+-- > server = getBook+-- > where getBook :: Text -> Handler Book+-- > getBook isbn = ...+instance (KnownSymbol capture, FromHttpApiData a, Typeable a+ , HasServer api context, SBoolI (FoldLenient mods)+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters+ )+ => HasServer (Capture' mods capture a :> api) context where++ type ServerT (Capture' mods capture a :> api) m =+ If (FoldLenient mods) (Either String a) a -> ServerT api m++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++ route Proxy context d =+ CaptureRouter [hint] $+ route (Proxy :: Proxy api)+ context+ (addCapture d $ \ txt -> withRequest $ \ request ->+ case ( sbool :: SBool (FoldLenient mods)+ , parseUrlPiece txt :: Either T.Text a) of+ (SFalse, Left e) -> delayedFail $ formatError rep request $ T.unpack e+ (SFalse, Right v) -> return v+ (STrue, piece) -> return $ either (Left . T.unpack) Right piece)+ where+ rep = typeRep (Proxy :: Proxy Capture')+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))++-- | If you use 'CaptureAll' in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a+-- function that takes an argument of a list of the type specified by+-- the 'CaptureAll'. This lets servant worry about getting values from+-- the URL and turning them into values of the type you specify.+--+-- You can control how they'll be converted from 'Text' to your type+-- by simply providing an instance of 'FromHttpApiData' for your type.+--+-- Example:+--+-- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile+-- >+-- > server :: Server MyApi+-- > server = getSourceFile+-- > where getSourceFile :: [Text] -> Handler Book+-- > getSourceFile pathSegments = ...+instance (KnownSymbol capture, FromHttpApiData a, Typeable a+ , HasServer api context+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters+ )+ => HasServer (CaptureAll capture a :> api) context where++ type ServerT (CaptureAll capture a :> api) m =+ [a] -> ServerT api m++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++ route Proxy context d =+ CaptureAllRouter [hint] $+ route (Proxy :: Proxy api)+ context+ (addCapture d $ \ txts -> withRequest $ \ request ->+ case parseUrlPieces txts of+ Left e -> delayedFail $ formatError rep request $ T.unpack e+ Right v -> return v+ )+ where+ rep = typeRep (Proxy :: Proxy CaptureAll)+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))++-- | If you use 'WithResource' in one of the endpoints for your API Servant+-- will provide the handler for this endpoint an argument of the specified type.+-- The lifespan of this resource will be automatically managed by Servant. This+-- resource will be created before the handler starts and it will be destoyed+-- after it ends. A new resource is created for each request to the endpoint.++-- The creation and destruction are done using a 'Data.Acquire.Acquire'+-- provided via server 'Context'.+--+-- Example+--+-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent+-- >+-- > server :: Server MyApi+-- > server = writeToFile+-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent+-- > writeToFile (_, h) = hPutStrLn h "message"+--+-- In addition to the resource, the handler will also receive a 'ReleaseKey'+-- which can be used to deallocate the resource before the end of the request+-- if desired.++instance (HasServer api ctx, HasContextEntry ctx (Acquire a))+ => HasServer (WithResource a :> api) ctx where++ type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s++ route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)+ where+ allocateResource :: DelayedIO (ReleaseKey, a)+ allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)++++allowedMethodHead :: Method -> Request -> Bool+allowedMethodHead method request = method == methodGet && requestMethod request == methodHead++allowedMethod :: Method -> Request -> Bool+allowedMethod method request = allowedMethodHead method request || requestMethod request == method++methodCheck :: Method -> Request -> DelayedIO ()+methodCheck method request+ | allowedMethod method request = return ()+ | otherwise = delayedFail err405++-- This has switched between using 'Fail' and 'FailFatal' a number of+-- times. If the 'acceptCheck' is run after the body check (which would+-- be morally right), then we have to set this to 'FailFatal', because+-- the body check is not reversible, and therefore backtracking after the+-- body check is no longer an option. However, we now run the accept+-- check before the body check and can therefore afford to make it+-- recoverable.+acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO ()+acceptCheck proxy accH+ | canHandleAcceptH proxy accH = return ()+ | otherwise = delayedFail err406++methodRouter :: (AllCTRender ctypes a)+ => (b -> ([(HeaderName, B.ByteString)], a))+ -> Method -> Proxy ctypes -> Status+ -> Delayed env (Handler b)+ -> Router env+methodRouter splitHeaders method proxy status action = leafRouter route'+ where+ route' env request respond =+ let accH = getAcceptHeader request+ in runAction (action `addMethodCheck` methodCheck method request+ `addAcceptCheck` acceptCheck proxy accH+ ) env request respond $ \ output -> do+ let (headers, b) = splitHeaders output+ case handleAcceptH proxy accH b of+ 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, BSL.toStrict contentT) : headers) bdy++noContentRouter :: Method+ -> Status+ -> Delayed env (Handler b)+ -> Router env+noContentRouter method status action = leafRouter route'+ where+ route' env request respond =+ runAction (action `addMethodCheck` methodCheck method request)+ env request respond $ \ _output ->+ Route $ responseLBS status [] ""++instance {-# OVERLAPPABLE #-}+ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status+ ) => HasServer (Verb method status ctypes a) context where++ type ServerT (Verb method status ctypes a) m = m a+ hoistServerWithContext _ _ nt s = nt s++ route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status+ where method = reflectMethod (Proxy :: Proxy method)+ status = statusFromNat (Proxy :: Proxy status)++instance {-# OVERLAPPING #-}+ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status+ , GetHeaders (Headers h a)+ ) => HasServer (Verb method status ctypes (Headers h a)) context where++ type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)+ hoistServerWithContext _ _ nt s = nt s++ route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status+ where method = reflectMethod (Proxy :: Proxy method)+ status = statusFromNat (Proxy :: Proxy status)++instance (ReflectMethod method) =>+ HasServer (NoContentVerb method) context where++ type ServerT (NoContentVerb method) m = m NoContent+ hoistServerWithContext _ _ nt s = nt s++ route Proxy _ = noContentRouter method status204+ where method = reflectMethod (Proxy :: Proxy method)++instance {-# OVERLAPPABLE #-}+ ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,+ FramingRender framing, ToSourceIO chunk a+ ) => HasServer (Stream method status framing ctype a) context where++ type ServerT (Stream method status framing ctype a) m = m a+ hoistServerWithContext _ _ nt s = nt s++ route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)+ where method = reflectMethod (Proxy :: Proxy method)+ status = statusFromNat (Proxy :: Proxy status)+++instance {-# OVERLAPPING #-}+ ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,+ FramingRender framing, ToSourceIO chunk a,+ GetHeaders (Headers h a)+ ) => HasServer (Stream method status framing ctype (Headers h a)) context where++ type ServerT (Stream method status framing ctype (Headers h a)) m = m (Headers h a)+ hoistServerWithContext _ _ nt s = nt s++ route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)+ where method = reflectMethod (Proxy :: Proxy method)+ status = statusFromNat (Proxy :: Proxy status)+++streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>+ (c -> ([(HeaderName, B.ByteString)], a))+ -> Method+ -> Status+ -> Proxy framing+ -> Proxy ctype+ -> Delayed env (Handler c)+ -> Router env+streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->+ let AcceptHeader accH = getAcceptHeader request+ cmediatype = NHM.matchAccept [contentType ctypeproxy] accH+ accCheck = when (isNothing cmediatype) $ delayedFail err406+ contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)+ in runAction (action `addMethodCheck` methodCheck method request+ `addAcceptCheck` accCheck+ ) env request respond $ \ output ->+ let (headers, fa) = splitHeaders output+ sourceT = toSourceIO fa+ 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+ loop (S.Skip s) = loop s+ loop (S.Effect ms) = ms >>= loop+ loop (S.Yield lbs s) = do+ write (BB.lazyByteString lbs)+ flush+ loop s++ kStepLBS loop++-- | If you use 'Header' in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of the type specified by 'Header'.+-- This lets servant worry about extracting it from the request and turning+-- it into a value of the type you specify.+--+-- All it asks is for a 'FromHttpApiData' instance.+--+-- Example:+--+-- > newtype Referer = Referer Text+-- > deriving (Eq, Show, FromHttpApiData)+-- >+-- > -- GET /view-my-referer+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer+-- >+-- > server :: Server MyApi+-- > server = viewReferer+-- > where viewReferer :: Referer -> Handler referer+-- > viewReferer referer = return referer+instance+ (KnownSymbol sym, FromHttpApiData a, HasServer api context+ , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters+ )+ => HasServer (Header' mods sym a :> api) context where+------+ type ServerT (Header' mods sym a :> api) m =+ RequestArgument mods 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 `addHeaderCheck` withRequest headerCheck+ where+ rep = typeRep (Proxy :: Proxy Header')+ formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)++ headerName :: IsString n => n+ headerName = fromString $ symbolVal (Proxy :: Proxy sym)++ headerCheck :: Request -> DelayedIO (RequestArgument mods a)+ headerCheck req =+ unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev+ where+ mev :: Maybe (Either T.Text a)+ mev = fmap parseHeader $ lookup headerName (requestHeaders req)++ errReq = delayedFailFatal $ formatError rep req+ $ "Header " <> headerName <> " is required"++ errSt e = delayedFailFatal $ formatError rep req+ $ T.unpack $ "Error parsing header "+ <> headerName+ <> " failed: " <> e++instance+ ( KnownSymbol sym+ , HasServer api context+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters+ ) => HasServer (Host sym :> api) context where+ type ServerT (Host sym :> api) m = ServerT api m++ hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)++ route _ context (Delayed {..}) = route (Proxy :: Proxy api) context $+ let formatError =+ headerParseErrorFormatter $ getContextEntry $ mkContextWithErrorFormatter context+ rep = typeRep (Proxy :: Proxy Host)+ targetHost = symbolVal (Proxy :: Proxy sym)+ hostCheck :: DelayedIO ()+ hostCheck = withRequest $ \req ->+ case requestHeaderHost req of+ Just hostBytes ->+ let host = BC8.unpack hostBytes+ in unless (host == targetHost) $+ delayedFail $ formatError rep req $ "Invalid host: " ++ host+ _ -> delayedFail $ formatError rep req "Host header missing"+ in Delayed { headersD = headersD <* hostCheck, .. }++-- | 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+-- that takes an argument of type @'Maybe' 'Text'@.+--+-- This lets servant worry about looking it up in the query string+-- and turning it into a value of the type you specify, enclosed+-- in 'Maybe', because it may not be there and servant would then+-- hand you 'Nothing'.+--+-- You can control how it'll be converted from 'Text' to your type+-- by simply providing an instance of 'FromHttpApiData' for your type.+--+-- Example:+--+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooksBy+-- > where getBooksBy :: Maybe Text -> Handler [Book]+-- > getBooksBy Nothing = ...return all books...+-- > getBooksBy (Just author) = ...return books by the given author...+instance+ ( KnownSymbol sym, FromHttpApiData a, HasServer api context+ , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters+ )+ => HasServer (QueryParam' mods sym a :> api) context where+------+ type ServerT (QueryParam' mods sym a :> api) m =+ RequestArgument mods a -> ServerT api m++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++ route Proxy context subserver =+ let querytext = queryToQueryText . queryString+ paramname = T.pack $ symbolVal (Proxy :: Proxy sym)++ rep = typeRep (Proxy :: Proxy QueryParam')+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)++ parseParam :: Request -> DelayedIO (RequestArgument mods a)+ parseParam req =+ unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev+ where+ mev :: Maybe (Either T.Text a)+ mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req++ errReq = delayedFailFatal $ formatError rep req+ $ T.unpack $ "Query parameter " <> paramname <> " is required"++ errSt e = delayedFailFatal $ formatError rep req+ $ T.unpack $ "Error parsing query parameter "+ <> paramname <> " failed: " <> e++ delayed = addParameterCheck subserver . withRequest $ \req ->+ parseParam req++ in route (Proxy :: Proxy api) context delayed++-- | If you use @'QueryParams' "authors" Text@ 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 @['Text']@.+--+-- This lets servant worry about looking up 0 or more values in the query string+-- associated to @authors@ and turning each of them into a value of+-- the type you specify.+--+-- You can control how the individual values are converted from 'Text' to your type+-- by simply providing an instance of 'FromHttpApiData' for your type.+--+-- Example:+--+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooksBy+-- > where getBooksBy :: [Text] -> Handler [Book]+-- > getBooksBy authors = ...return all books by these authors...+instance (KnownSymbol sym, FromHttpApiData a, HasServer api context+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters)+ => HasServer (QueryParams sym a :> api) context where++ type ServerT (QueryParams 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 QueryParams)+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)++ paramname = T.pack $ symbolVal (Proxy :: Proxy sym)+ paramsCheck req =+ case partitionEithers $ fmap parseQueryParam params of+ ([], parsed) -> return parsed+ (errs, _) -> delayedFailFatal $ formatError rep req+ $ T.unpack $ "Error parsing query parameter(s) "+ <> paramname <> " failed: "+ <> T.intercalate ", " errs+ where+ params :: [T.Text]+ params = mapMaybe snd+ . filter (looksLikeParam . fst)+ . queryToQueryText+ . queryString+ $ req++ looksLikeParam name = name == paramname || name == (paramname <> "[]")++-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of type 'Bool'.+--+-- Example:+--+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooks+-- > where getBooks :: Bool -> Handler [Book]+-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...+instance (KnownSymbol sym, HasServer api context)+ => HasServer (QueryFlag sym :> api) context where++ type ServerT (QueryFlag sym :> api) m =+ Bool -> ServerT api m++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++ route Proxy context subserver =+ let querytext = queryToQueryText . queryString+ param r = case lookup paramname (querytext r) of+ Just Nothing -> True -- param is there, with no value+ 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 = 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:+--+-- > type MyApi = "images" :> Raw+-- >+-- > server :: Server MyApi+-- > server = serveDirectory "/var/www/images"+instance HasServer Raw context where++ type ServerT Raw m = Tagged m Application++ hoistServerWithContext _ _ _ = retag++ route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do+ -- note: a Raw application doesn't register any cleanup+ -- but for the sake of consistency, we nonetheless run+ -- the cleanup once its done+ r <- runDelayed rawApplication env request+ liftIO $ go r request respond++ where go r request respond = case r of+ Route app -> untag app request (respond . Route)+ Fail a -> respond $ Fail a+ FailFatal e -> respond $ FailFatal e++-- | Just pass the request to the underlying application and serve its response.+--+-- Example:+--+-- > type MyApi = "images" :> Raw+-- >+-- > server :: Server MyApi+-- > server = serveDirectory "/var/www/images"+instance HasServer RawM context where+ type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived++ route+ :: Proxy RawM+ -> Context context+ -> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env+ route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do+ routeResult <- runDelayed handleDelayed env request+ let respond' = liftIO . respond+ liftIO $ case routeResult of+ Route handler -> runHandler (handler request (respond . Route)) >>=+ \case+ Left e -> respond' $ FailFatal e+ Right a -> pure a+ Fail e -> respond' $ Fail e+ FailFatal e -> respond' $ FailFatal e++ hoistServerWithContext _ _ f srvM = \req respond -> f (srvM req respond)+++-- | If you use 'ReqBody' in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of the type specified by 'ReqBody'.+-- The @Content-Type@ header is inspected, and the list provided is used to+-- attempt deserialization. If the request does not have a @Content-Type@+-- header, it is treated as @application/octet-stream@ (as specified in+-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)).+-- This lets servant worry about extracting it from the request and turning+-- it into a value of the type you specify.+--+--+-- All it asks is for a 'FromJSON' instance.+--+-- Example:+--+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book+-- >+-- > server :: Server MyApi+-- > server = postBook+-- > where postBook :: Book -> Handler Book+-- > postBook book = ...insert into your db...+instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters+ ) => HasServer (ReqBody' mods list a :> api) context where++ type ServerT (ReqBody' mods list a :> api) m =+ If (FoldLenient mods) (Either String a) a -> ServerT api m++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++ route Proxy context subserver+ = route (Proxy :: Proxy api) context $+ addBodyCheck subserver ctCheck bodyCheck+ where+ rep = typeRep (Proxy :: Proxy ReqBody')+ formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)++ -- Content-Type check, we only lookup we can try to parse the request body+ ctCheck = withRequest $ \ request -> do+ -- See HTTP RFC 2616, section 7.2.1+ -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1+ -- See also "W3C Internet Media Type registration, consistency of use"+ -- http://www.w3.org/2001/tag/2002/0129-mime+ let contentTypeH = fromMaybe "application/octet-stream"+ $ lookup hContentType $ requestHeaders request+ case canHandleCTypeH (Proxy :: Proxy list) (BSL.fromStrict contentTypeH) :: Maybe (BSL.ByteString -> Either String a) of+ Nothing -> delayedFail err415+ Just f -> return f++ -- Body check, we get a body parsing functions as the first argument.+ bodyCheck f = withRequest $ \ request -> do+ mrqbody <- f <$> liftIO (lazyRequestBody request)+ case sbool :: SBool (FoldLenient mods) of+ STrue -> return mrqbody+ SFalse -> case mrqbody of+ Left e -> delayedFailFatal $ formatError rep request e+ Right v -> return v++instance+ ( FramingUnrender framing, FromSourceIO chunk a, MimeUnrender ctype chunk+ , HasServer api context+ ) => HasServer (StreamBody' mods framing ctype a :> api) context+ where+ type ServerT (StreamBody' mods framing ctype 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 $+ addBodyCheck subserver ctCheck bodyCheck+ where+ ctCheck :: DelayedIO (SourceIO chunk -> IO a)+ -- TODO: do content-type check+ ctCheck = return fromSourceIO++ bodyCheck :: (SourceIO chunk -> IO a) -> DelayedIO a+ bodyCheck fromRS = withRequest $ \req -> do+ 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+ liftIO $ fromRS $ framingUnrender' rs++-- | Make sure the incoming request starts with @"/path"@, strip it and+-- pass the rest of the request path to @api@.+instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where++ type ServerT (path :> api) m = ServerT api m++ route Proxy context subserver =+ pathRouter+ (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++instance HasServer api context => HasServer (RemoteHost :> api) context where+ type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m++ route Proxy context subserver =+ route (Proxy :: Proxy api) context (passToServer subserver remoteHost)+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++instance HasServer api context => HasServer (IsSecure :> api) context where+ type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m++ route Proxy context subserver =+ route (Proxy :: Proxy api) context (passToServer subserver secure)+ where secure req = if isSecure req then Secure else NotSecure++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++instance HasServer api context => HasServer (Vault :> api) context where+ type ServerT (Vault :> api) m = Vault -> ServerT api m++ route Proxy context subserver =+ route (Proxy :: Proxy api) context (passToServer subserver vault)+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++instance HasServer api context => HasServer (HttpVersion :> api) context where+ type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m++ route Proxy context subserver =+ route (Proxy :: Proxy api) context (passToServer subserver httpVersion)+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++-- | Ignore @'Summary'@ in server handlers.+instance HasServer api ctx => HasServer (Summary desc :> api) ctx where+ type ServerT (Summary desc :> api) m = ServerT api m++ route _ = route (Proxy :: Proxy api)+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s++-- | Ignore @'Description'@ in server handlers.+instance HasServer api ctx => HasServer (Description desc :> api) ctx where+ type ServerT (Description desc :> api) m = ServerT api m++ route _ = route (Proxy :: Proxy api)+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s++-- | 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 `emptyServer`.+--+-- > type MyApi = "nothing" :> EmptyApi+-- >+-- > server :: Server MyApi+-- > server = emptyServer+instance HasServer EmptyAPI context where+ type ServerT EmptyAPI m = Tagged m EmptyServer++ route Proxy _ _ = StaticRouter mempty mempty++ 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+ , HasContextEntry context (BasicAuthCheck usr)+ )+ => HasServer (BasicAuth realm usr :> api) context where++ type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m++ route Proxy context subserver =+ route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck)+ where+ realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)+ basicAuthContext = getContextEntry context+ authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++-- * helpers++ct_wildcard :: B.ByteString+ct_wildcard = "*" <> "/" <> "*"++getAcceptHeader :: Request -> AcceptHeader+getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders++-- * General Authentication+++-- * contexts++instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext)+ => HasServer (WithNamedContext name subContext subApi) context where++ type ServerT (WithNamedContext name subContext subApi) m =+ ServerT subApi m++ route Proxy context delayed =+ route subProxy subContext delayed+ where+ subProxy :: Proxy subApi+ subProxy = Proxy++ subContext :: Context subContext+ subContext = descendIntoNamedContext (Proxy :: Proxy name) context++ hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s++-------------------------------------------------------------------------------+-- Custom type errors+-------------------------------------------------------------------------------++-- Erroring instance for 'HasServer' when a combinator is not fully applied+instance TypeError (PartialApplication++ @(Type -> [Type] -> Constraint)++ HasServer arr) => HasServer ((arr :: a -> b) :> sub) context+ where+ type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: Type -> [Type] -> Constraint) arr)+ route = error "unreachable"+ hoistServerWithContext _ _ _ _ = error "unreachable"++-- | This instance prevents from accidentally using '->' instead of ':>'+--+-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")+-- ...+-- ...No instance HasServer (a -> b).+-- ...Maybe you have used '->' instead of ':>' between+-- ...Capture' '[] "foo" Int+-- ...and+-- ...Verb 'GET 200 '[JSON] Int+-- ...+--+-- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int)+-- ...+-- ...No instance HasServer (a -> b).+-- ...Maybe you have used '->' instead of ':>' between+-- ...Capture' '[] "foo" Int+-- ...and+-- ...Verb 'GET 200 '[JSON] Int+-- ...+--+instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context+ where+ type ServerT (a -> b) m = TypeError (HasServerArrowTypeError a b)+ route _ _ _ = error "servant-server panic: impossible happened in HasServer (a -> b)"+ hoistServerWithContext _ _ _ = id++type HasServerArrowTypeError a b =+ 'Text "No instance HasServer (a -> b)."+ ':$$: 'Text "Maybe you have used '->' instead of ':>' between "+ ':$$: 'ShowType a+ ':$$: 'Text "and"+ ':$$: 'ShowType b++-- Erroring instances for 'HasServer' for unknown API combinators++-- XXX: This omits the @context@ parameter, e.g.:+--+-- "There is no instance for HasServer (Bool :> …)". Do we care ?+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub++ @(Type -> [Type] -> Constraint)++ HasServer ty) => HasServer (ty :> sub) context++instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context++-- | Ignore @'Fragment'@ in server handlers.+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.+--+-- Example:+--+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooks+-- > where getBooks :: Handler [Book]+-- > getBooks = ...return all books...+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++ route _ = route (Proxy :: Proxy api)++ hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)++-- $setup+-- >>> import Servant++-- | A type that specifies that an API record contains a server implementation.+data AsServerT (m :: Type -> Type)+instance GenericMode (AsServerT m) where+ type AsServerT m :- api = ServerT api m++type AsServer = AsServerT Handler+++-- | Set of constraints required to convert to / from vanilla server types.+type GServerConstraints api m =+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m+ , GServantProduct (Rep (api (AsServerT m)))+ )++-- | This class is a necessary evil: in the implementation of 'HasServer' for+-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall+-- m. 'GServerConstraints' m@ to hold.+--+-- We cannot require do that directly as the definition of 'GServerConstraints'+-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide+-- those type family applications behind a typeclass providing evidence for+-- @'GServerConstraints' api m@ in the form of a dictionary, and require that+-- @forall m. 'GServer' api m@ instead.+--+-- 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 :: Type -> Type) (m :: Type -> Type) where+ gServerProof :: Dict (GServerConstraints api m)++instance+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m+ , GServantProduct (Rep (api (AsServerT m)))+ ) => GServer api m where+ gServerProof = Dict++instance+ ( HasServer (ToServantApi api) context+ , forall m. Generic (api (AsServerT m))+ , forall m. GServer api m+ , ErrorIfNoGeneric api+ ) => HasServer (NamedRoutes api) context where++ type ServerT (NamedRoutes api) m = api (AsServerT m)++ route+ :: Proxy (NamedRoutes api)+ -> Context context+ -> Delayed env (api (AsServerT Handler))+ -> Router env+ route _ ctx delayed =+ case gServerProof @api @Handler of+ Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)++ hoistServerWithContext+ :: forall m n. Proxy (NamedRoutes api)+ -> Proxy context+ -> (forall x. m x -> n x)+ -> api (AsServerT m)+ -> api (AsServerT n)+ hoistServerWithContext _ pctx nat server =+ case (gServerProof @api @m, gServerProof @api @n) of+ (Dict, Dict) ->+ fromServant servantSrvN+ where+ servantSrvM :: ServerT (ToServantApi api) m =+ toServant server+ servantSrvN :: ServerT (ToServantApi api) n =+ hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM+++instance+ ( HasAcceptCheck cs,+ ResponseListRender cs as,+ AsUnion as r,+ ReflectMethod method+ ) =>+ HasServer (MultiVerb method cs as r) ctx+ where+ type ServerT (MultiVerb method cs as r) m = m r++ hoistServerWithContext _ _ f = f++ route ::+ forall env.+ Proxy (MultiVerb method cs as r) ->+ Context ctx ->+ Delayed env (Handler r) ->+ Router env+ route _ _ action = leafRouter $ \env req k -> do+ let acc = getAcceptHeader req+ action' =+ action+ `addMethodCheck` methodCheck method req+ `addAcceptCheck` acceptCheck' (Proxy @cs) acc+ runAction action' env req k $ \output -> do+ let mresp = responseListRender @cs @as acc (toUnion @as output)+ someResponseToWai <$> case mresp of+ Nothing -> FailFatal err406+ Just resp+ | allowedMethodHead method req -> pure (setEmptyBody resp)+ | otherwise -> pure resp+ where+ method = reflectMethod (Proxy @method)++class HasAcceptCheck cs where+ acceptCheck' :: Proxy cs -> AcceptHeader -> DelayedIO ()++instance (AllMime cs) => HasAcceptCheck cs where+ acceptCheck' = acceptCheck++instance HasAcceptCheck '() where+ acceptCheck' _ _ = pure ()
src/Servant/Server/Internal/BasicAuth.hs view
@@ -1,29 +1,36 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.BasicAuth where -import Control.Monad (guard)-import Control.Monad.Trans (liftIO)-import qualified Data.ByteString as BS-import Data.ByteString.Base64 (decodeLenient)-import Data.Monoid ((<>))-import Data.Typeable (Typeable)-import Data.Word8 (isSpace, toLower, _colon)+import Control.Monad+ (guard)+import Control.Monad.Trans+ (liftIO)+import qualified Data.ByteString as BS+import Data.ByteString.Base64+ (decodeLenient)+import Data.Typeable+ (Typeable)+import Data.Word8+ (isSpace, toLower, _colon) import GHC.Generics-import Network.HTTP.Types (Header)-import Network.Wai (Request, requestHeaders)+import Network.HTTP.Types+ (Header)+import Network.Wai+ (Request, requestHeaders) -import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))-import Servant.Server.Internal.RoutingApplication-import Servant.Server.Internal.ServantErr+import Servant.API.BasicAuth+ (BasicAuthData (BasicAuthData))+import Servant.Server.Internal.DelayedIO+import Servant.Server.Internal.ServerError -- * Basic Auth -- | servant-server's current implementation of basic authentication is not--- immune to certian kinds of timing attacks. Decoding payloads does not take+-- immune to certain kinds of timing attacks. Decoding payloads does not take -- a fixed amount of time. -- | The result of authentication/authorization
src/Servant/Server/Internal/Context.hs view
@@ -1,29 +1,33 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--#include "overlapping-compat.h"+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} -module Servant.Server.Internal.Context where+module Servant.Server.Internal.Context+ ( module Servant.Server.Internal.Context+ , module Servant.API.TypeLevel.List+ ) where +import Data.Kind + (Type) import Data.Proxy import GHC.TypeLits+import Servant.API.TypeLevel.List+ (type (.++)) -- | 'Context's are used to pass values to combinators. (They are __not__ meant -- to be used to pass parameters to your handlers, i.e. they should not replace -- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using--- with 'Servant.Utils.Enter'.) If you don't use combinators that+-- with 'hoistServer'.) If you don't use combinators that -- require any context entries, you can just use 'Servant.Server.serve' as always. -- -- If you are using combinators that require a non-empty 'Context' you have to -- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all--- the values your combinators need. A 'Context' is essentially a heterogenous+-- the values your combinators need. A 'Context' is essentially a heterogeneous -- list and accessing the elements is being done by type (see 'getContextEntry'). -- The parameter of the type 'Context' is a type-level list reflecting the types -- of the contained context entries. To create a 'Context' with entries, use the@@ -48,6 +52,11 @@ instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 +-- | Append two contexts.+(.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2)+EmptyContext .++ a = a+(a :. as) .++ b = a :. (as .++ b)+ -- | This class is used to access context entries in 'Context's. 'getContextEntry' -- returns the first value where the type matches: --@@ -59,16 +68,16 @@ -- -- >>> getContextEntry (True :. False :. EmptyContext) :: String -- ...--- ...No instance for (HasContextEntry '[] [Char])+-- ...No instance for ...HasContextEntry '[] [Char]... -- ...-class HasContextEntry (context :: [*]) (val :: *) where+class HasContextEntry (context :: [Type]) (val :: Type) where getContextEntry :: Context context -> val -instance OVERLAPPABLE_+instance {-# OVERLAPPABLE #-} HasContextEntry xs val => HasContextEntry (notIt ': xs) val where getContextEntry (_ :. xs) = getContextEntry xs -instance OVERLAPPING_+instance {-# OVERLAPPING #-} HasContextEntry (val ': xs) val where getContextEntry (x :. _) = x @@ -78,7 +87,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 :: [*])+newtype NamedContext (name :: Symbol) (subContext :: [Type]) = NamedContext (Context subContext) -- | 'descendIntoNamedContext' allows you to access `NamedContext's. Usually you
+ src/Servant/Server/Internal/Delayed.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Servant.Server.Internal.Delayed where++import Control.Monad.IO.Class+ (MonadIO (..))+import Control.Monad.Reader+ (ask)+import Control.Monad.Trans.Resource+ (ResourceT, runResourceT)+import Network.Wai+ (Request, Response)++import Servant.Server.Internal.DelayedIO+import Servant.Server.Internal.Handler+import Servant.Server.Internal.RouteResult+import Servant.Server.Internal.ServerError++-- | A 'Delayed' is a representation of a handler with scheduled+-- delayed checks that can trigger errors.+--+-- Why would we want to delay checks?+--+-- There are two reasons:+--+-- 1. In a straight-forward implementation, the order in which we+-- perform checks will determine the error we generate. This is+-- because once an error occurs, we would abort and not perform+-- any subsequent checks, but rather return the current error.+--+-- This is not a necessity: we could continue doing other checks,+-- and choose the preferred error. However, that would in general+-- mean more checking, which leads us to the other reason.+--+-- 2. We really want to avoid doing certain checks too early. For+-- example, captures involve parsing, and are much more costly+-- than static route matches. In particular, if several paths+-- contain the "same" capture, we'd like as much as possible to+-- avoid trying the same parse many times. Also tricky is the+-- request body. Again, this involves parsing, but also, WAI makes+-- obtaining the request body a side-effecting operation. We+-- could/can work around this by manually caching the request body,+-- but we'd rather keep the number of times we actually try to+-- decode the request body to an absolute minimum.+--+-- We prefer to have the following relative priorities of error+-- codes:+--+-- @+-- 404+-- 405 (bad method)+-- 401 (unauthorized)+-- 415 (unsupported media type)+-- 406 (not acceptable)+-- 400 (bad request)+-- @+--+-- Therefore, while routing, we delay most checks so that they+-- will ultimately occur in the right order.+--+-- A 'Delayed' contains many delayed blocks of tests, and+-- the actual handler:+--+-- 1. Delayed captures. These can actually cause 404, and+-- while they're costly, they should be done first among the+-- delayed checks (at least as long as we do not decouple the+-- check order from the error reporting, see above). Delayed+-- captures can provide inputs to the actual handler.+--+-- 2. Method check(s). This can cause a 405. On success,+-- it does not provide an input for the handler. Method checks+-- are comparatively cheap.+--+-- 3. Authentication checks. This can cause 401.+--+-- 4. Accept and content type header checks. These checks+-- can cause 415 and 406 errors.+--+-- 5. Query parameter checks. They require parsing and can cause 400 if the+-- parsing fails. Query parameter checks provide inputs to the handler+--+-- 6. Header Checks. They also require parsing and can cause 400 if parsing fails.+--+-- 7. Body check. The request body check can cause 400.+--+data Delayed env c where+ Delayed :: { capturesD :: env -> DelayedIO captures+ , methodD :: DelayedIO ()+ , authD :: DelayedIO auth+ , acceptD :: DelayedIO ()+ , contentD :: DelayedIO contentType+ , paramsD :: DelayedIO params+ , headersD :: DelayedIO headers+ , bodyD :: contentType -> DelayedIO body+ , serverD :: captures+ -> params+ -> headers+ -> auth+ -> body+ -> Request+ -> RouteResult c+ } -> Delayed env c++instance Functor (Delayed env) where+ fmap f Delayed{..} =+ Delayed+ { serverD = \ c p h a b req -> f <$> serverD c p h a b req+ , ..+ } -- Note [Existential Record Update]++-- | A 'Delayed' without any stored checks.+emptyDelayed :: RouteResult a -> Delayed env a+emptyDelayed result =+ Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result)+ where+ r = return ()++-- | Add a capture to the end of the capture block.+addCapture :: Delayed env (a -> b)+ -> (captured -> DelayedIO a)+ -> Delayed (captured, env) b+addCapture Delayed{..} new =+ Delayed+ { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt+ , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req+ , ..+ } -- Note [Existential Record Update]++-- | Add a parameter check to the end of the params block+addParameterCheck :: Delayed env (a -> b)+ -> DelayedIO a+ -> Delayed env b+addParameterCheck Delayed {..} new =+ Delayed+ { paramsD = (,) <$> paramsD <*> new+ , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req+ , ..+ }++-- | Add a parameter check to the end of the params block+addHeaderCheck :: Delayed env (a -> b)+ -> DelayedIO a+ -> Delayed env b+addHeaderCheck Delayed {..} new =+ Delayed+ { headersD = (,) <$> headersD <*> new+ , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req+ , ..+ }++-- | Add a method check to the end of the method block.+addMethodCheck :: Delayed env a+ -> DelayedIO ()+ -> Delayed env a+addMethodCheck Delayed{..} new =+ Delayed+ { methodD = methodD <* new+ , ..+ } -- Note [Existential Record Update]++-- | Add an auth check to the end of the auth block.+addAuthCheck :: Delayed env (a -> b)+ -> DelayedIO a+ -> Delayed env b+addAuthCheck Delayed{..} new =+ Delayed+ { authD = (,) <$> authD <*> new+ , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req+ , ..+ } -- Note [Existential Record Update]++-- | Add a content type and body checks around parameter checks.+--+-- We'll report failed content type check (415), before trying to parse+-- query parameters (400). Which, in turn, happens before request body parsing.+addBodyCheck :: Delayed env (a -> b)+ -> DelayedIO c -- ^ content type check+ -> (c -> DelayedIO a) -- ^ body check+ -> Delayed env b+addBodyCheck Delayed{..} newContentD newBodyD =+ Delayed+ { contentD = (,) <$> contentD <*> newContentD+ , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c+ , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req+ , ..+ } -- Note [Existential Record Update]+++-- | Add an accept header check before handling parameters.+-- In principle, we'd like+-- to take a bad body (400) response take precedence over a+-- failed accept check (406). BUT to allow streaming the body,+-- we cannot run the body check and then still backtrack.+-- We therefore do the accept check before the body check,+-- when we can still backtrack. There are other solutions to+-- this, but they'd be more complicated (such as delaying the+-- body check further so that it can still be run in a situation+-- where we'd otherwise report 406).+addAcceptCheck :: Delayed env a+ -> DelayedIO ()+ -> Delayed env a+addAcceptCheck Delayed{..} new =+ Delayed+ { acceptD = acceptD *> new+ , ..+ } -- Note [Existential Record Update]++-- | Many combinators extract information that is passed to+-- the handler without the possibility of failure. In such a+-- case, 'passToServer' can be used.+passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b+passToServer Delayed{..} x =+ Delayed+ { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req+ , ..+ } -- Note [Existential Record Update]++-- | Run a delayed server. Performs all scheduled operations+-- in order, and passes the results from the capture and body+-- blocks on to the actual handler.+--+-- This should only be called once per request; otherwise the guarantees about+-- effect and HTTP error ordering break down.+runDelayed :: Delayed env a+ -> env+ -> Request+ -> ResourceT IO (RouteResult a)+runDelayed Delayed{..} env = runDelayedIO $ do+ r <- ask+ c <- capturesD env+ methodD+ a <- authD+ acceptD+ content <- contentD+ p <- paramsD -- Has to be before body parsing, but after content-type checks+ h <- headersD+ b <- bodyD content+ liftRouteResult (serverD c p h a b r)++-- | Runs a delayed server and the resulting action.+-- Takes a continuation that lets us send a response.+-- Also takes a continuation for how to turn the+-- result of the delayed server into a response.+runAction :: Delayed env (Handler a)+ -> env+ -> Request+ -> (RouteResult Response -> IO r)+ -> (a -> RouteResult Response)+ -> IO r+runAction action env req respond k = runResourceT $+ runDelayed action env req >>= go >>= liftIO . respond+ where+ go (Fail e) = return $ Fail e+ go (FailFatal e) = return $ FailFatal e+ go (Route a) = liftIO $ do+ e <- runHandler a+ case e of+ Left err -> return . Route $ responseServerError err+ Right x -> return $! k x++{- Note [Existential Record Update]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot+do the more succinct thing - just update the records we actually change.+-}
+ src/Servant/Server/Internal/DelayedIO.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Servant.Server.Internal.DelayedIO where++import Control.Monad.Base+ (MonadBase (..))+import Control.Monad.Catch+ (MonadThrow (..))+import Control.Monad.Reader+ (MonadReader (..), ReaderT (..), runReaderT)+import Control.Monad.Trans+ (MonadIO (..), MonadTrans (..))+import Control.Monad.Trans.Control+ (MonadBaseControl (..))+import Control.Monad.Trans.Resource+ (MonadResource (..), ResourceT, runInternalState,+ transResourceT, withInternalState)+import Network.Wai+ (Request)++import Servant.Server.Internal.RouteResult+import Servant.Server.Internal.ServerError++-- | Computations used in a 'Delayed' can depend on the+-- incoming 'Request', may perform 'IO', and result in a+-- 'RouteResult', meaning they can either succeed, fail+-- (with the possibility to recover), or fail fatally.+--+newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }+ deriving newtype+ ( Functor, Applicative, Monad+ , MonadIO, MonadReader Request+ , MonadThrow+ , MonadResource+ )++instance MonadBase IO DelayedIO where+ liftBase = liftIO++liftRouteResult :: RouteResult a -> DelayedIO a+liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x++instance MonadBaseControl IO DelayedIO where+ -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a+ -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')+ -- restoreM = DelayedIO . restoreM++ type StM DelayedIO a = RouteResult a+ liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s ->+ liftBaseWith $ \runInBase -> f $ \x ->+ runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s)+ restoreM = DelayedIO . lift . withInternalState . const . restoreM+++runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)+runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req++-- | Fail with the option to recover.+delayedFail :: ServerError -> DelayedIO a+delayedFail err = liftRouteResult $ Fail err++-- | Fail fatally, i.e., without any option to recover.+delayedFailFatal :: ServerError -> DelayedIO a+delayedFailFatal err = liftRouteResult $ FailFatal err++-- | Gain access to the incoming request.+withRequest :: (Request -> DelayedIO a) -> DelayedIO a+withRequest f = do+ req <- ask+ f req
+ src/Servant/Server/Internal/ErrorFormatter.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++module Servant.Server.Internal.ErrorFormatter+ ( ErrorFormatters(..)+ , ErrorFormatter+ , NotFoundErrorFormatter++ , DefaultErrorFormatters+ , defaultErrorFormatters++ , MkContextWithErrorFormatter+ , mkContextWithErrorFormatter+ ) where++import Data.Kind (Type)+import Data.Typeable+import Network.Wai.Internal (Request)+import qualified Data.ByteString.Lazy.Char8 as BSL8++import Servant.API+ (Capture, ReqBody)+import Servant.Server.Internal.Context+import Servant.Server.Internal.ServerError++-- | 'Context' that contains default error formatters.+type DefaultErrorFormatters = '[ErrorFormatters]++-- | A collection of error formatters for different situations.+--+-- If you need to override one of them, use 'defaultErrorFormatters' with record update syntax.+data ErrorFormatters = ErrorFormatters+ { -- | Format error from parsing the request body.+ bodyParserErrorFormatter :: ErrorFormatter+ -- | Format error from parsing url parts or query parameters.+ , urlParseErrorFormatter :: ErrorFormatter+ -- | Format error from parsing request headers.+ , headerParseErrorFormatter :: ErrorFormatter+ -- | Format error for not found URLs.+ , notFoundErrorFormatter :: NotFoundErrorFormatter+ }++-- | Default formatters will just return HTTP 400 status code with error+-- message as response body.+defaultErrorFormatters :: ErrorFormatters+defaultErrorFormatters = ErrorFormatters+ { bodyParserErrorFormatter = err400Formatter+ , urlParseErrorFormatter = err400Formatter+ , headerParseErrorFormatter = err400Formatter+ , notFoundErrorFormatter = const err404+ }++-- | A custom formatter for errors produced by parsing combinators like+-- 'ReqBody' or 'Capture'.+--+-- A 'TypeRep' argument described the concrete combinator that raised+-- the error, allowing formatter to customize the message for different+-- combinators.+--+-- A full 'Request' is also passed so that the formatter can react to @Accept@ header,+-- for example.+type ErrorFormatter = TypeRep -> Request -> String -> ServerError++-- | This formatter does not get neither 'TypeRep' nor error message.+type NotFoundErrorFormatter = Request -> ServerError++type MkContextWithErrorFormatter (ctx :: [Type]) = ctx .++ DefaultErrorFormatters++mkContextWithErrorFormatter :: forall (ctx :: [Type]). Context ctx -> Context (MkContextWithErrorFormatter ctx)+mkContextWithErrorFormatter ctx = ctx .++ (defaultErrorFormatters :. EmptyContext)++-- Internal++err400Formatter :: ErrorFormatter+err400Formatter _ _ e = err400 { errBody = BSL8.pack e }++-- These definitions suppress "unused import" warning.+-- The imorts are needed for Haddock to correctly link to them.+_RB :: Proxy ReqBody+_RB = Proxy+_C :: Proxy Capture+_C = Proxy+_CT :: Proxy Context+_CT = Proxy
+ src/Servant/Server/Internal/Handler.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PatternSynonyms #-}+module Servant.Server.Internal.Handler where++import Control.Monad.Base+ (MonadBase (..))+import Control.Monad.Catch+ (MonadCatch, MonadMask, MonadThrow)+import Control.Monad.Error.Class+ (MonadError, throwError)+import Control.Monad.IO.Class+ (MonadIO)+import Control.Monad.Trans.Control+ (MonadBaseControl (..))+import Control.Monad.Trans.Except+ (ExceptT(ExceptT), runExceptT)+import Data.String+ (fromString)+import GHC.Generics+ (Generic)+import Servant.Server.Internal.ServerError+ (ServerError, errBody, err500)++newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }+ deriving stock (Generic)+ deriving newtype+ ( Functor, Applicative, Monad, MonadIO+ , MonadError ServerError+ , MonadThrow, MonadCatch, MonadMask+ )++instance MonadFail Handler where+ fail str = throwError err500 { errBody = fromString str }++instance MonadBase IO Handler where+ liftBase = Handler . liftBase++instance MonadBaseControl IO Handler where+ type StM Handler a = Either ServerError a++ -- liftBaseWith :: (RunInBase Handler IO -> IO a) -> Handler a+ liftBaseWith f = Handler (liftBaseWith (\g -> f (g . runHandler')))++ -- restoreM :: StM Handler a -> Handler a+ restoreM st = Handler (restoreM st)++runHandler :: Handler a -> IO (Either 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/ResponseRender.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE EmptyCase #-}++module Servant.Server.Internal.ResponseRender where++import Data.ByteString (ByteString)+import Data.Kind (Type)+import Data.Typeable+import GHC.TypeLits+import qualified Data.ByteString.Lazy as BSL+import qualified Network.Wai as Wai+import Network.HTTP.Types (Status, hContentType)+import Data.SOP+import qualified Servant.Types.SourceT as S+import qualified Data.ByteString.Builder as BB+import qualified Data.Sequence as Seq ++import Servant.API.ContentTypes (AcceptHeader (..), AllMimeRender, MimeRender, Accept, allMimeRender, mimeRender, contentType)+import Servant.API.MultiVerb+import Servant.API.Status+import Servant.API.Stream (SourceIO)+import Servant.API.UVerb.Union+import Servant.Types.Internal.Response+import qualified Network.HTTP.Media as M+import Data.Foldable (toList)+import Data.Sequence ((<|))++class (Typeable a) => IsWaiBody a where+ responseToWai :: InternalResponse a -> Wai.Response++instance IsWaiBody BSL.ByteString where+ responseToWai r =+ Wai.responseLBS+ (statusCode r)+ (toList (headers r))+ (responseBody r)++instance IsWaiBody () where+ responseToWai r =+ Wai.responseLBS+ (statusCode r)+ (toList (headers r))+ mempty++instance IsWaiBody (SourceIO ByteString) where+ responseToWai r =+ Wai.responseStream+ (statusCode r)+ (toList (headers r))+ $ \output flush -> do+ S.foreach+ (const (pure ()))+ (\chunk -> output (BB.byteString chunk) *> flush)+ (responseBody r)++data SomeResponse = forall a. (IsWaiBody a) => SomeResponse (InternalResponse a)++class ResponseListRender cs as where+ responseListRender+ :: AcceptHeader+ -> Union (ResponseTypes as)+ -> Maybe SomeResponse+ responseListStatuses :: [Status]++instance ResponseListRender cs '[] where+ responseListRender _ x = case x of {}+ responseListStatuses = []++class (IsWaiBody (ResponseBody a)) => ResponseRender cs a where+ type ResponseStatus a :: Nat+ type ResponseBody a :: Type+ responseRender+ :: AcceptHeader+ -> ResponseType a+ -> Maybe (InternalResponse (ResponseBody a))++instance+ ( ResponseRender cs a,+ ResponseListRender cs as,+ KnownStatus (ResponseStatus a)+ ) =>+ ResponseListRender cs (a ': as)+ where+ responseListRender acc (Z (I x)) = fmap SomeResponse (responseRender @cs @a acc x)+ responseListRender acc (S x) = responseListRender @cs @as acc x++ responseListStatuses = statusVal (Proxy @(ResponseStatus a)) : responseListStatuses @cs @as++instance+ ( AsHeaders xs (ResponseType r) a,+ ServantHeaders hs xs,+ ResponseRender cs r+ ) =>+ ResponseRender cs (WithHeaders hs a r)+ where+ type ResponseStatus (WithHeaders hs a r) = ResponseStatus r+ type ResponseBody (WithHeaders hs a r) = ResponseBody r++ responseRender acc x = addHeaders <$> responseRender @cs @r acc y+ where+ (hs, y) = toHeaders @xs x+ addHeaders r =+ r+ { headers = headers r <> Seq.fromList (constructHeaders @hs hs)+ }++instance+ ( KnownStatus s,+ MimeRender ct a+ ) =>+ ResponseRender cs (RespondAs (ct :: Type) s desc a)+ where+ type ResponseStatus (RespondAs ct s desc a) = s+ type ResponseBody (RespondAs ct s desc a) = BSL.ByteString++ responseRender _ x =+ pure . addContentType @ct $+ InternalResponse+ { statusCode = statusVal (Proxy @s),+ responseBody = mimeRender (Proxy @ct) x,+ headers = mempty+ }++instance (KnownStatus s) => ResponseRender cs (RespondAs '() s desc ()) where+ type ResponseStatus (RespondAs '() s desc ()) = s+ type ResponseBody (RespondAs '() s desc ()) = ()++ responseRender _ _ =+ pure $+ InternalResponse+ { statusCode = statusVal (Proxy @s),+ responseBody = (),+ headers = mempty+ }++instance+ (Accept ct, KnownStatus s)+ => ResponseRender cs (RespondStreaming s desc framing ct)+ where+ type ResponseStatus (RespondStreaming s desc framing ct) = s+ type ResponseBody (RespondStreaming s desc framing ct) = SourceIO ByteString + responseRender _ x =+ pure . addContentType @ct $+ InternalResponse+ { statusCode = statusVal (Proxy @s),+ responseBody = x,+ headers = mempty+ }++instance+ (AllMimeRender cs a, KnownStatus s)+ => ResponseRender cs (Respond s desc a) where+ type ResponseStatus (Respond s desc a) = s+ type ResponseBody (Respond s desc a) = BSL.ByteString++ -- Note: here it seems like we are rendering for all possible content types,+ -- only to choose the correct one afterwards. However, render results besides the+ -- one picked by 'M.mapAcceptMedia' are not evaluated, and therefore nor are the+ -- corresponding rendering functions.+ responseRender (AcceptHeader acc) x =+ M.mapAcceptMedia (map (uncurry mkRenderOutput) (allMimeRender (Proxy @cs) x)) acc+ where+ mkRenderOutput :: M.MediaType -> BSL.ByteString -> (M.MediaType, InternalResponse BSL.ByteString)+ mkRenderOutput c body =+ (c,) . addContentType' c $+ InternalResponse+ { statusCode = statusVal (Proxy @s),+ responseBody = body,+ headers = mempty+ }++addContentType :: forall ct a. (Accept ct) => InternalResponse a -> InternalResponse a+addContentType = addContentType' (contentType (Proxy @ct))++addContentType' :: M.MediaType -> InternalResponse a -> InternalResponse a+addContentType' c r = r {headers = (hContentType, M.renderHeader c) <| headers r}++setEmptyBody :: SomeResponse -> SomeResponse+setEmptyBody (SomeResponse r) = SomeResponse (go r)+ where+ go :: InternalResponse a -> InternalResponse BSL.ByteString+ go InternalResponse {..} = InternalResponse {responseBody = mempty, ..}++someResponseToWai :: SomeResponse -> Wai.Response+someResponseToWai (SomeResponse r) = responseToWai r
+ src/Servant/Server/Internal/RouteResult.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Servant.Server.Internal.RouteResult where++import Control.Monad+ (ap, liftM)+import Control.Monad.Base+ (MonadBase (..))+import Control.Monad.Catch+ (MonadThrow (..))+import Control.Monad.Trans+ (MonadIO (..), MonadTrans (..))+import Control.Monad.Trans.Control+ (ComposeSt, MonadBaseControl (..), MonadTransControl (..),+ defaultLiftBaseWith, defaultRestoreM)++import Servant.Server.Internal.ServerError++-- | The result of matching against a path in the route tree.+data RouteResult a =+ Fail ServerError -- ^ Keep trying other paths.+ -- The 'ServantError' should only be 404, 405 or 406.+ | FailFatal !ServerError -- ^ Don't try other paths.+ | Route !a+ deriving (Eq, Show, Read, Functor)++instance Applicative RouteResult where+ pure = Route+ (<*>) = ap++instance Monad RouteResult where+ return = pure+ Route a >>= f = f a+ Fail e >>= _ = Fail e+ FailFatal e >>= _ = FailFatal e++newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) }+ deriving (Functor)++instance MonadTrans RouteResultT where+ lift = RouteResultT . fmap Route++instance (Functor m, Monad m) => Applicative (RouteResultT m) where+ pure = RouteResultT . return . Route+ (<*>) = ap++instance Monad m => Monad (RouteResultT m) where+ return = pure+ m >>= k = RouteResultT $ do+ a <- runRouteResultT m+ case a of+ Fail e -> return $ Fail e+ FailFatal e -> return $ FailFatal e+ Route b -> runRouteResultT (k b)++instance MonadIO m => MonadIO (RouteResultT m) where+ liftIO = lift . liftIO++instance MonadBase b m => MonadBase b (RouteResultT m) where+ liftBase = lift . liftBase++instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where+ type StM (RouteResultT m) a = ComposeSt RouteResultT m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++instance MonadTransControl RouteResultT where+ type StT RouteResultT a = RouteResult a+ liftWith f = RouteResultT $ liftM return $ f runRouteResultT+ restoreT = RouteResultT++instance MonadThrow m => MonadThrow (RouteResultT m) where+ throwM = lift . throwM
src/Servant/Server/Internal/Router.hs view
@@ -1,21 +1,45 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where -import Data.Map (Map)+import Data.Function+ (on)+import Data.List+ (nub)+import Data.Map+ (Map) import qualified Data.Map as M-import Data.Monoid-import Data.Text (Text)+import Data.Text+ (Text) import qualified Data.Text as T-import Network.Wai (Response, pathInfo)+import Data.Typeable+ (TypeRep)+import Network.Wai+ (Response, pathInfo)+import Servant.Server.Internal.ErrorFormatter+import Servant.Server.Internal.RouteResult import Servant.Server.Internal.RoutingApplication-import Servant.Server.Internal.ServantErr+import Servant.Server.Internal.ServerError type Router env = Router' env RoutingApplication +-- | Holds information about pieces of url that are captured as variables.+data CaptureHint = CaptureHint+ { captureName :: Text+ -- ^ Holds the name of the captured variable+ , captureType :: TypeRep+ -- ^ Holds the type of the captured variable+ }+ deriving (Show, Eq)++toCaptureTag :: CaptureHint -> Text+toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)++toCaptureTags :: [CaptureHint] -> Text+toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"+ -- | Internal representation of a router. -- -- The first argument describes an environment type that is@@ -28,12 +52,23 @@ -- ^ the map contains routers for subpaths (first path component used -- for lookup and removed afterwards), the list contains handlers -- for the empty path, to be tried in order- | CaptureRouter (Router' (Text, env) a)+ | CaptureRouter [CaptureHint] (Router' (Text, env) a) -- ^ first path component is passed to the child router in its- -- environment and removed afterwards- | CaptureAllRouter (Router' ([Text], env) a)+ -- environment and removed afterwards.+ -- The first argument is a list of hints for all variables that can be+ -- captured by the router. The fact that it is a list is counter-intuitive,+ -- because the 'Capture' combinator only allows to capture a single varible,+ -- with a single name and a single type. However, the 'choice' smart+ -- constructor may merge two 'Capture' combinators with different hints, thus+ -- forcing the type to be '[CaptureHint]'.+ -- Because 'CaptureRouter' is built from a 'Capture' combinator, the list of+ -- hints should always be non-empty.+ | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a) -- ^ all path components are passed to the child router in its -- environment and are removed afterwards+ -- The first argument is a hint for the list of variables that can be+ -- captured by the router. Note that the 'captureType' field of the hint+ -- should always be '[a]' for some 'a'. | RawRouter (env -> a) -- ^ to be used for routes we do not know anything about | Choice (Router' env a) (Router' env a)@@ -61,8 +96,8 @@ choice :: Router' env a -> Router' env a -> Router' env a choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) = StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)-choice (CaptureRouter router1) (CaptureRouter router2) =- CaptureRouter (choice router1 router2)+choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =+ CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2) choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3 choice router1 router2 = Choice router1 router2 @@ -76,7 +111,11 @@ -- data RouterStructure = StaticRouterStructure (Map Text RouterStructure) Int- | CaptureRouterStructure RouterStructure+ | CaptureRouterStructure [CaptureHint] RouterStructure+ -- ^ The first argument holds information about variables+ -- that are captured by the router. There may be several hints+ -- if several routers have been aggregated by the 'choice'+ -- smart constructor. | RawRouterStructure | ChoiceStructure RouterStructure RouterStructure deriving (Eq, Show)@@ -90,11 +129,11 @@ routerStructure :: Router' env a -> RouterStructure routerStructure (StaticRouter m ls) = StaticRouterStructure (fmap routerStructure m) (length ls)-routerStructure (CaptureRouter router) =- CaptureRouterStructure $+routerStructure (CaptureRouter hints router) =+ CaptureRouterStructure hints $ routerStructure router-routerStructure (CaptureAllRouter router) =- CaptureRouterStructure $+routerStructure (CaptureAllRouter hints router) =+ CaptureRouterStructure hints $ routerStructure router routerStructure (RawRouter _) = RawRouterStructure@@ -106,8 +145,8 @@ -- | Compare the structure of two routers. -- sameStructure :: Router' env a -> Router' env b -> Bool-sameStructure r1 r2 =- routerStructure r1 == routerStructure r2+sameStructure router1 router2 =+ routerStructure router1 == routerStructure router2 -- | Provide a textual representation of the -- structure of a router.@@ -118,7 +157,8 @@ where mkRouterLayout :: Bool -> RouterStructure -> [Text] mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n- mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)+ mkRouterLayout c (CaptureRouterStructure hints r) =+ mkSubTree c (toCaptureTags hints) (mkRouterLayout False r) mkRouterLayout c RawRouterStructure = if c then ["├─ <raw>"] else ["└─ <raw>"] mkRouterLayout c (ChoiceStructure r1 r2) =@@ -146,52 +186,55 @@ tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) -- | Interpret a router as an application.-runRouter :: Router () -> RoutingApplication-runRouter r = runRouterEnv r ()+runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication+runRouter fmt r = runRouterEnv fmt r () -runRouterEnv :: Router env -> env -> RoutingApplication-runRouterEnv router env request respond =+runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication+runRouterEnv fmt router env request respond = case router of StaticRouter table ls -> case pathInfo request of- [] -> runChoice ls env request respond+ [] -> runChoice fmt ls env request respond -- This case is to handle trailing slashes.- [""] -> runChoice ls env request respond+ [""] -> runChoice fmt ls env request respond first : rest | Just router' <- M.lookup first table -> let request' = request { pathInfo = rest }- in runRouterEnv router' env request' respond- _ -> respond $ Fail err404- CaptureRouter router' ->+ in runRouterEnv fmt router' env request' respond+ _ -> respond $ Fail $ fmt request+ CaptureRouter _ router' -> case pathInfo request of- [] -> respond $ Fail err404+ [] -> respond $ Fail $ fmt request -- This case is to handle trailing slashes.- [""] -> respond $ Fail err404+ [""] -> respond $ Fail $ fmt request first : rest -> let request' = request { pathInfo = rest }- in runRouterEnv router' (first, env) request' respond- CaptureAllRouter router' ->- let segments = pathInfo request+ in runRouterEnv fmt router' (first, env) request' respond+ CaptureAllRouter _ router' ->+ let segments = case pathInfo request of+ -- this case is to handle trailing slashes.+ ("":xs) -> xs+ xs -> xs request' = request { pathInfo = [] }- in runRouterEnv router' (segments, env) request' respond+ in runRouterEnv fmt router' (segments, env) request' respond RawRouter app -> app env request respond Choice r1 r2 ->- runChoice [runRouterEnv r1, runRouterEnv r2] env request respond+ runChoice fmt [runRouterEnv fmt r1, runRouterEnv fmt r2] env request respond -- | Try a list of routing applications in order. -- We stop as soon as one fails fatally or succeeds. -- If all fail normally, we pick the "best" error. ---runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication-runChoice ls =+runChoice :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication+runChoice fmt ls = case ls of- [] -> \ _ _ respond -> respond (Fail err404)+ [] -> \ _ request respond -> respond (Fail $ fmt request) [r] -> r (r : rs) -> \ env request respond -> r env request $ \ response1 -> case response1 of- Fail _ -> runChoice rs env request $ \ response2 ->+ Fail _ -> runChoice fmt rs env request $ \ response2 -> respond $ highestPri response1 response2 _ -> respond response1 where@@ -204,7 +247,14 @@ -- Priority on HTTP codes. ----- It just so happens that 404 < 405 < 406 as far as--- we are concerned here, so we can use (<). worseHTTPCode :: Int -> Int -> Bool-worseHTTPCode = (<)+worseHTTPCode = on (<) toPriority+ where+ toPriority :: Int -> Int+ toPriority 404 = 0 -- not found+ toPriority 405 = 1 -- method not allowed+ toPriority 401 = 2 -- unauthorized+ toPriority 415 = 3 -- unsupported media type+ toPriority 406 = 4 -- not acceptable+ toPriority 400 = 6 -- bad request+ toPriority _ = 5
src/Servant/Server/Internal/RoutingApplication.hs view
@@ -1,277 +1,18 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-} module Servant.Server.Internal.RoutingApplication where -import Control.Monad (ap, liftM)-import Control.Monad.Trans (MonadIO(..))-import Control.Monad.Trans.Except (runExceptT)-import Network.Wai (Application, Request,- Response, ResponseReceived)-import Prelude ()-import Prelude.Compat-import Servant.Server.Internal.ServantErr+import Network.Wai+ (Application, Request, Response, ResponseReceived)+import Servant.Server.Internal.RouteResult+import Servant.Server.Internal.ServerError type RoutingApplication = Request -- ^ the request, the field 'pathInfo' may be modified by url routing -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived --- | The result of matching against a path in the route tree.-data RouteResult a =- Fail ServantErr -- ^ Keep trying other paths. The @ServantErr@- -- should only be 404, 405 or 406.- | FailFatal !ServantErr -- ^ Don't try other paths.- | Route !a- deriving (Eq, Show, Read, Functor)- toApplication :: RoutingApplication -> Application toApplication ra request respond = ra request routingRespond where routingRespond :: RouteResult Response -> IO ResponseReceived- routingRespond (Fail err) = respond $ responseServantErr err- routingRespond (FailFatal err) = respond $ responseServantErr err+ routingRespond (Fail err) = respond $ responseServerError err+ routingRespond (FailFatal err) = respond $ responseServerError err routingRespond (Route v) = respond v---- | A 'Delayed' is a representation of a handler with scheduled--- delayed checks that can trigger errors.------ Why would we want to delay checks?------ There are two reasons:------ 1. In a straight-forward implementation, the order in which we--- perform checks will determine the error we generate. This is--- because once an error occurs, we would abort and not perform--- any subsequent checks, but rather return the current error.------ This is not a necessity: we could continue doing other checks,--- and choose the preferred error. However, that would in general--- mean more checking, which leads us to the other reason.------ 2. We really want to avoid doing certain checks too early. For--- example, captures involve parsing, and are much more costly--- than static route matches. In particular, if several paths--- contain the "same" capture, we'd like as much as possible to--- avoid trying the same parse many times. Also tricky is the--- request body. Again, this involves parsing, but also, WAI makes--- obtaining the request body a side-effecting operation. We--- could/can work around this by manually caching the request body,--- but we'd rather keep the number of times we actually try to--- decode the request body to an absolute minimum.------ We prefer to have the following relative priorities of error--- codes:------ @--- 404--- 405 (bad method)--- 401 (unauthorized)--- 415 (unsupported media type)--- 400 (bad request)--- 406 (not acceptable)--- @------ Therefore, while routing, we delay most checks so that they--- will ultimately occur in the right order.------ A 'Delayed' contains three delayed blocks of tests, and--- the actual handler:------ 1. Delayed captures. These can actually cause 404, and--- while they're costly, they should be done first among the--- delayed checks (at least as long as we do not decouple the--- check order from the error reporting, see above). Delayed--- captures can provide inputs to the actual handler.------ 2. Method check(s). This can cause a 405. On success,--- it does not provide an input for the handler. Method checks--- are comparatively cheap.------ 3. Body and accept header checks. The request body check can--- cause both 400 and 415. This provides an input to the handler.--- The accept header check can be performed as the final--- computation in this block. It can cause a 406.----data Delayed env c where- Delayed :: { capturesD :: env -> DelayedIO captures- , methodD :: DelayedIO ()- , authD :: DelayedIO auth- , bodyD :: DelayedIO body- , serverD :: captures -> auth -> body -> Request -> RouteResult c- } -> Delayed env c--instance Functor (Delayed env) where- fmap f Delayed{..} =- Delayed- { serverD = \ c a b req -> f <$> serverD c a b req- , ..- } -- Note [Existential Record Update]---- | Computations used in a 'Delayed' can depend on the--- incoming 'Request', may perform 'IO, and result in a--- 'RouteResult, meaning they can either suceed, fail--- (with the possibility to recover), or fail fatally.----newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> IO (RouteResult a) }--instance Functor DelayedIO where- fmap = liftM--instance Applicative DelayedIO where- pure = return- (<*>) = ap--instance Monad DelayedIO where- return x = DelayedIO (const $ return (Route x))- DelayedIO m >>= f =- DelayedIO $ \ req -> do- r <- m req- case r of- Fail e -> return $ Fail e- FailFatal e -> return $ FailFatal e- Route a -> runDelayedIO (f a) req--instance MonadIO DelayedIO where- liftIO m = DelayedIO (const $ Route <$> m)---- | A 'Delayed' without any stored checks.-emptyDelayed :: RouteResult a -> Delayed env a-emptyDelayed result =- Delayed (const r) r r r (\ _ _ _ _ -> result)- where- r = return ()---- | Fail with the option to recover.-delayedFail :: ServantErr -> DelayedIO a-delayedFail err = DelayedIO (const $ return $ Fail err)---- | Fail fatally, i.e., without any option to recover.-delayedFailFatal :: ServantErr -> DelayedIO a-delayedFailFatal err = DelayedIO (const $ return $ FailFatal err)---- | Gain access to the incoming request.-withRequest :: (Request -> DelayedIO a) -> DelayedIO a-withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)---- | Add a capture to the end of the capture block.-addCapture :: Delayed env (a -> b)- -> (captured -> DelayedIO a)- -> Delayed (captured, env) b-addCapture Delayed{..} new =- Delayed- { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt- , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req- , ..- } -- Note [Existential Record Update]---- | Add a method check to the end of the method block.-addMethodCheck :: Delayed env a- -> DelayedIO ()- -> Delayed env a-addMethodCheck Delayed{..} new =- Delayed- { methodD = methodD <* new- , ..- } -- Note [Existential Record Update]---- | Add an auth check to the end of the auth block.-addAuthCheck :: Delayed env (a -> b)- -> DelayedIO a- -> Delayed env b-addAuthCheck Delayed{..} new =- Delayed- { authD = (,) <$> authD <*> new- , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req- , ..- } -- Note [Existential Record Update]---- | Add a body check to the end of the body block.-addBodyCheck :: Delayed env (a -> b)- -> DelayedIO a- -> Delayed env b-addBodyCheck Delayed{..} new =- Delayed- { bodyD = (,) <$> bodyD <*> new- , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req- , ..- } -- Note [Existential Record Update]----- | Add an accept header check to the beginning of the body--- block. There is a tradeoff here. In principle, we'd like--- to take a bad body (400) response take precedence over a--- failed accept check (406). BUT to allow streaming the body,--- we cannot run the body check and then still backtrack.--- We therefore do the accept check before the body check,--- when we can still backtrack. There are other solutions to--- this, but they'd be more complicated (such as delaying the--- body check further so that it can still be run in a situation--- where we'd otherwise report 406).-addAcceptCheck :: Delayed env a- -> DelayedIO ()- -> Delayed env a-addAcceptCheck Delayed{..} new =- Delayed- { bodyD = new *> bodyD- , ..- } -- Note [Existential Record Update]---- | Many combinators extract information that is passed to--- the handler without the possibility of failure. In such a--- case, 'passToServer' can be used.-passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b-passToServer Delayed{..} x =- Delayed- { serverD = \ c a b req -> ($ x req) <$> serverD c a b req- , ..- } -- Note [Existential Record Update]---- | Run a delayed server. Performs all scheduled operations--- in order, and passes the results from the capture and body--- blocks on to the actual handler.------ This should only be called once per request; otherwise the guarantees about--- effect and HTTP error ordering break down.-runDelayed :: Delayed env a- -> env- -> Request- -> IO (RouteResult a)-runDelayed Delayed{..} env = runDelayedIO $ do- c <- capturesD env- methodD- a <- authD- b <- bodyD- DelayedIO (\ req -> return $ serverD c a b req)---- | Runs a delayed server and the resulting action.--- Takes a continuation that lets us send a response.--- Also takes a continuation for how to turn the--- result of the delayed server into a response.-runAction :: Delayed env (Handler a)- -> env- -> Request- -> (RouteResult Response -> IO r)- -> (a -> RouteResult Response)- -> IO r-runAction action env req respond k =- runDelayed action env req >>= go >>= respond- where- go (Fail e) = return $ Fail e- go (FailFatal e) = return $ FailFatal e- go (Route a) = do- e <- runExceptT a- case e of- Left err -> return . Route $ responseServantErr err- Right x -> return $! k x--{- Note [Existential Record Update]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot-do the more succint thing - just update the records we actually change.--}
− src/Servant/Server/Internal/ServantErr.hs
@@ -1,447 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable #-}-module Servant.Server.Internal.ServantErr where--import Control.Exception (Exception)-import Control.Monad.Trans.Except (ExceptT)-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy as LBS-import Data.Typeable (Typeable)-import qualified Network.HTTP.Types as HTTP-import Network.Wai (Response, responseLBS)--data ServantErr = ServantErr { errHTTPCode :: Int- , errReasonPhrase :: String- , errBody :: LBS.ByteString- , errHeaders :: [HTTP.Header]- } deriving (Show, Eq, Read, Typeable)--instance Exception ServantErr--type Handler = ExceptT ServantErr IO--responseServantErr :: ServantErr -> Response-responseServantErr ServantErr{..} = responseLBS status errHeaders errBody- where- status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)---- | 'err300' Multiple Choices------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err300 { errBody = "I can't choose." }----err300 :: ServantErr-err300 = ServantErr { errHTTPCode = 300- , errReasonPhrase = "Multiple Choices"- , errBody = ""- , errHeaders = []- }---- | 'err301' Moved Permanently------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err301----err301 :: ServantErr-err301 = ServantErr { errHTTPCode = 301- , errReasonPhrase = "Moved Permanently"- , errBody = ""- , errHeaders = []- }---- | 'err302' Found------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err302----err302 :: ServantErr-err302 = ServantErr { errHTTPCode = 302- , errReasonPhrase = "Found"- , errBody = ""- , errHeaders = []- }---- | 'err303' See Other------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err303----err303 :: ServantErr-err303 = ServantErr { errHTTPCode = 303- , errReasonPhrase = "See Other"- , errBody = ""- , errHeaders = []- }---- | 'err304' Not Modified------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err304----err304 :: ServantErr-err304 = ServantErr { errHTTPCode = 304- , errReasonPhrase = "Not Modified"- , errBody = ""- , errHeaders = []- }---- | 'err305' Use Proxy------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err305----err305 :: ServantErr-err305 = ServantErr { errHTTPCode = 305- , errReasonPhrase = "Use Proxy"- , errBody = ""- , errHeaders = []- }---- | 'err307' Temporary Redirect------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err307----err307 :: ServantErr-err307 = ServantErr { errHTTPCode = 307- , errReasonPhrase = "Temporary Redirect"- , errBody = ""- , errHeaders = []- }---- | 'err400' Bad Request------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." }----err400 :: ServantErr-err400 = ServantErr { errHTTPCode = 400- , errReasonPhrase = "Bad Request"- , errBody = ""- , errHeaders = []- }---- | 'err401' Unauthorized------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." }----err401 :: ServantErr-err401 = ServantErr { errHTTPCode = 401- , errReasonPhrase = "Unauthorized"- , errBody = ""- , errHeaders = []- }---- | 'err402' Payment Required------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." }----err402 :: ServantErr-err402 = ServantErr { errHTTPCode = 402- , errReasonPhrase = "Payment Required"- , errBody = ""- , errHeaders = []- }---- | 'err403' Forbidden------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err403 { errBody = "Please login first." }----err403 :: ServantErr-err403 = ServantErr { errHTTPCode = 403- , errReasonPhrase = "Forbidden"- , errBody = ""- , errHeaders = []- }---- | 'err404' Not Found------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." }----err404 :: ServantErr-err404 = ServantErr { errHTTPCode = 404- , errReasonPhrase = "Not Found"- , errBody = ""- , errHeaders = []- }---- | 'err405' Method Not Allowed------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }----err405 :: ServantErr-err405 = ServantErr { errHTTPCode = 405- , errReasonPhrase = "Method Not Allowed"- , errBody = ""- , errHeaders = []- }---- | 'err406' Not Acceptable------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err406----err406 :: ServantErr-err406 = ServantErr { errHTTPCode = 406- , errReasonPhrase = "Not Acceptable"- , errBody = ""- , errHeaders = []- }---- | 'err407' Proxy Authentication Required------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err407----err407 :: ServantErr-err407 = ServantErr { errHTTPCode = 407- , errReasonPhrase = "Proxy Authentication Required"- , errBody = ""- , errHeaders = []- }---- | 'err409' Conflict------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }----err409 :: ServantErr-err409 = ServantErr { errHTTPCode = 409- , errReasonPhrase = "Conflict"- , errBody = ""- , errHeaders = []- }---- | 'err410' Gone------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }----err410 :: ServantErr-err410 = ServantErr { errHTTPCode = 410- , errReasonPhrase = "Gone"- , errBody = ""- , errHeaders = []- }---- | 'err411' Length Required------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError err411----err411 :: ServantErr-err411 = ServantErr { errHTTPCode = 411- , errReasonPhrase = "Length Required"- , errBody = ""- , errHeaders = []- }---- | 'err412' Precondition Failed------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }----err412 :: ServantErr-err412 = ServantErr { errHTTPCode = 412- , errReasonPhrase = "Precondition Failed"- , errBody = ""- , errHeaders = []- }---- | 'err413' Request Entity Too Large------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." }----err413 :: ServantErr-err413 = ServantErr { errHTTPCode = 413- , errReasonPhrase = "Request Entity Too Large"- , errBody = ""- , errHeaders = []- }---- | 'err414' Request-URI Too Large------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." }----err414 :: ServantErr-err414 = ServantErr { errHTTPCode = 414- , errReasonPhrase = "Request-URI Too Large"- , errBody = ""- , errHeaders = []- }---- | 'err415' Unsupported Media Type------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" }----err415 :: ServantErr-err415 = ServantErr { errHTTPCode = 415- , errReasonPhrase = "Unsupported Media Type"- , errBody = ""- , errHeaders = []- }---- | 'err416' Request range not satisfiable------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." }----err416 :: ServantErr-err416 = ServantErr { errHTTPCode = 416- , errReasonPhrase = "Request range not satisfiable"- , errBody = ""- , errHeaders = []- }---- | 'err417' Expectation Failed------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." }----err417 :: ServantErr-err417 = ServantErr { errHTTPCode = 417- , errReasonPhrase = "Expectation Failed"- , errBody = ""- , errHeaders = []- }---- | 'err500' Internal Server Error------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }----err500 :: ServantErr-err500 = ServantErr { errHTTPCode = 500- , errReasonPhrase = "Internal Server Error"- , errBody = ""- , errHeaders = []- }---- | 'err501' Not Implemented------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." }----err501 :: ServantErr-err501 = ServantErr { errHTTPCode = 501- , errReasonPhrase = "Not Implemented"- , errBody = ""- , errHeaders = []- }---- | 'err502' Bad Gateway------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }----err502 :: ServantErr-err502 = ServantErr { errHTTPCode = 502- , errReasonPhrase = "Bad Gateway"- , errBody = ""- , errHeaders = []- }---- | 'err503' Service Unavailable------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." }----err503 :: ServantErr-err503 = ServantErr { errHTTPCode = 503- , errReasonPhrase = "Service Unavailable"- , errBody = ""- , errHeaders = []- }---- | 'err504' Gateway Time-out------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }----err504 :: ServantErr-err504 = ServantErr { errHTTPCode = 504- , errReasonPhrase = "Gateway Time-out"- , errBody = ""- , errHeaders = []- }---- | 'err505' HTTP Version not supported------ Example usage:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." }----err505 :: ServantErr-err505 = ServantErr { errHTTPCode = 505- , errReasonPhrase = "HTTP Version not supported"- , errBody = ""- , errHeaders = []- }
+ src/Servant/Server/Internal/ServerError.hs view
@@ -0,0 +1,491 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Servant.Server.Internal.ServerError where++import Control.Exception+ (Exception)+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Typeable+ (Typeable)+import qualified Network.HTTP.Types as HTTP+import Network.Wai+ (Response, responseLBS)++data ServerError = ServerError+ { errHTTPCode :: Int+ , errReasonPhrase :: String+ , errBody :: LBS.ByteString+ , errHeaders :: [HTTP.Header]+ }+ deriving (Show, Eq, Read, Typeable)++instance Exception ServerError++responseServerError :: ServerError -> Response+responseServerError ServerError{..} = responseLBS status errHeaders errBody+ where+ status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)++-- | 'err300' Multiple Choices+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err300 { errBody = "I can't choose." }+--+err300 :: ServerError+err300 = ServerError { errHTTPCode = 300+ , errReasonPhrase = "Multiple Choices"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err301' Moved Permanently+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err301+--+err301 :: ServerError+err301 = ServerError { errHTTPCode = 301+ , errReasonPhrase = "Moved Permanently"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err302' Found+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err302+--+err302 :: ServerError+err302 = ServerError { errHTTPCode = 302+ , errReasonPhrase = "Found"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err303' See Other+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err303+--+err303 :: ServerError+err303 = ServerError { errHTTPCode = 303+ , errReasonPhrase = "See Other"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err304' Not Modified+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err304+--+err304 :: ServerError+err304 = ServerError { errHTTPCode = 304+ , errReasonPhrase = "Not Modified"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err305' Use Proxy+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err305+--+err305 :: ServerError+err305 = ServerError { errHTTPCode = 305+ , errReasonPhrase = "Use Proxy"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err307' Temporary Redirect+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err307+--+err307 :: ServerError+err307 = ServerError { errHTTPCode = 307+ , errReasonPhrase = "Temporary Redirect"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err400' Bad Request+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." }+--+err400 :: ServerError+err400 = ServerError { errHTTPCode = 400+ , errReasonPhrase = "Bad Request"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err401' Unauthorized+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." }+--+err401 :: ServerError+err401 = ServerError { errHTTPCode = 401+ , errReasonPhrase = "Unauthorized"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err402' Payment Required+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." }+--+err402 :: ServerError+err402 = ServerError { errHTTPCode = 402+ , errReasonPhrase = "Payment Required"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err403' Forbidden+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err403 { errBody = "Please login first." }+--+err403 :: ServerError+err403 = ServerError { errHTTPCode = 403+ , errReasonPhrase = "Forbidden"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err404' Not Found+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err404 { errBody = "Are you lost?" }+--+err404 :: ServerError+err404 = ServerError { errHTTPCode = 404+ , errReasonPhrase = "Not Found"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err405' Method Not Allowed+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }+--+err405 :: ServerError+err405 = ServerError { errHTTPCode = 405+ , errReasonPhrase = "Method Not Allowed"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err406' Not Acceptable+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err406+--+err406 :: ServerError+err406 = ServerError { errHTTPCode = 406+ , errReasonPhrase = "Not Acceptable"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err407' Proxy Authentication Required+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err407+--+err407 :: ServerError+err407 = ServerError { errHTTPCode = 407+ , errReasonPhrase = "Proxy Authentication Required"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err409' Conflict+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }+--+err409 :: ServerError+err409 = ServerError { errHTTPCode = 409+ , errReasonPhrase = "Conflict"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err410' Gone+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }+--+err410 :: ServerError+err410 = ServerError { errHTTPCode = 410+ , errReasonPhrase = "Gone"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err411' Length Required+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError err411+--+err411 :: ServerError+err411 = ServerError { errHTTPCode = 411+ , errReasonPhrase = "Length Required"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err412' Precondition Failed+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }+--+err412 :: ServerError+err412 = ServerError { errHTTPCode = 412+ , errReasonPhrase = "Precondition Failed"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err413' Request Entity Too Large+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." }+--+err413 :: ServerError+err413 = ServerError { errHTTPCode = 413+ , errReasonPhrase = "Request Entity Too Large"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err414' Request-URI Too Large+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." }+--+err414 :: ServerError+err414 = ServerError { errHTTPCode = 414+ , errReasonPhrase = "Request-URI Too Large"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err415' Unsupported Media Type+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" }+--+err415 :: ServerError+err415 = ServerError { errHTTPCode = 415+ , errReasonPhrase = "Unsupported Media Type"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err416' Request range not satisfiable+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." }+--+err416 :: ServerError+err416 = ServerError { errHTTPCode = 416+ , errReasonPhrase = "Request range not satisfiable"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err417' Expectation Failed+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." }+--+err417 :: ServerError+err417 = ServerError { errHTTPCode = 417+ , errReasonPhrase = "Expectation Failed"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err418' Expectation Failed+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err418 { errBody = "Apologies, this is not a webserver but a teapot." }+--+err418 :: ServerError+err418 = ServerError { errHTTPCode = 418+ , errReasonPhrase = "I'm a teapot"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err422' Unprocessable Entity+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err422 { errBody = "I understood your request, but can't process it." }+--+err422 :: ServerError+err422 = ServerError { errHTTPCode = 422+ , errReasonPhrase = "Unprocessable Entity"+ , errBody = ""+ , errHeaders = []+ }++-- | '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:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }+--+err500 :: ServerError+err500 = ServerError { errHTTPCode = 500+ , errReasonPhrase = "Internal Server Error"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err501' Not Implemented+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." }+--+err501 :: ServerError+err501 = ServerError { errHTTPCode = 501+ , errReasonPhrase = "Not Implemented"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err502' Bad Gateway+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }+--+err502 :: ServerError+err502 = ServerError { errHTTPCode = 502+ , errReasonPhrase = "Bad Gateway"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err503' Service Unavailable+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." }+--+err503 :: ServerError+err503 = ServerError { errHTTPCode = 503+ , errReasonPhrase = "Service Unavailable"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err504' Gateway Time-out+--+-- Example:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }+--+err504 :: ServerError+err504 = ServerError { errHTTPCode = 504+ , errReasonPhrase = "Gateway Time-out"+ , errBody = ""+ , errHeaders = []+ }++-- | 'err505' HTTP Version not supported+--+-- Example usage:+--+-- > failingHandler :: Handler ()+-- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." }+--+err505 :: ServerError+err505 = ServerError { errHTTPCode = 505+ , errReasonPhrase = "HTTP Version not supported"+ , errBody = ""+ , errHeaders = []+ }
+ src/Servant/Server/StaticFiles.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP #-}+-- | This module defines server-side handlers that lets you serve static files.+--+-- The most common needs for a web application are covered by+-- 'serveDirectoryWebApp`, but the other variants allow you to use+-- different `StaticSettings` and 'serveDirectoryWith' even allows you+-- to specify arbitrary 'StaticSettings' to be used for serving static files.+module Servant.Server.StaticFiles+ ( serveDirectoryWebApp+ , serveDirectoryWebAppLookup+ , serveDirectoryFileServer+ , serveDirectoryEmbedded+ , serveDirectoryWith+ , -- * Deprecated+ serveDirectory+ ) where++import Data.ByteString+ (ByteString)+import Network.Wai.Application.Static+import Servant.API.Raw+ (Raw)+import Servant.Server+ (ServerT, Tagged (..))+import System.FilePath+ (addTrailingPathSeparator)+import WaiAppStatic.Storage.Filesystem+ (ETagLookup)++-- | Serve anything under the specified directory as a 'Raw' endpoint.+--+-- @+-- type MyApi = "static" :> Raw+--+-- server :: Server MyApi+-- server = serveDirectoryWebApp "\/var\/www"+-- @+--+-- would capture any request to @\/static\/\<something>@ and look for+-- @\<something>@ under @\/var\/www@.+--+-- It will do its best to guess the MIME type for that file, based on the extension,+-- and send an appropriate /Content-Type/ header if possible.+--+-- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API+-- as a webapp backend, you will most likely not want the static files to be hidden+-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectoryWebApp'+-- handler in the last position, because /servant/ will try to match the handlers+-- in order.+--+-- Corresponds to the `defaultWebAppSettings` `StaticSettings` value.+serveDirectoryWebApp :: FilePath -> ServerT Raw m+serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath++-- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`.+serveDirectoryFileServer :: FilePath -> ServerT Raw m+serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath++-- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'.+serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> ServerT Raw m+serveDirectoryWebAppLookup etag =+ serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath++-- | Uses 'embeddedSettings'.+serveDirectoryEmbedded :: [(FilePath, ByteString)] -> ServerT Raw m+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 -> ServerT Raw m+serveDirectoryWith = Tagged . staticApp++-- | Same as 'serveDirectoryFileServer'. It used to be the only+-- file serving function in servant pre-0.10 and will be kept+-- around for a few versions, but is deprecated.+serveDirectory :: FilePath -> ServerT Raw m+serveDirectory = serveDirectoryFileServer+{-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-}++fixPath :: FilePath -> FilePath+fixPath = addTrailingPathSeparator
+ src/Servant/Server/UVerb.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Servant.Server.UVerb+ ( respond,+ IsServerResource,+ )+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 Network.HTTP.Types (Status, HeaderName, hContentType)+import Network.Wai (responseLBS, Request)+import Servant.API (ReflectMethod, reflectMethod)+import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)+import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))+import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)+import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)+++-- | '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 :: Type) (xs :: [Type]) (f :: Type -> Type).+ (Applicative f, HasStatus x, IsMember x xs) =>+ x ->+ f (Union xs)+respond = pure . inject . I++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+ => IsServerResource cts a where+ resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res+ resourceHeaders _ _ = []++instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))+ => IsServerResource cts (Headers h a) where+ resourceResponse request p res = resourceResponse request p (getResponse res)+ resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)++instance {-# OVERLAPPING #-} IsServerResource cts a+ => IsServerResource cts (WithStatus n a) where+ resourceResponse request p (WithStatus x) = resourceResponse request p x+ resourceHeaders cts (WithStatus x) = resourceHeaders cts x++encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)+ => Request -> Proxy cts -> a+ -> (Status, Maybe (BSL.ByteString, BSL.ByteString), [(HeaderName, B.ByteString)])+encodeResource request cts res = (statusOf (Proxy @a),+ resourceResponse request cts res,+ resourceHeaders cts res)++type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus++instance+ ( ReflectMethod method,+ AllMime contentTypes,+ All (IsServerResourceWithStatus contentTypes) as,+ Unique (Statuses as) -- for consistency with servant-swagger (server would work fine+ -- without; client is a bit of a corner case, because it dispatches+ -- the parser based on the status code. with this uniqueness+ -- constraint it won't have to run more than one parser in weird+ -- corner cases.+ ) =>+ HasServer (UVerb method contentTypes as) context+ where+ type ServerT (UVerb method contentTypes as) m = m (Union as)++ hoistServerWithContext _ _ nt s = nt s++ route ::+ forall env.+ Proxy (UVerb method contentTypes as) ->+ Context context ->+ Delayed env (Server (UVerb method contentTypes as)) ->+ Router env+ route _proxy _ctx action = leafRouter route'+ where+ method = reflectMethod (Proxy @method)+ route' env request cont = do+ let action' :: Delayed env (Handler (Union as))+ action' =+ action+ `addMethodCheck` methodCheck method request+ `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)++ runAction action' env request cont $ \(output :: Union as) -> do+ let cts = Proxy @contentTypes+ 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, BSL.toStrict contentT) : headers) bdy
src/Servant/Utils/StaticFiles.hs view
@@ -1,45 +1,6 @@-{-# LANGUAGE CPP #-}--- | This module defines a sever-side handler that lets you serve static files.------ - 'serveDirectory' lets you serve anything that lives under a particular--- directory on your filesystem.-module Servant.Utils.StaticFiles (- serveDirectory,- ) where--import Network.Wai.Application.Static (defaultFileServerSettings,- staticApp)-import Servant.API.Raw (Raw)-import Servant.Server (Server)-import System.FilePath (addTrailingPathSeparator)-#if !MIN_VERSION_wai_app_static(3,1,0)-import Filesystem.Path.CurrentOS (decodeString)-#endif+module Servant.Utils.StaticFiles+ {-# DEPRECATED "Use Servant.Server.StaticFiles." #-}+ ( module Servant.Server.StaticFiles )+ where --- | Serve anything under the specified directory as a 'Raw' endpoint.------ @--- type MyApi = "static" :> Raw------ server :: Server MyApi--- server = serveDirectory "\/var\/www"--- @------ would capture any request to @\/static\/\<something>@ and look for--- @\<something>@ under @\/var\/www@.------ It will do its best to guess the MIME type for that file, based on the extension,--- and send an appropriate /Content-Type/ header if possible.------ If your goal is to serve HTML, CSS and Javascript files that use the rest of the API--- as a webapp backend, you will most likely not want the static files to be hidden--- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectory'--- handler in the last position, because /servant/ will try to match the handlers--- in order.-serveDirectory :: FilePath -> Server Raw-serveDirectory =-#if MIN_VERSION_wai_app_static(3,1,0)- staticApp . defaultFileServerSettings . addTrailingPathSeparator-#else- staticApp . defaultFileServerSettings . decodeString . addTrailingPathSeparator-#endif+import Servant.Server.StaticFiles
− test/Doctests.hs
@@ -1,41 +0,0 @@-module Main where--import Data.List (isPrefixOf)-import System.Directory-import System.FilePath-import System.FilePath.Find-import Test.DocTest--main :: IO ()-main = do- files <- find always (extension ==? ".hs") "src"- mCabalMacrosFile <- getCabalMacrosFile- doctest $ "-isrc" : "-Iinclude" :- (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++- "-XOverloadedStrings" :- "-XFlexibleInstances" :- "-XMultiParamTypeClasses" :- "-XDataKinds" :- "-XTypeOperators" :- files--getCabalMacrosFile :: IO (Maybe FilePath)-getCabalMacrosFile = do- exists <- doesDirectoryExist "dist"- if exists- then do- contents <- getDirectoryContents "dist"- let rest = "build" </> "autogen" </> "cabal_macros.h"- whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of- [x] -> "dist" </> x </> rest- [] -> "dist" </> rest- xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"- ++ show xs ++ "\nTry cabal clean"- else return Nothing- where- whenExists :: FilePath -> IO (Maybe FilePath)- whenExists file = do- exists <- doesFileExist file- return $ if exists- then Just file- else Nothing
test/Servant/ArbitraryMonadServerSpec.hs view
@@ -3,15 +3,16 @@ {-# LANGUAGE TypeOperators #-} module Servant.ArbitraryMonadServerSpec where -import qualified Control.Category as C import Control.Monad.Reader+import Data.Functor.Identity import Data.Proxy import Servant.API import Servant.Server -import Test.Hspec (Spec, describe, it)-import Test.Hspec.Wai (get, matchStatus, post,- shouldRespondWith, with)+import Test.Hspec+ (Spec, describe, it)+import Test.Hspec.Wai+ (get, matchStatus, post, shouldRespondWith, with) spec :: Spec spec = describe "Arbitrary monad server" $ do@@ -27,23 +28,26 @@ readerAPI :: Proxy ReaderAPI readerAPI = Proxy +identityAPI :: Proxy IdentityAPI+identityAPI = Proxy+ combinedAPI :: Proxy CombinedAPI combinedAPI = Proxy readerServer' :: ServerT ReaderAPI (Reader String) readerServer' = return 1797 :<|> ask -fReader :: Reader String :~> Handler-fReader = generalizeNat C.. (runReaderTNat "hi")+fReader :: Reader String a -> Handler a+fReader x = return (runReader x "hi") readerServer :: Server ReaderAPI-readerServer = enter fReader readerServer'+readerServer = hoistServer readerAPI fReader readerServer' combinedReaderServer' :: ServerT CombinedAPI (Reader String)-combinedReaderServer' = readerServer' :<|> enter generalizeNat (return True)+combinedReaderServer' = readerServer' :<|> hoistServer identityAPI (return . runIdentity) (return True) combinedReaderServer :: Server CombinedAPI-combinedReaderServer = enter fReader combinedReaderServer'+combinedReaderServer = hoistServer combinedAPI fReader combinedReaderServer' enterSpec :: Spec enterSpec = describe "Enter" $ do
+ test/Servant/HoistSpec.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+module Servant.HoistSpec where++import Test.Hspec+ (Spec)++import Servant++-------------------------------------------------------------------------------+-- https://github.com/haskell-servant/servant/issues/734+-------------------------------------------------------------------------------++-- This didn't fail if executed in GHCi; cannot have as a doctest.++newtype App a = App a++type API = Get '[JSON] Int+ :<|> ReqBody '[JSON] String :> Get '[JSON] Bool++api :: Proxy API+api = Proxy++server :: App Int :<|> (String -> App Bool)+server = undefined++-- Natural transformation still seems to need an explicit type.+f :: App a -> App a+f = id++server' :: App Int :<|> (String -> App Bool)+server' = hoistServer api f server++-------------------------------------------------------------------------------+-- Spec+-------------------------------------------------------------------------------++spec :: Spec+spec = return ()
test/Servant/Server/ErrorSpec.hs view
@@ -6,15 +6,18 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Server.ErrorSpec (spec) where -import Control.Monad.Trans.Except (throwE)-import Data.Aeson (encode)+import Control.Monad+ (when)+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 Network.HTTP.Types (hAccept, hAuthorization,- hContentType, methodGet,- methodPost, methodPut)-import Safe (readMay)+import Network.HTTP.Types+ (hAccept, hAuthorization, hContentType, methodGet, methodPost,+ methodPut)+import Safe+ (readMay) import Test.Hspec import Test.Hspec.Wai @@ -26,6 +29,7 @@ prioErrorsSpec errorRetrySpec errorChoiceSpec+ customFormattersSpec -- * Auth machinery (reused throughout) @@ -45,13 +49,14 @@ :> BasicAuth "error-realm" () :> ReqBody '[JSON] Int :> Capture "t" Int+ :> QueryParam "param" Int :> Post '[JSON] Int errorOrderApi :: Proxy ErrorOrderApi errorOrderApi = Proxy errorOrderServer :: Server ErrorOrderApi-errorOrderServer = \_ _ _ -> throwE err402+errorOrderServer = \_ _ _ _ -> throwError err402 -- On error priorities: --@@ -86,7 +91,8 @@ goodContentType = (hContentType, "application/json") goodAccept = (hAccept, "application/json") goodMethod = methodPost- goodUrl = "home/2"+ goodUrl = "home/2?param=55"+ badParams = goodUrl <> "?param=foo" goodBody = encode (5 :: Int) -- username:password = servant:server goodAuth = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")@@ -96,25 +102,36 @@ `shouldRespondWith` 404 it "has 405 as its second highest priority error" $ do- request badMethod goodUrl [badAuth, badContentType, badAccept] badBody+ request badMethod badParams [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 405 it "has 401 as its third highest priority error (auth)" $ do- request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody+ request goodMethod badParams [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 401 it "has 406 as its fourth highest priority error" $ do- request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody+ request goodMethod badParams [goodAuth, badContentType, badAccept] badBody `shouldRespondWith` 406 it "has 415 as its fifth highest priority error" $ do- request goodMethod goodUrl [goodAuth, badContentType, goodAccept] badBody+ request goodMethod badParams [goodAuth, badContentType, goodAccept] badBody `shouldRespondWith` 415 it "has 400 as its sixth highest priority error" $ do- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody- `shouldRespondWith` 400+ badParamsRes <- request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody+ badBodyRes <- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody + -- Both bad body and bad params result in 400+ return badParamsRes `shouldRespondWith` 400+ return badBodyRes `shouldRespondWith` 400++ -- Param check should occur before body checks+ both <- request goodMethod badParams [goodAuth, goodContentType, goodAccept ] badBody+ when (both /= badParamsRes) $ liftIO $+ expectationFailure $ "badParams + badBody /= badParams: " ++ show both ++ ", " ++ show badParamsRes+ when (both == badBodyRes) $ liftIO $+ expectationFailure $ "badParams + badBody == badBody: " ++ show both+ it "has handler-level errors as last priority" $ do request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody `shouldRespondWith` 402@@ -187,7 +204,7 @@ errorRetryServer :: Server ErrorRetryApi errorRetryServer- = (\_ -> throwE err402)+ = (\_ -> throwError err402) :<|> (\_ -> return 1) :<|> (\_ -> return 2) :<|> (\_ -> return 3)@@ -211,11 +228,16 @@ it "should continue when URLs don't match" $ do request methodPost "" [jsonCT, jsonAccept] jsonBody- `shouldRespondWith` 200 { matchBody = Just $ encode (8 :: Int) }+ `shouldRespondWith` 200 { matchBody = mkBody $ encode (8 :: Int) } it "should continue when methods don't match" $ do request methodGet "a" [jsonCT, jsonAccept] jsonBody- `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }+ `shouldRespondWith` 200 { matchBody = mkBody $ encode (4 :: Int) }+ where+ mkBody b = MatchBody $ \_ b' ->+ if b == b'+ then Nothing+ else Just "body not correct\n" -- }}} ------------------------------------------------------------------------------@@ -228,6 +250,8 @@ :<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 3 :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- 4 :<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- 5+ :<|> "path5" :> (ReqBody '[JSON] Int :> Post '[PlainText] Int -- 6+ :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- 7 errorChoiceApi :: Proxy ErrorChoiceApi errorChoiceApi = Proxy@@ -237,8 +261,8 @@ :<|> return 1 :<|> return 2 :<|> (\_ -> return 3)- :<|> (\_ -> return 4)- :<|> (\_ -> return 5)+ :<|> ((\_ -> return 4) :<|> (\_ -> return 5))+ :<|> ((\_ -> return 6) :<|> (\_ -> return 7)) errorChoiceSpec :: Spec@@ -259,15 +283,77 @@ request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"), (hAccept, "blah")] "5" `shouldRespondWith` 406+ it "should respond with 415 only if none of the subservers supports the request's content type" $ do+ request methodPost "path5" [(hContentType, "text/plain;charset=utf-8")] "1"+ `shouldRespondWith` 200+ request methodPost "path5" [(hContentType, "application/json")] "1"+ `shouldRespondWith` 200+ request methodPost "path5" [(hContentType, "application/not-supported")] ""+ `shouldRespondWith` 415 -- }}} ------------------------------------------------------------------------------+-- * Custom errors {{{++customFormatter :: ErrorFormatter+customFormatter _ _ err = err400 { errBody = "CUSTOM! " <> BSL8.pack err }++customFormatters :: ErrorFormatters+customFormatters = defaultErrorFormatters+ { bodyParserErrorFormatter = customFormatter+ , urlParseErrorFormatter = customFormatter+ , notFoundErrorFormatter = const $ err404 { errBody = "CUSTOM! Not Found" }+ }++type CustomFormatterAPI+ = "query" :> QueryParam' '[Required, Strict] "param" Int :> Get '[PlainText] String+ :<|> "capture" :> Capture "cap" Bool :> Get '[PlainText] String+ :<|> "body" :> ReqBody '[JSON] Int :> Post '[PlainText] String++customFormatterAPI :: Proxy CustomFormatterAPI+customFormatterAPI = Proxy++customFormatterServer :: Server CustomFormatterAPI+customFormatterServer = (\_ -> return "query")+ :<|> (\_ -> return "capture")+ :<|> (\_ -> return "body")++customFormattersSpec :: Spec+customFormattersSpec = describe "Custom errors from combinators"+ $ with (return $ serveWithContext customFormatterAPI (customFormatters :. EmptyContext) customFormatterServer) $ do++ let startsWithCustom = ResponseMatcher+ { matchStatus = 400+ , matchHeaders = []+ , matchBody = MatchBody $ \_ body -> if "CUSTOM!" `BSL8.isPrefixOf` body+ then Nothing+ else Just $ show body <> " does not start with \"CUSTOM!\""+ }++ it "formats query parse error" $ do+ request methodGet "query?param=false" [] ""+ `shouldRespondWith` startsWithCustom++ it "formats query parse error with missing param" $ do+ request methodGet "query" [] ""+ `shouldRespondWith` startsWithCustom++ it "formats capture parse error" $ do+ request methodGet "capture/42" [] ""+ `shouldRespondWith` startsWithCustom++ it "formats body parse error" $ do+ request methodPost "body" [(hContentType, "application/json")] "foo"+ `shouldRespondWith` startsWithCustom++-- }}}+------------------------------------------------------------------------------ -- * 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/Internal/ContextSpec.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE DataKinds #-}-{-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-}+{-# OPTIONS_GHC -fdefer-type-errors -Wwarn -Wno-deferred-type-errors #-} module Servant.Server.Internal.ContextSpec (spec) where -import Data.Proxy (Proxy (..))-import Test.Hspec (Spec, describe, it, shouldBe, context)-import Test.ShouldNotTypecheck (shouldNotTypecheck)+import Data.Proxy+ (Proxy (..))+import Test.Hspec+ (Spec, context, describe, it, shouldBe)+import Test.ShouldNotTypecheck+ (shouldNotTypecheck) import Servant.API import Servant.Server.Internal.Context@@ -36,8 +39,8 @@ show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)" it "works with operators" $ do- let cxt = ((1 :: Integer) :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)- show cxt `shouldBe` "(1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)"+ let cxt = (1 :: Integer) :. 'a' :. EmptyContext :<|> 'b' :. True :. EmptyContext+ show cxt `shouldBe` "1 :. 'a' :. EmptyContext :<|> 'b' :. True :. EmptyContext" describe "descendIntoNamedContext" $ do let cxt :: Context [Char, NamedContext "sub" '[Char]]
+ test/Servant/Server/Internal/RoutingApplicationSpec.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Servant.Server.Internal.RoutingApplicationSpec (spec) where++import Prelude ()+import Prelude.Compat++import Control.Exception hiding+ (Handler)+import Control.Monad.IO.Class+import Control.Monad.Trans.Resource+ (register)+import Data.IORef+import Data.Proxy+import GHC.TypeLits+ (KnownSymbol, Symbol, symbolVal)+import Network.Wai+ (defaultRequest)+import Servant+import Servant.Server.Internal+import Test.Hspec+import Test.Hspec.Wai+ (request, shouldRespondWith, with)++import qualified Data.Text as T++import System.IO.Unsafe+ (unsafePerformIO)++data TestResource x+ = TestResourceNone+ | TestResource x+ | TestResourceFreed+ | TestResourceError+ deriving (Eq, Show)++-- Let's not write to the filesystem+delayedTestRef :: IORef (TestResource String)+delayedTestRef = unsafePerformIO $ newIORef TestResourceNone++fromTestResource :: a -> (b -> a) -> TestResource b -> a+fromTestResource _ f (TestResource x) = f x+fromTestResource x _ _ = x++initTestResource :: IO ()+initTestResource = writeIORef delayedTestRef TestResourceNone++writeTestResource :: String -> IO ()+writeTestResource x = modifyIORef delayedTestRef $ \r -> case r of+ TestResourceNone -> TestResource x+ _ -> TestResourceError++freeTestResource :: IO ()+freeTestResource = modifyIORef delayedTestRef $ \r -> case r of+ TestResource _ -> TestResourceFreed+ _ -> TestResourceError++delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())+delayed body srv = Delayed+ { capturesD = \() -> return ()+ , methodD = return ()+ , authD = return ()+ , acceptD = return ()+ , contentD = return ()+ , paramsD = return ()+ , headersD = return ()+ , bodyD = \() -> do+ liftIO (writeTestResource "hia" >> putStrLn "garbage created")+ _ <- register (freeTestResource >> putStrLn "garbage collected")+ body+ , serverD = \() () () () _body _req -> srv+ }++simpleRun :: Delayed () (Handler ())+ -> IO ()+simpleRun d = fmap (either ignoreE id) . try $+ runAction d () defaultRequest (\_ -> return ()) (\_ -> FailFatal err500)++ where ignoreE :: SomeException -> ()+ ignoreE = const ()++-------------------------------------------------------------------------------+-- Combinator example+-------------------------------------------------------------------------------++-- | This data types writes 'sym' to 'delayedTestRef'.+data Res (sym :: Symbol)++instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where+ type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m++ hoistServerWithContext _ nc nt s = hoistServerWithContext (Proxy :: Proxy api) nc nt . s++ route Proxy ctx server = route (Proxy :: Proxy api) ctx $+ addBodyCheck server (return ()) check+ where+ sym = symbolVal (Proxy :: Proxy sym)+ check () = do+ liftIO $ writeTestResource sym+ _ <- register freeTestResource+ return delayedTestRef++type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text++resApi :: Proxy ResApi+resApi = Proxy++resServer :: Server ResApi+resServer ref = liftIO $ fmap (fromTestResource "<wrong>" T.pack) $ readIORef ref++-------------------------------------------------------------------------------+-- Spec+-------------------------------------------------------------------------------++spec :: Spec+spec = do+ describe "Delayed" $ do+ it "actually runs clean up actions" $ do+ liftIO initTestResource+ _ <- simpleRun $ delayed (return ()) (Route $ return ())+ res <- readIORef delayedTestRef+ res `shouldBe` TestResourceFreed+ it "even with exceptions in serverD" $ do+ liftIO initTestResource+ _ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)+ res <- readIORef delayedTestRef+ res `shouldBe` TestResourceFreed+ it "even with routing failure in bodyD" $ do+ liftIO initTestResource+ _ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())+ res <- readIORef delayedTestRef+ res `shouldBe` TestResourceFreed+ it "even with exceptions in bodyD" $ do+ liftIO initTestResource+ _ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())+ res <- readIORef delayedTestRef+ res `shouldBe` TestResourceFreed+ describe "ResApi" $+ with (return $ serve resApi resServer) $ do+ it "writes and cleanups resources" $ do+ liftIO initTestResource+ request "GET" "foobar" [] "" `shouldRespondWith` "foobar"+ liftIO $ do+ res <- readIORef delayedTestRef+ res `shouldBe` TestResourceFreed
test/Servant/Server/RouterSpec.hs view
@@ -1,43 +1,81 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeOperators #-} module Servant.Server.RouterSpec (spec) where -import Control.Monad (unless)-import Data.Proxy (Proxy(..))-import Data.Text (unpack)-import Network.HTTP.Types (Status (..))-import Network.Wai (responseBuilder)-import Network.Wai.Internal (Response (ResponseBuilder))-import Test.Hspec-import Test.Hspec.Wai (get, shouldRespondWith, with)+import Control.Monad+ (unless)+import Data.Proxy+ (Proxy (..))+import Data.Text+ (Text, unpack)+import Data.Typeable+ (typeRep)+import Network.HTTP.Types+ (Status (..))+import Network.Wai+ (responseBuilder)+import Network.Wai.Internal+ (Response (ResponseBuilder)) import Servant.API import Servant.Server import Servant.Server.Internal+import Test.Hspec+import Test.Hspec.Wai+ (get, shouldRespondWith, with) spec :: Spec spec = describe "Servant.Server.Internal.Router" $ do routerSpec distributivitySpec+ serverLayoutSpec routerSpec :: Spec routerSpec = do- let app' :: Application- app' = toApplication $ runRouter router'+ describe "tweakResponse" $ do+ let app' :: Application+ app' = toApplication $ runRouter (const err404) router' - router', router :: Router ()- router' = tweakResponse (fmap twk) router- router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")+ router', router :: Router ()+ router' = tweakResponse (fmap twk) router+ router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "") - twk :: Response -> Response- twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b- twk b = b+ twk :: Response -> Response+ twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b+ twk b = b - describe "tweakResponse" . with (return app') $ do- it "calls f on route result" $ do- get "" `shouldRespondWith` 202+ with (return app') $ do+ it "calls f on route result" $ do+ get "" `shouldRespondWith` 202 + describe "runRouter" $ do+ let toApp :: Router () -> Application+ toApp = toApplication . runRouter (const err404)++ cap :: Router ()+ cap = CaptureRouter [hint] $+ let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)+ in leafRouter+ $ \env req res ->+ runAction delayed env req res+ . const+ $ Route success++ hint :: CaptureHint+ hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())++ router :: Router ()+ router = leafRouter (\_ _ res -> res $ Route success)+ `Choice` cap++ success :: Response+ success = responseBuilder (Status 200 "") [] ""++ with (pure $ toApp router) $ do+ it "capture failure returns a 400 response" $ do+ get "/badcapture" `shouldRespondWith` 400+ distributivitySpec :: Spec distributivitySpec = describe "choice" $ do@@ -49,6 +87,8 @@ dynamic `shouldHaveSameStructureAs` dynamicRef it "properly reorders permuted static paths" $ do permute `shouldHaveSameStructureAs` permuteRef+ it "properly reorders permuted static paths in the presence of QueryParams" $ do+ permuteQuery `shouldHaveSameStructureAs` permuteRef it "properly reorders permuted static paths in the presence of Raw in end" $ do permuteRawEnd `shouldHaveSameStructureAs` permuteRawEndRef it "properly reorders permuted static paths in the presence of Raw in beginning" $ do@@ -64,12 +104,30 @@ it "properly handles mixing static paths at different levels" $ do level `shouldHaveSameStructureAs` levelRef +serverLayoutSpec :: Spec+serverLayoutSpec =+ describe "serverLayout" $ do+ it "correctly represents the example API" $ do+ exampleLayout `shouldHaveLayout` expectedExampleLayout+ it "aggregates capture hints when different" $ do+ captureDifferentTypes `shouldHaveLayout` expectedCaptureDifferentTypes+ it "nubs capture hints when equal" $ do+ captureSameType `shouldHaveLayout` expectedCaptureSameType+ it "properly displays CaptureAll hints" $ do+ captureAllLayout `shouldHaveLayout` expectedCaptureAllLayout+ shouldHaveSameStructureAs :: (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation shouldHaveSameStructureAs p1 p2 = unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $ expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1)) +shouldHaveLayout ::+ (HasServer api '[]) => Proxy api -> Text -> Expectation+shouldHaveLayout p l =+ unless (routerLayout (makeTrivialRouter p) == l) $+ expectationFailure ("expected:\n" ++ unpack l ++ "\nbut got:\n" ++ unpack (layout p))+ makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router () makeTrivialRouter p = route p EmptyContext (emptyDelayed (FailFatal err501))@@ -110,12 +168,12 @@ -- structure: type Dynamic =- "a" :> Capture "foo" Int :> "b" :> End- :<|> "a" :> Capture "bar" Bool :> "c" :> End- :<|> "a" :> Capture "baz" Char :> "d" :> End+ "a" :> Capture "foo" Int :> "b" :> End+ :<|> "a" :> Capture "foo" Int :> "c" :> End+ :<|> "a" :> Capture "foo" Int :> "d" :> End type DynamicRef =- "a" :> Capture "anything" () :>+ "a" :> Capture "foo" Int :> ("b" :> End :<|> "c" :> End :<|> "d" :> End) dynamic :: Proxy Dynamic@@ -154,6 +212,19 @@ permuteRef :: Proxy PermuteRef permuteRef = Proxy +-- Adding a "QueryParam" should not affect structure++type PermuteQuery =+ QueryParam "1" Int :> "a" :> "b" :> "c" :> End+ :<|> QueryParam "2" Int :> "b" :> "a" :> "c" :> End+ :<|> QueryParam "3" Int :> "a" :> "c" :> "b" :> End+ :<|> QueryParam "4" Int :> "c" :> "a" :> "b" :> End+ :<|> QueryParam "5" Int :> "b" :> "c" :> "a" :> End+ :<|> QueryParam "6" Int :> "c" :> "b" :> "a" :> End++permuteQuery :: Proxy PermuteQuery+permuteQuery = Proxy+ -- Adding a 'Raw' in one of the ends should have minimal -- effect on the grouping. @@ -292,3 +363,100 @@ levelRef :: Proxy LevelRef levelRef = Proxy++-- The example API for the 'layout' function.+-- Should get factorized by the 'choice' smart constructor.+type ExampleLayout =+ "a" :> "d" :> Get '[JSON] NoContent+ :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool+ :<|> "c" :> Put '[JSON] Bool+ :<|> "a" :> "e" :> Get '[JSON] Int+ :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool+ :<|> Raw++exampleLayout :: Proxy ExampleLayout+exampleLayout = Proxy++-- The expected representation of the example API layout+--+expectedExampleLayout :: Text+expectedExampleLayout =+ "/\n\+ \├─ a/\n\+ \│ ├─ d/\n\+ \│ │ └─•\n\+ \│ └─ e/\n\+ \│ └─•\n\+ \├─ b/\n\+ \│ └─ <x::Int>/\n\+ \│ ├─•\n\+ \│ ┆\n\+ \│ └─•\n\+ \├─ c/\n\+ \│ └─•\n\+ \┆\n\+ \└─ <raw>\n"++-- A capture API with all capture types being the same+--+type CaptureSameType =+ "a" :> Capture "foo" Int :> "b" :> End+ :<|> "a" :> Capture "foo" Int :> "c" :> End+ :<|> "a" :> Capture "foo" Int :> "d" :> End++captureSameType :: Proxy CaptureSameType+captureSameType = Proxy++-- The expected representation of the CaptureSameType API layout.+--+expectedCaptureSameType :: Text+expectedCaptureSameType =+ "/\n\+ \└─ a/\n\+ \ └─ <foo::Int>/\n\+ \ ├─ b/\n\+ \ │ └─•\n\+ \ ├─ c/\n\+ \ │ └─•\n\+ \ └─ d/\n\+ \ └─•\n"++-- A capture API capturing different types+--+type CaptureDifferentTypes =+ "a" :> Capture "foo" Int :> "b" :> End+ :<|> "a" :> Capture "bar" Bool :> "c" :> End+ :<|> "a" :> Capture "baz" Char :> "d" :> End++captureDifferentTypes :: Proxy CaptureDifferentTypes+captureDifferentTypes = Proxy++-- The expected representation of the CaptureDifferentTypes API layout.+--+expectedCaptureDifferentTypes :: Text+expectedCaptureDifferentTypes =+ "/\n\+ \└─ a/\n\+ \ └─ <foo::Int|bar::Bool|baz::Char>/\n\+ \ ├─ b/\n\+ \ │ └─•\n\+ \ ├─ c/\n\+ \ │ └─•\n\+ \ └─ d/\n\+ \ └─•\n"++-- An API with a CaptureAll part++type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End++captureAllLayout :: Proxy CaptureAllLayout+captureAllLayout = Proxy++-- The expected representation of the CaptureAllLayout API.+--+expectedCaptureAllLayout :: Text+expectedCaptureAllLayout =+ "/\n\+ \└─ a/\n\+ \ └─ <foos::[Int]>/\n\+ \ └─•\n"
+ test/Servant/Server/StaticFilesSpec.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Servant.Server.StaticFilesSpec where++import Control.Exception+ (bracket)+import Data.Proxy+ (Proxy (Proxy))+import Network.Wai+ (Application)+import System.Directory+ (createDirectory, getCurrentDirectory, setCurrentDirectory)+import System.IO.Temp+ (withSystemTempDirectory)+import Test.Hspec+ (Spec, around_, describe, it)+import Test.Hspec.Wai+ (get, shouldRespondWith, with)++import Servant.API+ ((:<|>) ((:<|>)), (:>), Capture, Get, JSON, Raw)+import Servant.Server+ (Server, serve)+import Servant.Server.StaticFiles+ (serveDirectoryFileServer)+import Servant.ServerSpec+ (Person (Person))++type Api =+ "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person+ :<|> "static" :> Raw+++api :: Proxy Api+api = Proxy++app :: Application+app = serve api server++server :: Server Api+server =+ (\ name_ -> return (Person name_ 42))+ :<|> serveDirectoryFileServer "static"++withStaticFiles :: IO () -> IO ()+withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->+ bracket (setup tmpDir) teardown (const action)+ where+ setup tmpDir = do+ outer <- getCurrentDirectory+ setCurrentDirectory tmpDir+ createDirectory "static"+ writeFile "static/foo.txt" "bar"+ writeFile "static/index.html" "index"+ return outer++ teardown outer = do+ setCurrentDirectory outer++spec :: Spec+spec = do+ around_ withStaticFiles $ with (return app) $ do+ describe "serveDirectory" $ do+ it "successfully serves files" $ do+ get "/static/foo.txt" `shouldRespondWith` "bar"++ it "serves the contents of index.html when requesting the root of a directory" $ do+ get "/static/" `shouldRespondWith` "index"
test/Servant/Server/StreamingSpec.hs view
@@ -1,18 +1,19 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-} -- | This module tests whether streaming works from client to server -- with a server implemented with servant-server. module Servant.Server.StreamingSpec where import Control.Concurrent-import Control.Exception hiding (Handler)+import Control.Exception hiding+ (Handler) import Control.Monad.IO.Class-import qualified Data.ByteString as Strict-import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Lazy as Lazy import Network.HTTP.Types import Network.Wai import Network.Wai.Internal@@ -80,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.hs view
@@ -1,12 +1,13 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeOperators #-} module Servant.Server.UsingContextSpec where import Network.Wai-import Test.Hspec (Spec, describe, it)+import Test.Hspec+ (Spec, describe, it) import Test.Hspec.Wai import Servant
test/Servant/Server/UsingContextSpec/TestCombinators.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} -- | These are custom combinators for Servant.Server.UsingContextSpec. --@@ -20,6 +20,7 @@ import GHC.TypeLits import Servant+import Data.Kind (Type) data ExtractFromContext @@ -29,13 +30,15 @@ type ServerT (ExtractFromContext :> subApi) m = String -> ServerT subApi m + 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 @@ -45,6 +48,9 @@ type ServerT (InjectIntoContext :> subApi) m = ServerT subApi m + hoistServerWithContext _ _ nt s =+ hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy (String ': context)) nt s+ route Proxy context delayed = route subProxy newContext delayed where@@ -53,13 +59,16 @@ 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 type ServerT (NamedContextWithBirdface name subContext :> subApi) m = ServerT subApi m++ hoistServerWithContext _ _ nt s =+ hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s route Proxy context delayed = route subProxy subContext delayed
test/Servant/ServerSpec.hs view
@@ -1,91 +1,120 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -freduction-depth=100 #-} module Servant.ServerSpec where -import Control.Monad (forM_, when, unless)-import Control.Monad.Trans.Except (throwE)-import Data.Aeson (FromJSON, ToJSON, decode', encode)-import qualified Data.ByteString.Base64 as Base64-import Data.ByteString.Conversion ()-import Data.Char (toUpper)-import Data.Monoid-import Data.Proxy (Proxy (Proxy))-import Data.String (fromString)-import Data.String.Conversions (cs)-import qualified Data.Text as T-import GHC.Generics (Generic)-import Network.HTTP.Types (Status (..), hAccept, hContentType,- methodDelete, methodGet,- methodHead, methodPatch,- methodPost, methodPut, ok200,- imATeaPot418,- parseQuery)-import Network.Wai (Application, Request, requestHeaders, pathInfo,- queryString, rawQueryString,- responseLBS)-import Network.Wai.Test (defaultRequest, request,- runSession, simpleBody,- simpleHeaders, simpleStatus)-import Servant.API ((:<|>) (..), (:>), AuthProtect,- BasicAuth, BasicAuthData(BasicAuthData),- Capture, CaptureAll, Delete, Get, Header (..),- Headers, HttpVersion,- IsSecure (..), JSON,- NoContent (..), Patch, PlainText,- Post, Put,- QueryFlag, QueryParam, QueryParams,- Raw, RemoteHost, ReqBody,- StdMethod (..), Verb, addHeader)-import Servant.API.Internal.Test.ComprehensiveAPI-import Servant.Server (Server, Handler, err401, err403,- err404, serve, serveWithContext,- Context((:.), EmptyContext))-import Test.Hspec (Spec, context, describe, it,- shouldBe, shouldContain)-import qualified Test.Hspec.Wai as THW-import Test.Hspec.Wai (get, liftIO, matchHeaders,- matchStatus, shouldRespondWith,- with, (<:>))+import Prelude ()+import Prelude.Compat -import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck),- BasicAuthResult(Authorized,Unauthorized))+import Control.Monad+ (forM_, join, unless, when)+import Control.Monad.Reader (runReaderT, ask)+import Control.Monad.Error.Class+ (MonadError (..))+import Control.Monad.IO.Class (MonadIO(..))+import Data.Aeson+ (FromJSON, ToJSON, decode', encode)+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)+import Data.Maybe+ (fromMaybe)+import Data.Proxy+ (Proxy (Proxy))+import Data.String+ (fromString)+import qualified Data.Text as T+import GHC.Generics+ (Generic)+import Network.HTTP.Types+ (QueryItem, Status (..), hAccept, hContentType, imATeapot418,+ methodDelete, methodGet, methodHead, methodPatch, methodPost,+ methodPut, ok200, parseQuery)+import Network.Wai+ (Application, Middleware, Request, pathInfo, queryString,+ rawQueryString, requestHeaders, responseLBS)+import Network.Wai.Test+ (defaultRequest, request, runSession, simpleBody,+ simpleHeaders, simpleStatus)+import Servant.API+ ((:<|>) (..), (:>), AuthProtect, BasicAuth,+ BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,+ 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, addHeader')+import Servant.API.QueryString (FromDeepQuery(..))+import Servant.Server+ (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..),+ emptyServer, err401, err403, err404, hoistServer, respond, serve,+ serveWithContext)+import Servant.Test.ComprehensiveAPI+import qualified Servant.Types.SourceT as S+import Test.Hspec+ (Spec, context, describe, it, shouldBe, shouldContain)+import Test.Hspec.Wai+ (get, matchHeaders, matchStatus, shouldRespondWith,+ with, (<:>))+import qualified Test.Hspec.Wai as THW+import Text.Read (readMaybe)+ import Servant.Server.Experimental.Auth- (AuthHandler, AuthServerData,- mkAuthHandler)+ (AuthHandler, AuthServerData, mkAuthHandler)+import Servant.Server.Internal.BasicAuth+ (BasicAuthCheck (BasicAuthCheck),+ BasicAuthResult (Authorized, Unauthorized)) import Servant.Server.Internal.Context- (NamedContext(..))+ (NamedContext (..)) -- * comprehensive api test -- This declaration simply checks that all instances are in place. _ = serveWithContext comprehensiveAPI comprehensiveApiContext -comprehensiveApiContext :: Context '[NamedContext "foo" '[]]-comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext+comprehensiveApiContext :: Context '[NamedContext "foo" '[], Acquire Int]+comprehensiveApiContext =+ NamedContext EmptyContext :.+ mkAcquire (pure 10) (\_ -> pure ()) :.+ EmptyContext -- * Specs spec :: Spec spec = do verbSpec+ uverbSpec captureSpec+ captureAllSpec queryParamSpec+ fragmentSpec reqBodySpec headerSpec rawSpec+ rawMSpec alternativeSpec responseHeadersSpec+ uverbResponseHeadersSpec miscCombinatorSpec basicAuthSpec genAuthSpec@@ -96,12 +125,14 @@ type VerbApi method status = Verb method status '[JSON] Person- :<|> "noContent" :> Verb method status '[JSON] NoContent+ :<|> "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 )+ :<|> "stream" :> Stream method status NoFraming OctetStream (SourceIO BS.ByteString) verbSpec :: Spec verbSpec = describe "Servant.API.Verb" $ do@@ -110,7 +141,10 @@ :<|> return NoContent :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent)+ :<|> return (addHeader' 5 alice) :<|> (return alice :<|> return "B")+ :<|> return (S.source ["bytestring"])+ get200 = Proxy :: Proxy (VerbApi 'GET 200) post210 = Proxy :: Proxy (VerbApi 'POST 210) put203 = Proxy :: Proxy (VerbApi 'PUT 203)@@ -130,7 +164,7 @@ it "returns no content on NoContent" $ do response <- THW.request method "/noContent" [] ""- liftIO $ statusCode (simpleStatus response) `shouldBe` status+ liftIO $ statusCode (simpleStatus response) `shouldBe` 204 liftIO $ simpleBody response `shouldBe` "" -- HEAD should not return body@@ -139,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" [] ""@@ -152,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 ""@@ -174,8 +210,13 @@ it "sets the Content-Type header" $ do response <- THW.request method "" [] "" liftIO $ simpleHeaders response `shouldContain`- [("Content-Type", "application/json")]+ [("Content-Type", "application/json;charset=utf-8")] + it "works for Stream as for Result" $ do+ response <- THW.request method "/stream" [] ""+ liftIO $ statusCode (simpleStatus response) `shouldBe` status+ liftIO $ simpleBody response `shouldBe` "bytestring"+ test "GET 200" get200 methodGet 200 test "POST 210" post210 methodPost 210 test "PUT 203" put203 methodPut 203@@ -189,99 +230,163 @@ ------------------------------------------------------------------------------ type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal+ :<|> "ears" :> Capture' '[Lenient] "ears" Integer :> Get '[JSON] Animal+ :<|> "eyes" :> Capture' '[Strict] "eyes" Integer :> Get '[JSON] Animal captureApi :: Proxy CaptureApi captureApi = Proxy-captureServer :: Integer -> Handler Animal-captureServer legs = case legs of- 4 -> return jerry- 2 -> return tweety- _ -> throwE err404 +captureServer :: Server CaptureApi+captureServer = getLegs :<|> getEars :<|> getEyes+ where getLegs :: Integer -> Handler Animal+ getLegs legs = case legs of+ 4 -> return jerry+ 2 -> return tweety+ _ -> throwError err404++ getEars :: Either String Integer -> Handler Animal+ getEars (Left _) = return chimera -- ignore integer parse error, return weird animal+ getEars (Right 2) = return jerry+ getEars (Right _) = throwError err404++ getEyes :: Integer -> Handler Animal+ getEyes 2 = return jerry+ 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 - with (return (serve- (Proxy :: Proxy (Capture "captured" String :> Raw))- (\ "captured" 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]))+ 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 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 [] (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- _ -> throwE 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 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])))+ (\ _captured -> Tagged $ \request_ sendResponse ->+ 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+qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges :<|> qpRaw :<|> qpDeep where qpNames (_:name2:_) = return alice { name = name2 } qpNames _ = return alice@@ -289,75 +394,188 @@ qpCapitalize False = return alice qpCapitalize True = return alice { name = map toUpper (name alice) } + qpAge Nothing = return alice+ qpAge (Just age') = return alice{ age = age'}++ qpAges ages = return alice{ age = sum ages}++ 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 ++ queryParamSpec :: Spec queryParamSpec = do+ let mkRequest params pinfo = Network.Wai.Test.request defaultRequest+ { rawQueryString = params+ , queryString = parseQuery params+ , pathInfo = pinfo+ }+ describe "Servant.API.QueryParam" $ do it "allows retrieving simple GET parameters" $- (flip runSession) (serve queryParamApi qpServer) $ do- let params1 = "?name=bob"- response1 <- Network.Wai.Test.request defaultRequest{- rawQueryString = params1,- queryString = parseQuery params1- }- liftIO $ do- decode' (simpleBody response1) `shouldBe` Just alice{- name = "bob"- }+ flip runSession (serve queryParamApi qpServer) $ do+ response1 <- mkRequest "?name=bob" []+ liftIO $ decode' (simpleBody response1) `shouldBe` Just alice+ { name = "bob"+ } it "allows retrieving lists in GET parameters" $- (flip runSession) (serve queryParamApi qpServer) $ do- let params2 = "?names[]=bob&names[]=john"- response2 <- Network.Wai.Test.request defaultRequest{- rawQueryString = params2,- queryString = parseQuery params2,- pathInfo = ["a"]- }- liftIO $- decode' (simpleBody response2) `shouldBe` Just alice{- name = "john"- }+ flip runSession (serve queryParamApi qpServer) $ do+ response2 <- mkRequest "?names[]=bob&names[]=john" ["a"]+ liftIO $ decode' (simpleBody response2) `shouldBe` Just alice+ { name = "john"+ } + it "parses a query parameter" $+ flip runSession (serve queryParamApi qpServer) $ do+ response <- mkRequest "?age=55" ["param"]+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice+ { age = 55+ } + it "generates an error on query parameter parse failure" $+ flip runSession (serve queryParamApi qpServer) $ do+ response <- mkRequest "?age=foo" ["param"]+ liftIO $ statusCode (simpleStatus response) `shouldBe` 400+ return ()++ it "parses multiple query parameters" $+ flip runSession (serve queryParamApi qpServer) $ do+ response <- mkRequest "?ages=10&ages=22" ["multiparam"]+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice+ { age = 32+ }++ it "generates an error on parse failures of multiple parameters" $+ flip runSession (serve queryParamApi qpServer) $ do+ response <- mkRequest "?ages=2&ages=foo" ["multiparam"]+ liftIO $ statusCode (simpleStatus response) `shouldBe` 400+ return ()+ it "allows retrieving value-less GET parameters" $- (flip runSession) (serve queryParamApi qpServer) $ do- let params3 = "?capitalize"- response3 <- Network.Wai.Test.request defaultRequest{- rawQueryString = params3,- queryString = parseQuery params3,- pathInfo = ["b"]- }- liftIO $- decode' (simpleBody response3) `shouldBe` Just alice{- name = "ALICE"- }+ flip runSession (serve queryParamApi qpServer) $ do+ response3 <- mkRequest "?capitalize" ["b"]+ liftIO $ decode' (simpleBody response3) `shouldBe` Just alice+ { name = "ALICE"+ } - let params3' = "?capitalize="- response3' <- Network.Wai.Test.request defaultRequest{- rawQueryString = params3',- queryString = parseQuery params3',- pathInfo = ["b"]- }- liftIO $- decode' (simpleBody response3') `shouldBe` Just alice{- name = "ALICE"- }+ response3' <- mkRequest "?capitalize=" ["b"]+ liftIO $ decode' (simpleBody response3') `shouldBe` Just alice+ { name = "ALICE"+ } - let params3'' = "?unknown="- response3'' <- Network.Wai.Test.request defaultRequest{- rawQueryString = params3'',- queryString = parseQuery params3'',- pathInfo = ["b"]- }- liftIO $- decode' (simpleBody response3'') `shouldBe` Just alice{- name = "Alice"- }+ response3'' <- mkRequest "?unknown=" ["b"]+ liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice+ { 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 = rewrite <$> queryString req+ }+ where+ rewrite :: QueryItem -> QueryItem+ rewrite (k, v) = (fromMaybe k (BS.stripPrefix "person_" k), v)++ let app = queryRewriter $ serve queryParamApi qpServer++ it "allows rewriting for simple GET/query parameters" $+ flip runSession app $ do+ response1 <- mkRequest "?person_name=bob" []+ liftIO $ decode' (simpleBody response1) `shouldBe` Just alice+ { name = "bob"+ }++ it "allows rewriting for lists in GET parameters" $+ flip runSession app $ do+ response2 <- mkRequest "?person_names[]=bob&person_names[]=john" ["a"]+ liftIO $ decode' (simpleBody response2) `shouldBe` Just alice+ { name = "john"+ }++ it "allows rewriting when parsing multiple query parameters" $+ flip runSession app $ do+ response <- mkRequest "?person_ages=10&person_ages=22" ["multiparam"]+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice+ { age = 32+ }++ it "allows retrieving value-less GET parameters" $+ flip runSession app $ do+ response3 <- mkRequest "?person_capitalize" ["b"]+ liftIO $ decode' (simpleBody response3) `shouldBe` Just alice+ { name = "ALICE"+ }++ response3' <- mkRequest "?person_capitalize=" ["b"]+ liftIO $ decode' (simpleBody response3') `shouldBe` Just alice+ { name = "ALICE"+ }++ response3'' <- mkRequest "?person_unknown=" ["b"]+ liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice+ { name = "Alice"+ }+ -- }}} ------------------------------------------------------------------------------+-- * fragmentSpec {{{+------------------------------------------------------------------------------++type FragmentApi = "name" :> Fragment String :> Get '[JSON] Person+ :<|> "age" :> Fragment Integer :> Get '[JSON] Person++fragmentApi :: Proxy FragmentApi+fragmentApi = Proxy++fragServer :: Server FragmentApi+fragServer = fragmentServer :<|> fragAge+ where+ fragmentServer = return alice+ fragAge = return alice++fragmentSpec :: Spec+fragmentSpec = do+ let mkRequest params pinfo = Network.Wai.Test.request defaultRequest+ { rawQueryString = params+ , queryString = parseQuery params+ , pathInfo = pinfo+ }++ 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++-- }}}+------------------------------------------------------------------------------ -- * reqBodySpec {{{ ------------------------------------------------------------------------------ type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person@@ -380,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 -- }}} ------------------------------------------------------------------------------@@ -393,8 +609,8 @@ ------------------------------------------------------------------------------ type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] NoContent-headerApi :: Proxy (HeaderApi a)-headerApi = Proxy+headerApi :: Proxy a -> Proxy (HeaderApi a)+headerApi _ = Proxy headerSpec :: Spec headerSpec = describe "Servant.API.Header" $ do@@ -411,18 +627,25 @@ return NoContent expectsString Nothing = error "Expected a string" - with (return (serve headerApi expectsInt)) $ do+ with (return (serve (headerApi (Proxy :: Proxy Int)) expectsInt)) $ do let delete' x = THW.request methodDelete x [("MyHeader", "5")] it "passes the header to the handler (Int)" $ delete' "/" "" `shouldRespondWith` 200 - with (return (serve headerApi expectsString)) $ do+ with (return (serve (headerApi (Proxy :: Proxy String)) expectsString)) $ do let delete' x = THW.request methodDelete x [("MyHeader", "more from you")] it "passes the header to the handler (String)" $ delete' "/" "" `shouldRespondWith` 200 + with (return (serve (headerApi (Proxy :: Proxy Int)) expectsInt)) $ do+ let delete' x = THW.request methodDelete x [("MyHeader", "not a number")]++ it "checks for parse errors" $+ delete' "/" "" `shouldRespondWith` 400++ -- }}} ------------------------------------------------------------------------------ -- * rawSpec {{{@@ -433,31 +656,60 @@ 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_ sendResponse ->+ sendResponse $ responseLBS ok200 []+ (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]) -- }}} ------------------------------------------------------------------------------+-- * rawMSpec {{{+------------------------------------------------------------------------------++type RawMApi = "foo" :> RawM++rawMApi :: Proxy RawMApi+rawMApi = Proxy++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 = 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" $ 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" $ 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 {{{ ------------------------------------------------------------------------------ type AlternativeApi =@@ -481,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 {{{@@ -517,36 +763,58 @@ 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 -- }}} ------------------------------------------------------------------------------+-- * uverbResponseHeaderSpec {{{+------------------------------------------------------------------------------+type UVerbHeaderResponse = '[+ WithStatus 200 (Headers '[Header "H1" Int] String),+ WithStatus 404 String ]++type UVerbResponseHeadersApi =+ Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse++uverbResponseHeadersServer :: Server UVerbResponseHeadersApi+uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String)+uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String)++uverbResponseHeadersSpec :: Spec+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+ }++-- }}}+------------------------------------------------------------------------------ -- * miscCombinatorSpec {{{ ------------------------------------------------------------------------------ type MiscCombinatorsAPI = "version" :> HttpVersion :> Get '[JSON] String :<|> "secure" :> IsSecure :> Get '[JSON] String :<|> "host" :> RemoteHost :> Get '[JSON] String+ :<|> "empty" :> EmptyAPI miscApi :: Proxy MiscCombinatorsAPI miscApi = Proxy@@ -555,6 +823,7 @@ miscServ = versionHandler :<|> secureHandler :<|> hostHandler+ :<|> emptyServer where versionHandler = return . show secureHandler Secure = return "secure"@@ -573,6 +842,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 -- }}}@@ -590,7 +862,7 @@ basicAuthServer :: Server BasicAuthAPI basicAuthServer = const (return jerry) :<|>- (\ _ respond -> respond $ responseLBS imATeaPot418 [] "")+ Tagged (\ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext =@@ -601,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 -- }}} ------------------------------------------------------------------------------@@ -635,7 +903,7 @@ genAuthServer :: Server GenAuthAPI genAuthServer = const (return tweety)- :<|> (\ _ respond -> respond $ responseLBS imATeaPot418 [] "")+ :<|> Tagged (\ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") type instance AuthServerData (AuthProtect "auth") = () @@ -643,28 +911,91 @@ genAuthContext = let authHandler = \req -> case lookup "Auth" (requestHeaders req) of Just "secret" -> return ()- Just _ -> throwE err403- Nothing -> throwE err401+ Just _ -> throwError err403+ Nothing -> throwError err401 in mkAuthHandler authHandler :. EmptyContext genAuthSpec :: Spec-genAuthSpec = do- describe "Servant.API.Auth" $ do- with (return (serveWithContext genAuthApi genAuthContext genAuthServer)) $ do+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 - 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+-- }}}+------------------------------------------------------------------------------+-- * UVerb {{{+------------------------------------------------------------------------------ +newtype PersonResponse = PersonResponse Person+ deriving Generic+instance ToJSON PersonResponse+instance HasStatus PersonResponse where+ type StatusOf PersonResponse = 200++newtype RedirectResponse = RedirectResponse String+ deriving Generic+instance ToJSON RedirectResponse+instance HasStatus RedirectResponse where+ type StatusOf RedirectResponse = 301++newtype AnimalResponse = AnimalResponse Animal+ deriving Generic+instance ToJSON AnimalResponse+instance HasStatus AnimalResponse where+ type StatusOf AnimalResponse = 203+++type UVerbApi+ = "person" :> Capture "shouldRedirect" Bool :> UVerb 'GET '[JSON] '[PersonResponse, RedirectResponse]+ :<|> "animal" :> UVerb 'GET '[JSON] '[AnimalResponse]++uverbSpec :: Spec+uverbSpec = describe "Servant.API.UVerb " $ do+ let+ joe = Person "joe" 42+ mouse = Animal "Mouse" 7++ personHandler+ :: Bool+ -> Handler (Union '[PersonResponse+ ,RedirectResponse])+ personHandler True = respond $ RedirectResponse "over there!"+ personHandler False = respond $ PersonResponse joe++ animalHandler = respond $ AnimalResponse mouse++ server :: Server UVerbApi+ server = personHandler :<|> animalHandler++ with (pure $ serve (Proxy :: Proxy UVerbApi) server) $ do+ context "A route returning either 301/String or 200/Person" $ do+ context "when requesting the person" $ do+ let theRequest = THW.get "/person/false"+ it "returns status 200" $+ theRequest `shouldRespondWith` 200+ it "returns a person" $ do+ response <- theRequest+ liftIO $ decode' (simpleBody response) `shouldBe` Just joe+ context "requesting the redirect" $+ it "returns a message and status 301" $+ THW.get "/person/true"+ `shouldRespondWith` "\"over there!\"" {matchStatus = 301}+ context "a route with a single response type" $ do+ let theRequest = THW.get "/animal"+ it "should return the defined status code" $+ theRequest `shouldRespondWith` 203+ it "should return the expected response" $ do+ response <- theRequest+ liftIO $ decode' (simpleBody response) `shouldBe` Just mouse+ -- }}} ------------------------------------------------------------------------------ -- * Test data types {{{@@ -696,6 +1027,10 @@ tweety :: Animal tweety = Animal "Bird" 2++-- weird animal with non-integer amount of ears+chimera :: Animal+chimera = Animal "Chimera" (-1) beholder :: Animal beholder = Animal "Beholder" 0
− test/Servant/Utils/StaticFilesSpec.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Servant.Utils.StaticFilesSpec where--import Control.Exception (bracket)-import Data.Proxy (Proxy (Proxy))-import Network.Wai (Application)-import System.Directory (createDirectory,- getCurrentDirectory,- setCurrentDirectory)-import System.IO.Temp (withSystemTempDirectory)-import Test.Hspec (Spec, around_, describe, it)-import Test.Hspec.Wai (get, shouldRespondWith, with)--import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)-import Servant.Server (Server, serve)-import Servant.ServerSpec (Person (Person))-import Servant.Utils.StaticFiles (serveDirectory)--type Api =- "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person- :<|> "static" :> Raw---api :: Proxy Api-api = Proxy--app :: Application-app = serve api server--server :: Server Api-server =- (\ name_ -> return (Person name_ 42))- :<|> serveDirectory "static"--withStaticFiles :: IO () -> IO ()-withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->- bracket (setup tmpDir) teardown (const action)- where- setup tmpDir = do- outer <- getCurrentDirectory- setCurrentDirectory tmpDir- createDirectory "static"- writeFile "static/foo.txt" "bar"- writeFile "static/index.html" "index"- return outer-- teardown outer = do- setCurrentDirectory outer--spec :: Spec-spec = do- around_ withStaticFiles $ with (return app) $ do- describe "serveDirectory" $ do- it "successfully serves files" $ do- get "/static/foo.txt" `shouldRespondWith` "bar"-- it "serves the contents of index.html when requesting the root of a directory" $ do- get "/static/" `shouldRespondWith` "index"