servant-server 0.14.1 → 0.20.3.0
raw patch · 39 files changed
Files
- CHANGELOG.md +254/−0
- LICENSE +1/−1
- README.md +1/−1
- Setup.hs +2/−0
- Setup.lhs +0/−31
- example/greet.hs +19/−3
- include/overlapping-compat.h +0/−8
- servant-server.cabal +140/−120
- src/Servant.hs +5/−4
- src/Servant/Server.hs +76/−16
- src/Servant/Server/Experimental/Auth.hs +31/−26
- src/Servant/Server/Generic.hs +61/−19
- src/Servant/Server/Internal.hs +593/−214
- src/Servant/Server/Internal/BasicAuth.hs +23/−16
- src/Servant/Server/Internal/Context.hs +27/−18
- 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 +37/−19
- src/Servant/Server/Internal/ResponseRender.hs +184/−0
- src/Servant/Server/Internal/RouteResult.hs +76/−0
- src/Servant/Server/Internal/Router.hs +95/−44
- src/Servant/Server/Internal/RoutingApplication.hs +6/−378
- src/Servant/Server/Internal/ServantErr.hs +0/−472
- src/Servant/Server/Internal/ServerError.hs +491/−0
- src/Servant/Server/StaticFiles.hs +1/−10
- src/Servant/Server/UVerb.hs +116/−0
- src/Servant/Utils/StaticFiles.hs +1/−1
- test/Servant/ArbitraryMonadServerSpec.hs +4/−3
- test/Servant/HoistSpec.hs +4/−3
- test/Servant/Server/ErrorSpec.hs +68/−10
- test/Servant/Server/Internal/ContextSpec.hs +7/−4
- test/Servant/Server/Internal/RoutingApplicationSpec.hs +28/−22
- test/Servant/Server/RouterSpec.hs +179/−26
- test/Servant/Server/StreamingSpec.hs +10/−9
- test/Servant/Server/UsingContextSpec.hs +4/−3
- test/Servant/Server/UsingContextSpec/TestCombinators.hs +13/−12
- test/Servant/ServerSpec.hs +516/−266
- test/doctests.hs +0/−25
CHANGELOG.md view
@@ -1,6 +1,260 @@ [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 ------
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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,31 +0,0 @@-\begin{code}-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wall #-}-module Main (main) where--#ifndef MIN_VERSION_cabal_doctest-#define MIN_VERSION_cabal_doctest(x,y,z) 0-#endif--#if MIN_VERSION_cabal_doctest(1,0,0)--import Distribution.Extra.Doctest ( defaultMainWithDoctests )-main :: IO ()-main = defaultMainWithDoctests "doctests"--#else--#ifdef MIN_VERSION_Cabal-#warning You are configuring this package without cabal-doctest installed. \- The doctests test-suite will not work as a result. \- To fix this, install cabal-doctest before configuring.-#endif--import Distribution.Simple--main :: IO ()-main = defaultMain--#endif--\end{code}
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,48 +1,94 @@-name: servant-server-version: 0.14.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: Servant, Web-build-type: Custom-cabal-version: >=1.10-tested-with:- GHC==7.8.4- GHC==7.10.3- GHC==8.0.2- GHC==8.2.2- GHC==8.4.3++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 source-repository head- type: git+ type: git location: http://github.com/haskell-servant/servant.git -custom-setup- setup-depends:- base >= 4 && <5,- Cabal,- cabal-doctest >= 1.0.6 && <1.1+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@@ -51,103 +97,96 @@ 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.Server.Internal.ServerError Servant.Server.StaticFiles+ Servant.Server.UVerb -- deprecated- exposed-modules:- Servant.Utils.StaticFiles+ exposed-modules: Servant.Utils.StaticFiles -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4- --- -- note: mtl lower bound is so low because of GHC-7.8 build-depends:- base >= 4.7 && < 4.12- , bytestring >= 0.10.4.0 && < 0.11- , containers >= 0.5.5.1 && < 0.6- , mtl >= 2.1 && < 2.3- , text >= 1.2.3.0 && < 1.3- , transformers >= 0.3.0.0 && < 0.6- , filepath >= 1.3.0.2 && < 1.5-- if !impl(ghc >= 8.0)- build-depends:- semigroups >= 0.18.4 && < 0.19+ , 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 -- Servant dependencies+ -- strict dependency as we re-export 'servant' things. build-depends:- servant >= 0.14.1 && <0.15+ , http-api-data >=0.4.1 && <0.7+ , servant >=0.20.2 && <0.21 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends:- base-compat >= 0.10.1 && < 0.11- , base64-bytestring >= 1.0.0.1 && < 1.1- , exceptions >= 0.10.0 && < 0.11- , http-api-data >= 0.3.8.1 && < 0.4- , http-media >= 0.7.1.2 && < 0.8- , http-types >= 0.12.1 && < 0.13- , network-uri >= 2.6.1.0 && < 2.7- , monad-control >= 1.0.2.3 && < 1.1- , network >= 2.6.3.5 && < 2.8- , string-conversions >= 0.4.0.1 && < 0.5- , resourcet >= 1.1.11 && < 1.3- , tagged >= 0.8.5 && < 0.9- , transformers-base >= 0.4.4 && < 0.5- , transformers-compat >= 0.6.2 && < 0.7- , wai >= 3.2.1.1 && < 3.3- , wai-app-static >= 3.1.6.1 && < 3.2- , word8 >= 0.1.3 && < 0.2+ , 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- default-language: Haskell2010- ghc-options: -Wall- if impl(ghc >= 8.0)- ghc-options: -Wno-redundant-constraints- include-dirs: include+ 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- , wai , text+ , wai build-depends:- aeson >= 1.3.1.1 && < 1.5- , warp >= 3.2.13 && < 3.3+ , aeson >=1.4.1.0 && <3+ , warp >=3.2.25 && <3.5 test-suite spec- type: exitcode-stdio-1.0- ghc-options: -Wall- default-language: Haskell2010- hs-source-dirs: test- main-is: Spec.hs+ import: extensions+ import: ghc-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs other-modules:- Servant.ArbitraryMonadServerSpec- Servant.Server.ErrorSpec- Servant.Server.Internal.ContextSpec- Servant.Server.Internal.RoutingApplicationSpec- Servant.Server.RouterSpec- Servant.Server.StaticFilesSpec- Servant.Server.StreamingSpec- Servant.Server.UsingContextSpec- Servant.Server.UsingContextSpec.TestCombinators- Servant.HoistSpec- Servant.ServerSpec+ Servant.ArbitraryMonadServerSpec+ Servant.HoistSpec+ Servant.Server.ErrorSpec+ Servant.Server.Internal.ContextSpec+ Servant.Server.Internal.RoutingApplicationSpec+ Servant.Server.RouterSpec+ Servant.Server.StaticFilesSpec+ Servant.Server.StreamingSpec+ Servant.Server.UsingContextSpec+ Servant.Server.UsingContextSpec.TestCombinators+ Servant.ServerSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends:- base+ , base , base-compat , base64-bytestring , bytestring@@ -157,36 +196,17 @@ , safe , servant , servant-server- , string-conversions , text- , transformers- , transformers-compat , wai - -- Additonal dependencies+ -- Additional dependencies build-depends:- aeson >= 1.3.1.1 && < 1.5- , directory >= 1.2.1.0 && < 1.4- , hspec >= 2.5.1 && < 2.6- , hspec-wai >= 0.9.0 && < 0.10- , QuickCheck >= 2.11.3 && < 2.12- , should-not-typecheck >= 2.1.0 && < 2.2- , temporary >= 1.3 && < 1.4- , wai-extra >= 3.0.21.0 && < 3.1-- build-tool-depends:- hspec-discover:hspec-discover >= 2.5.1 && <2.6+ , 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 -test-suite doctests- build-depends:- base- , servant-server- , doctest >= 0.15.0 && <0.17- type: exitcode-stdio-1.0- main-is: test/doctests.hs- buildable: True- default-language: Haskell2010- ghc-options: -Wall -threaded- if impl(ghc >= 8.2)- x-doctest-options: -fdiagnostics-color=never- include-dirs: include+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12
src/Servant.hs view
@@ -7,15 +7,16 @@ module Servant.Server, -- | Utilities on top of the servant core module Servant.Links,- module Servant.Utils.StaticFiles,+ 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.Server import Servant.Links-import Servant.Utils.StaticFiles+import Servant.Server+import Servant.Server.StaticFiles
src/Servant/Server.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# 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@@ -21,6 +26,7 @@ , emptyServer , Handler (..) , runHandler+ , pattern MkHandler -- * Debugging the server layout , layout@@ -35,6 +41,8 @@ -- * Context , Context(..) , HasContextEntry(getContextEntry)+ , type (.++)+ , (.++) -- ** NamedContext , NamedContext(..) , descendIntoNamedContext@@ -49,7 +57,7 @@ -- , mkAuthHandler -- * Default error type- , ServantErr(..)+ , ServerError(..) -- ** 3XX , err300 , err301@@ -78,6 +86,7 @@ , err417 , err418 , err422+ , err429 -- ** 5XX , err500 , err501@@ -86,27 +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.Tagged (Tagged (..))-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.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@@ -125,11 +167,28 @@ 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@@ -179,7 +238,7 @@ -- > │ └─ e/ -- > │ └─• -- > ├─ b/--- > │ └─ <capture>/+-- > │ └─ <x::Int>/ -- > │ ├─• -- > │ ┆ -- > │ └─•@@ -196,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. --
src/Servant/Server/Experimental/Auth.hs view
@@ -1,33 +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 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 (..),- getContextEntry)-import Servant.Server.Internal.RoutingApplication (addAuthCheck,- delayedFailFatal,- DelayedIO,- withRequest)-import Servant.Server.Internal.Handler (Handler, runHandler)+import Servant.Server.Internal+ (DelayedIO, Handler, HasContextEntry, HasServer (..),+ addAuthCheck, delayedFailFatal, getContextEntry, runHandler,+ withRequest) -- * General Auth @@ -35,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
src/Servant/Server/Generic.hs view
@@ -1,34 +1,31 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# 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,+ genericServerT ) where +import Data.Kind+ (Type) import Data.Proxy (Proxy (..)) -import Servant.API.Generic import Servant.Server---- | A type that specifies that an API record contains a server implementation.-data AsServerT (m :: * -> *)-instance GenericMode (AsServerT m) where- type AsServerT m :- api = ServerT api m--type AsServer = AsServerT Handler+import Servant.API.Generic+import Servant.Server.Internal --- | Transform record of routes into a WAI 'Application'.+-- | Transform a record of routes into a WAI 'Application'. genericServe :: forall routes. ( HasServer (ToServantApi routes) '[]@@ -38,15 +35,60 @@ => routes AsServer -> Application genericServe = serve (Proxy :: Proxy (ToServantApi routes)) . genericServer --- | Transform record of endpoints into a 'Server'.+-- | 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,109 +1,103 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802-#define HAS_TYPE_ERROR-#endif--#ifdef HAS_TYPE_ERROR-{-# LANGUAGE UndecidableInstances #-}-#endif--#include "overlapping-compat.h"+{-# 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.ServantErr+ , module Servant.Server.Internal.ServerError ) where -import Control.Monad (join, when)-import Control.Monad.Trans (liftIO)-import Control.Monad.Trans.Resource (runResourceT)-import qualified Data.ByteString as B-import qualified Data.ByteString.Builder as BB-import qualified Data.ByteString.Char8 as BC8-import qualified Data.ByteString.Lazy as BL-import Data.Maybe (fromMaybe, mapMaybe,- isNothing, maybeToList)-import Data.Either (partitionEithers)-import Data.Semigroup ((<>))-import Data.String (IsString (..))-import Data.String.Conversions (cs)-import Data.Tagged (Tagged(..), retag, untag)-import qualified Data.Text as T+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.TypeLits (KnownNat, KnownSymbol, natVal,- symbolVal)-import Network.HTTP.Types hiding (Header, ResponseHeaders)-import qualified Network.HTTP.Media as NHM-import Network.Socket (SockAddr)-import Network.Wai (Application, Request,- httpVersion, isSecure,- lazyRequestBody,- rawQueryString, remoteHost,- requestHeaders, requestMethod,- responseLBS, responseStream,- vault)-import Prelude ()-import Prelude.Compat-import Web.HttpApiData (FromHttpApiData, parseHeader,- parseQueryParam,- parseUrlPieceMaybe,- parseUrlPieces)-import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture',- CaptureAll, Verb, EmptyAPI,- ReflectMethod(reflectMethod),- IsSecure(..), Header', QueryFlag,- QueryParam', QueryParams, Raw,- RemoteHost, ReqBody', Vault,- WithNamedContext,- Description, Summary,- Accept(..),- FramingRender(..), Stream,- StreamGenerator(..), ToStreamGenerator(..),- BoundaryStrategy(..),- If, SBool (..), SBoolI (..))-import Servant.API.Modifiers (unfoldRequestArgument, RequestArgument, FoldRequired, FoldLenient)-import Servant.API.ContentTypes (AcceptHeader (..),- AllCTRender (..),- AllCTUnrender (..),- AllMime,- MimeRender(..),- canHandleAcceptH)-import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,- getResponse)+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.Context 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.ServantErr--#ifdef HAS_TYPE_ERROR-import GHC.TypeLits (TypeError, ErrorMessage (..))-#endif+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- type ServerT api (m :: * -> *) :: *+ -- | 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@@ -164,22 +158,31 @@ -- > server = getBook -- > where getBook :: Text -> Handler Book -- > getBook isbn = ...-instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)+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 =- a -> ServerT 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 $+ CaptureRouter [hint] $ route (Proxy :: Proxy api) context- (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of- Nothing -> delayedFail err400- Just v -> return v- )+ (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@@ -198,7 +201,10 @@ -- > server = getSourceFile -- > where getSourceFile :: [Text] -> Handler Book -- > getSourceFile pathSegments = ...-instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)+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 =@@ -207,15 +213,55 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context d =- CaptureAllRouter $+ CaptureAllRouter [hint] $ route (Proxy :: Proxy api) context- (addCapture d $ \ txts -> case parseUrlPieces txts of- Left _ -> delayedFail err400- Right v -> return v+ (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 @@ -234,10 +280,10 @@ -- 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 :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO () acceptCheck proxy accH- | canHandleAcceptH proxy (AcceptHeader accH) = return ()- | otherwise = delayedFail err406+ | canHandleAcceptH proxy accH = return ()+ | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a) => (b -> ([(HeaderName, B.ByteString)], a))@@ -247,18 +293,29 @@ methodRouter splitHeaders method proxy status action = leafRouter route' where route' env request respond =- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ 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 (AcceptHeader accH) b of+ 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, cs contentT) : headers) bdy+ in Route $ responseLBS status ((hContentType, BSL.toStrict contentT) : headers) bdy -instance OVERLAPPABLE_+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 @@ -267,9 +324,9 @@ route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method)- status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)+ status = statusFromNat (Proxy :: Proxy status) -instance OVERLAPPING_+instance {-# OVERLAPPING #-} ( AllCTRender ctypes a, ReflectMethod method, KnownNat status , GetHeaders (Headers h a) ) => HasServer (Verb method status ctypes (Headers h a)) context where@@ -279,37 +336,46 @@ route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method)- status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)+ status = statusFromNat (Proxy :: Proxy status) +instance (ReflectMethod method) =>+ HasServer (NoContentVerb method) context where -instance OVERLAPPABLE_- ( MimeRender ctype a, ReflectMethod method, KnownNat status,- FramingRender framing ctype, ToStreamGenerator b a- ) => HasServer (Stream method status framing ctype b) context where+ type ServerT (NoContentVerb method) m = m NoContent+ hoistServerWithContext _ _ nt s = nt s - type ServerT (Stream method status framing ctype b) m = m b+ 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 = toEnum . fromInteger $ natVal (Proxy :: Proxy status)+ status = statusFromNat (Proxy :: Proxy status) -instance OVERLAPPING_- ( MimeRender ctype a, ReflectMethod method, KnownNat status,- FramingRender framing ctype, ToStreamGenerator b a,- GetHeaders (Headers h b)- ) => HasServer (Stream method status framing ctype (Headers h b)) context where - type ServerT (Stream method status framing ctype (Headers h b)) m = m (Headers h b)+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 = toEnum . fromInteger $ natVal (Proxy :: Proxy status)+ status = statusFromNat (Proxy :: Proxy status) -streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator b a) =>- (c -> ([(HeaderName, B.ByteString)], b))+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@@ -317,7 +383,7 @@ -> Delayed env (Handler c) -> Router env streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ let AcceptHeader accH = getAcceptHeader request cmediatype = NHM.matchAccept [contentType ctypeproxy] accH accCheck = when (isNothing cmediatype) $ delayedFail err406 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)@@ -325,29 +391,20 @@ `addAcceptCheck` accCheck ) env request respond $ \ output -> let (headers, fa) = splitHeaders output- k = getStreamGenerator . toStreamGenerator $ fa in- Route $ responseStream status (contentHeader : headers) $ \write flush -> do- write . BB.lazyByteString $ header framingproxy ctypeproxy- case boundary framingproxy ctypeproxy of- BoundaryStrategyBracket f ->- let go x = let bs = mimeRender ctypeproxy x- (before, after) = f bs- in write ( BB.lazyByteString before- <> BB.lazyByteString bs- <> BB.lazyByteString after) >> flush- in k go go- BoundaryStrategyIntersperse sep -> k- (\x -> do- write . BB.lazyByteString . mimeRender ctypeproxy $ x- flush)- (\x -> do- write . (BB.lazyByteString sep <>) . BB.lazyByteString . mimeRender ctypeproxy $ x- flush)- BoundaryStrategyGeneral f ->- let go = (>> flush) . write . BB.lazyByteString . f . mimeRender ctypeproxy- in k go go- write . BB.lazyByteString $ trailer framingproxy ctypeproxy+ 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'.@@ -371,6 +428,7 @@ 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 ------@@ -382,6 +440,9 @@ 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) @@ -392,16 +453,38 @@ mev :: Maybe (Either T.Text a) mev = fmap parseHeader $ lookup headerName (requestHeaders req) - errReq = delayedFailFatal err400- { errBody = "Header " <> headerName <> " is required"- }+ errReq = delayedFailFatal $ formatError rep req+ $ "Header " <> headerName <> " is required" - errSt e = delayedFailFatal err400- { errBody = cs $ "Error parsing header "- <> headerName- <> " failed: " <> e- }+ 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'@.@@ -426,6 +509,7 @@ 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 ------@@ -435,9 +519,12 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver =- let querytext req = parseQueryText $ rawQueryString req- paramname = cs $ symbolVal (Proxy :: Proxy sym)+ 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@@ -445,14 +532,12 @@ mev :: Maybe (Either T.Text a) mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req - errReq = delayedFailFatal err400- { errBody = cs $ "Query parameter " <> paramname <> " is required"- }+ errReq = delayedFailFatal $ formatError rep req+ $ T.unpack $ "Query parameter " <> paramname <> " is required" - errSt e = delayedFailFatal err400- { errBody = cs $ "Error parsing query parameter "- <> paramname <> " failed: " <> e- }+ errSt e = delayedFailFatal $ formatError rep req+ $ T.unpack $ "Error parsing query parameter "+ <> paramname <> " failed: " <> e delayed = addParameterCheck subserver . withRequest $ \req -> parseParam req@@ -478,7 +563,8 @@ -- > server = getBooksBy -- > where getBooksBy :: [Text] -> Handler [Book] -- > getBooksBy authors = ...return all books by these authors...-instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)+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 =@@ -489,21 +575,23 @@ route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addParameterCheck` withRequest paramsCheck where- paramname = cs $ symbolVal (Proxy :: Proxy sym)+ 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 err400- { errBody = cs $ "Error parsing query parameter(s) "- <> paramname <> " failed: "- <> T.intercalate ", " errs- }+ (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)- . parseQueryText- . rawQueryString+ . queryToQueryText+ . queryString $ req looksLikeParam name = name == paramname || name == (paramname <> "[]")@@ -529,16 +617,115 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver =- let querytext r = parseQueryText $ rawQueryString r+ 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 = cs $ symbolVal (Proxy :: Proxy sym)+ where paramname = T.pack $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False +-- | If you use @'QueryString'@ in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of type @Query@ (@[('ByteString', 'Maybe' 'ByteString')]@).+--+-- This lets you extract the whole query string. This is useful when the query string+-- can contain parameters with dynamic names, that you can't access with @'QueryParam'@.+--+-- Example:+--+-- > type MyApi = "books" :> QueryString :> Get '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooksBy+-- > where getBooksBy :: Query -> Handler [Book]+-- > getBooksBy filters = ...filter books based on the dynamic filters provided...+instance+ ( HasServer api context+ )+ => HasServer (QueryString :> api) context where+------+ type ServerT (QueryString :> api) m =+ Query -> ServerT api m++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++ route Proxy context subserver =+ route (Proxy :: Proxy api) context (passToServer subserver queryString)++-- | If you use @'DeepQuery' "symbol" a@ in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of type @a@.+--+-- This lets you extract an object from multiple parameters in the query string,+-- with its fields enclosed in brackets: `/books?filter[author][name]=value`. When+-- all the fields are known in advance, it can be done with @'QueryParam'@ (it can+-- still be tedious if you the object has many fields). When some fields are dynamic,+-- it cannot be done with @'QueryParam'.+--+-- The way the object is constructed from the extracted fields can be controlled by+-- providing an instance on @'FromDeepQuery'@+--+-- Example:+--+-- > type MyApi = "books" :> DeepQuery "filter" BookQuery :> Get '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooksBy+-- > where getBooksBy :: BookQuery -> Handler [Book]+-- > getBooksBy query = ...filter books based on the dynamic filters provided...+instance+ ( KnownSymbol sym, FromDeepQuery a, HasServer api context+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters+ )+ => HasServer (DeepQuery sym a :> api) context where+------+ type ServerT (DeepQuery sym a :> api) m =+ a -> ServerT api m++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s++ route Proxy context subserver = route (Proxy :: Proxy api) context $+ subserver `addParameterCheck` withRequest paramsCheck+ where+ rep = typeRep (Proxy :: Proxy DeepQuery)+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)++ paramname = T.pack $ symbolVal (Proxy :: Proxy sym)+ paramsCheck req =+ let relevantParams :: [(T.Text, Maybe T.Text)]+ relevantParams = mapMaybe isRelevantParam+ . queryToQueryText+ . queryString+ $ req+ isRelevantParam (name, value) = (, value) <$>+ case T.stripPrefix paramname name of+ Just "" -> Just ""+ Just x | "[" `T.isPrefixOf` x -> Just x+ _ -> Nothing+ in case fromDeepQuery =<< traverse parseDeepParam relevantParams of+ Left e -> delayedFailFatal $ formatError rep req+ $ T.unpack $ "Error parsing deep query parameter(s) "+ <> paramname <> T.pack " failed: "+ <> T.pack e+ Right parsed -> return parsed++parseDeepParam :: (T.Text, Maybe T.Text) -> Either String ([T.Text], Maybe T.Text)+parseDeepParam (paramname, value) =+ let parseParam "" = return []+ parseParam n = reverse <$> go [] n+ go parsed remaining = case T.take 1 remaining of+ "[" -> case T.breakOn "]" remaining of+ (_ , "") -> Left $ "Error parsing deep param, missing closing ']': " <> T.unpack remaining+ (name, "]") -> return $ T.drop 1 name : parsed+ (name, remaining') -> case T.take 2 remaining' of+ "][" -> go (T.drop 1 name : parsed) (T.drop 1 remaining')+ _ -> Left $ "Error parsing deep param, incorrect brackets: " <> T.unpack remaining+ _ -> Left $ "Error parsing deep param, missing opening '[': " <> T.unpack remaining+ in (, value) <$> parseParam paramname+ -- | Just pass the request to the underlying application and serve its response. -- -- Example:@@ -565,13 +752,42 @@ 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--- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.+-- [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. --@@ -587,6 +803,7 @@ -- > 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 =@@ -598,6 +815,9 @@ = 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@@ -606,7 +826,7 @@ -- http://www.w3.org/2001/tag/2002/0129-mime let contentTypeH = fromMaybe "application/octet-stream" $ lookup hContentType $ requestHeaders request- case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of+ case canHandleCTypeH (Proxy :: Proxy list) (BSL.fromStrict contentTypeH) :: Maybe (BSL.ByteString -> Either String a) of Nothing -> delayedFail err415 Just f -> return f @@ -616,9 +836,33 @@ case sbool :: SBool (FoldLenient mods) of STrue -> return mrqbody SFalse -> case mrqbody of- Left e -> delayedFailFatal err400 { errBody = cs e }+ 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@@ -627,7 +871,7 @@ route Proxy context subserver = pathRouter- (cs (symbolVal proxyPath))+ (T.pack (symbolVal proxyPath)) (route (Proxy :: Proxy api) context subserver) where proxyPath = Proxy :: Proxy path hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s@@ -683,12 +927,12 @@ emptyServer :: ServerT EmptyAPI m emptyServer = Tagged EmptyServer --- | The server for an `EmptyAPI` is `emptyAPIServer`.+-- | The server for an `EmptyAPI` is `emptyServer`. -- -- > type MyApi = "nothing" :> EmptyApi -- > -- > server :: Server MyApi--- > server = emptyAPIServer+-- > server = emptyServer instance HasServer EmptyAPI context where type ServerT EmptyAPI m = Tagged m EmptyServer @@ -696,6 +940,13 @@ hoistServerWithContext _ _ _ = retag +-- | Ignore @'EmptyAPI'@ as part of route in server handlers.+instance HasServer api context => HasServer (EmptyAPI :> api) context where+ type ServerT (EmptyAPI :> api) m = ServerT api m++ route _ = route (Proxy :: Proxy api)+ hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)+ -- | Basic Authentication instance ( KnownSymbol realm , HasServer api context@@ -717,8 +968,11 @@ -- * helpers ct_wildcard :: B.ByteString-ct_wildcard = "*" <> "/" <> "*" -- Because CPP+ct_wildcard = "*" <> "/" <> "*" +getAcceptHeader :: Request -> AcceptHeader+getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders+ -- * General Authentication @@ -742,40 +996,20 @@ hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s ---------------------------------------------------------------------------------- TypeError helpers+-- Custom type errors ------------------------------------------------------------------------------- -#ifdef HAS_TYPE_ERROR--- | This instance catches mistakes when there are non-saturated--- type applications on LHS of ':>'.------ >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")--- ...--- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.--- ...Maybe you haven't applied enough arguments to--- ...Capture' '[] "foo"--- ...------ >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)--- ...--- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.--- ...Maybe you haven't applied enough arguments to--- ...Capture' '[] "foo"--- ...--- -instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context- where- type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)- -- it doens't really matter what sub route we peak- route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"- hoistServerWithContext _ _ _ = id+-- Erroring instance for 'HasServer' when a combinator is not fully applied+instance TypeError (PartialApplication --- Cannot have TypeError here, otherwise use of this symbol will error :)-type HasServerArrowKindError arr =- 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."- ':$$: 'Text "Maybe you haven't applied enough arguments to"- ':$$: 'ShowType arr+ @(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 "...")@@ -808,7 +1042,152 @@ ':$$: 'ShowType a ':$$: 'Text "and" ':$$: 'ShowType b-#endif +-- 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,19 +1,23 @@-{-# 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@@ -23,7 +27,7 @@ -- -- 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
@@ -1,34 +1,45 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PatternSynonyms #-} module Servant.Server.Internal.Handler where -import Prelude ()-import Prelude.Compat--import Control.Monad.Base (MonadBase (..))-import Control.Monad.Catch (MonadCatch, MonadThrow)-import Control.Monad.Error.Class (MonadError)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Trans.Control (MonadBaseControl (..))-import Control.Monad.Trans.Except (ExceptT, runExceptT)-import GHC.Generics (Generic)-import Servant.Server.Internal.ServantErr (ServantErr)+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 ServantErr IO a }- deriving- ( Functor, Applicative, Monad, MonadIO, Generic- , MonadError ServantErr- , MonadThrow, MonadCatch+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 ServantErr a+ type StM Handler a = Either ServerError a -- liftBaseWith :: (RunInBase Handler IO -> IO a) -> Handler a liftBaseWith f = Handler (liftBaseWith (\g -> f (g . runHandler')))@@ -36,5 +47,12 @@ -- restoreM :: StM Handler a -> Handler a restoreM st = Handler (restoreM st) -runHandler :: Handler a -> IO (Either ServantErr a)+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,20 +1,45 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}+{-# 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@@ -27,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)@@ -60,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 @@ -75,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)@@ -89,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@@ -105,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.@@ -117,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) =@@ -145,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@@ -203,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,390 +1,18 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.RoutingApplication where -import Control.Monad (ap, liftM)-import Control.Monad.Base (MonadBase (..))-import Control.Monad.Catch (MonadThrow (..))-import Control.Monad.Reader (MonadReader (..), ReaderT (..), runReaderT)-import Control.Monad.Trans (MonadIO (..), MonadTrans (..))-import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..),- defaultLiftBaseWith, defaultRestoreM)-import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runResourceT, transResourceT, withInternalState, runInternalState)-import Network.Wai (Application, Request, Response, ResponseReceived)-import Prelude ()-import Prelude.Compat-import Servant.Server.Internal.Handler-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)--instance Applicative RouteResult where- pure = return- (<*>) = ap--instance Monad RouteResult where- return = Route- Route a >>= f = f a- Fail e >>= _ = Fail e- FailFatal e >>= _ = FailFatal e--newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) }- deriving (Functor)--instance MonadTrans RouteResultT where- lift = RouteResultT . liftM Route--instance (Functor m, Monad m) => Applicative (RouteResultT m) where- pure = return- (<*>) = ap--instance Monad m => Monad (RouteResultT m) where- return = RouteResultT . return . Route- m >>= k = RouteResultT $ do- a <- runRouteResultT m- case a of- Fail e -> return $ Fail e- FailFatal e -> return $ FailFatal e- Route b -> runRouteResultT (k b)--instance MonadIO m => MonadIO (RouteResultT m) where- liftIO = lift . liftIO--instance MonadBase b m => MonadBase b (RouteResultT m) where- liftBase = lift . liftBase--instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where- type StM (RouteResultT m) a = ComposeSt RouteResultT m a- liftBaseWith = defaultLiftBaseWith- restoreM = defaultRestoreM--instance MonadTransControl RouteResultT where- type StT RouteResultT a = RouteResult a- liftWith f = RouteResultT $ liftM return $ f runRouteResultT- restoreT = RouteResultT--instance MonadThrow m => MonadThrow (RouteResultT m) where- throwM = lift . throwM- toApplication :: RoutingApplication -> Application toApplication ra request respond = ra request routingRespond where 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)--- 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]---- | 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' :: ReaderT Request (ResourceT (RouteResultT IO)) a }- deriving- ( 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---- | 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 ()---- | Fail with the option to recover.-delayedFail :: ServantErr -> DelayedIO a-delayedFail err = liftRouteResult $ Fail err---- | Fail fatally, i.e., without any option to recover.-delayedFailFatal :: ServantErr -> 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---- | 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 $ 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,472 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable #-}-module Servant.Server.Internal.ServantErr 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 ServantErr = ServantErr { errHTTPCode :: Int- , errReasonPhrase :: String- , errBody :: LBS.ByteString- , errHeaders :: [HTTP.Header]- } deriving (Show, Eq, Read, Typeable)--instance Exception ServantErr--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 = []- }---- | 'err418' Expectation Failed------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err418 { errBody = "Apologies, this is not a webserver but a teapot." }----err418 :: ServantErr-err418 = ServantErr { errHTTPCode = 418- , errReasonPhrase = "I'm a teapot"- , errBody = ""- , errHeaders = []- }---- | 'err422' Unprocessable Entity------ Example:------ > failingHandler :: Handler ()--- > failingHandler = throwError $ err422 { errBody = "I understood your request, but can't process it." }----err422 :: ServantErr-err422 = ServantErr { errHTTPCode = 422- , errReasonPhrase = "Unprocessable Entity"- , errBody = ""- , errHeaders = []- }---- | '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
@@ -24,10 +24,6 @@ (ServerT, Tagged (..)) import System.FilePath (addTrailingPathSeparator)-#if !MIN_VERSION_wai_app_static(3,1,0)-import Filesystem.Path.CurrentOS- (decodeString)-#endif import WaiAppStatic.Storage.Filesystem (ETagLookup) @@ -84,9 +80,4 @@ {-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-} fixPath :: FilePath -> FilePath-fixPath =-#if MIN_VERSION_wai_app_static(3,1,0)- addTrailingPathSeparator-#else- decodeString . addTrailingPathSeparator-#endif+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,5 +1,5 @@ module Servant.Utils.StaticFiles- {-# DEPRECATED "Use Servant.ServerStaticFiles." #-}+ {-# DEPRECATED "Use Servant.Server.StaticFiles." #-} ( module Servant.Server.StaticFiles ) where
test/Servant/ArbitraryMonadServerSpec.hs view
@@ -9,9 +9,10 @@ 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
test/Servant/HoistSpec.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} module Servant.HoistSpec where -import Test.Hspec (Spec)+import Test.Hspec+ (Spec) -import Servant+import Servant ------------------------------------------------------------------------------- -- https://github.com/haskell-servant/servant/issues/734
test/Servant/Server/ErrorSpec.hs view
@@ -6,16 +6,18 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Server.ErrorSpec (spec) where -import Control.Monad (when)-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 Data.Monoid ((<>))+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 @@ -27,6 +29,7 @@ prioErrorsSpec errorRetrySpec errorChoiceSpec+ customFormattersSpec -- * Auth machinery (reused throughout) @@ -291,11 +294,66 @@ -- }}} ------------------------------------------------------------------------------+-- * 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
test/Servant/Server/Internal/RoutingApplicationSpec.hs view
@@ -1,31 +1,37 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Servant.Server.Internal.RoutingApplicationSpec (spec) where -import Prelude ()-import Prelude.Compat+import Prelude ()+import Prelude.Compat -import Control.Exception hiding (Handler)-import Control.Monad.Trans.Resource (register)-import Control.Monad.IO.Class-import Data.IORef-import Data.Proxy-import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)-import Servant-import Servant.Server.Internal.RoutingApplication-import Network.Wai (defaultRequest)-import Test.Hspec-import Test.Hspec.Wai (request, shouldRespondWith, with)+import 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 qualified Data.Text as T -import System.IO.Unsafe (unsafePerformIO)+import System.IO.Unsafe+ (unsafePerformIO) data TestResource x = TestResourceNone
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@@ -66,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))@@ -112,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@@ -307,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/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 @@ -32,12 +33,12 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy subApi) pc nt . s route Proxy context delayed =- route subProxy context (fmap inject delayed)+ route subProxy context (fmap injectContext delayed) where subProxy :: Proxy subApi subProxy = Proxy - inject f = f (getContextEntry context)+ injectContext f = f (getContextEntry context) data InjectIntoContext @@ -58,7 +59,7 @@ newContext = ("injected" :: String) :. context -data NamedContextWithBirdface (name :: Symbol) (subContext :: [*])+data NamedContextWithBirdface (name :: Symbol) (subContext :: [Type]) instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) => HasServer (NamedContextWithBirdface name subContext :> subApi) context where
test/Servant/ServerSpec.hs view
@@ -1,70 +1,83 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}-#if __GLASGOW_HASKELL__ >= 800+{-# 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 #-}-#else-{-# OPTIONS_GHC -fcontext-stack=100 #-}-#endif module Servant.ServerSpec where +import Prelude ()+import Prelude.Compat+ import Control.Monad- (forM_, unless, when)+ (forM_, join, unless, when)+import Control.Monad.Reader (runReaderT, ask) import Control.Monad.Error.Class (MonadError (..))+import Control.Monad.IO.Class (MonadIO(..)) import Data.Aeson (FromJSON, ToJSON, decode', encode)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Base64 as Base64+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.Monoid+import Data.Maybe+ (fromMaybe) import Data.Proxy (Proxy (Proxy)) import Data.String (fromString)-import Data.String.Conversions- (cs)-import qualified Data.Text as T+import qualified Data.Text as T import GHC.Generics (Generic) import Network.HTTP.Types- (Status (..), hAccept, hContentType, imATeapot418,+ (QueryItem, Status (..), hAccept, hContentType, imATeapot418, methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut, ok200, parseQuery) import Network.Wai- (Application, Request, pathInfo, queryString, rawQueryString,- requestHeaders, responseLBS)+ (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, CaptureAll, Delete,- EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..),- JSON, NoContent (..), NoFraming, OctetStream, Patch,- PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,- RemoteHost, ReqBody, StdMethod (..), Stream,- StreamGenerator (..), Verb, addHeader)-import Servant.API.Internal.Test.ComprehensiveAPI+ 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, Tagged (..),- emptyServer, err401, err403, err404, serve, serveWithContext)+ (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, liftIO, matchHeaders, matchStatus, shouldRespondWith,+ (get, matchHeaders, matchStatus, shouldRespondWith, with, (<:>))-import qualified Test.Hspec.Wai as THW+import qualified Test.Hspec.Wai as THW+import Text.Read (readMaybe) import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler)@@ -79,22 +92,29 @@ -- 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@@ -105,13 +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 (StreamGenerator BS.ByteString)+ :<|> "stream" :> Stream method status NoFraming OctetStream (SourceIO BS.ByteString) verbSpec :: Spec verbSpec = describe "Servant.API.Verb" $ do@@ -120,8 +141,9 @@ :<|> return NoContent :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent)+ :<|> return (addHeader' 5 alice) :<|> (return alice :<|> return "B")- :<|> return (StreamGenerator $ \f _ -> f "bytestring")+ :<|> return (S.source ["bytestring"]) get200 = Proxy :: Proxy (VerbApi 'GET 200) post210 = Proxy :: Proxy (VerbApi 'POST 210)@@ -142,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@@ -151,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" [] ""@@ -164,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 ""@@ -206,101 +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- _ -> throwError 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" -> Tagged $ \request_ respond ->- respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do- it "strips the captured path snippet from pathInfo" $ do- get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))+ 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- _ -> throwError err404+captureAllServer :: Server CaptureAllApi+captureAllServer = handleLegs :<|> return+ where+ handleLegs [] = return beholder+ handleLegs legs = case sum legs of+ 4 -> return jerry+ 2 -> return tweety+ _ -> throwError err404 +type RootedCaptureAllApi = CaptureAll "xs" String :> Get '[JSON] [String]+ captureAllSpec :: Spec captureAllSpec = do+ let getStringList = decode' @[String] . simpleBody+ describe "Servant.API.CaptureAll" $ do with (return (serve captureAllApi captureAllServer)) $ do it "can capture a single element of the 'pathInfo'" $ do- response <- get "/2"+ response <- get "/legs/2" liftIO $ decode' (simpleBody response) `shouldBe` Just tweety it "can capture multiple elements of the 'pathInfo'" $ do- response <- get "/2/2"+ response <- get "/legs/2/2" liftIO $ decode' (simpleBody response) `shouldBe` Just jerry it "can capture arbitrarily many elements of the 'pathInfo'" $ do- response <- get "/1/1/0/1/0/1"+ response <- get "/legs/1/1/0/1/0/1" liftIO $ decode' (simpleBody response) `shouldBe` Just jerry it "can capture when there are no elements in 'pathInfo'" $ do- response <- get "/"+ response <- get "/legs/" liftIO $ decode' (simpleBody response) `shouldBe` Just beholder - it "returns 400 if the decoding fails" $ do- get "/notAnInt" `shouldRespondWith` 400+ it "returns 400 if the decoding fails" $ get "/legs/notAnInt" `shouldRespondWith` 400 - it "returns 400 if the decoding fails, regardless of which element" $ do- get "/1/0/0/notAnInt/3/" `shouldRespondWith` 400+ it "returns 400 if the decoding fails, regardless of which element" $ get "/legs/1/0/0/notAnInt/3/" `shouldRespondWith` 400 - it "returns 400 if the decoding fails, even when it's multiple elements" $ do- get "/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400+ it "returns 400 if the decoding fails, even when it's multiple elements" $ get "/legs/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400 + it "can capture single String" $ do+ response <- get "/arms/jerry"+ liftIO $ getStringList response `shouldBe` Just ["jerry"]++ it "can capture when there are no elements in 'pathinfo'" $ do+ response <- get "/arms/"+ liftIO $ getStringList response `shouldBe` Just []++ it "can capture empty string from captureall" $ do+ response <- get "/arms//"+ liftIO $ getStringList response `shouldBe` Just [""]++ with (return (serve (Proxy :: Proxy RootedCaptureAllApi) return)) $ do+ it "can capture empty rooted capture all" $ do+ response <- get "/"+ liftIO $ getStringList response `shouldBe` Just []++ it "can capture empty string from rooted capture all" $ do+ response <- get "//"+ liftIO $ getStringList response `shouldBe` Just [""]+ with (return (serve (Proxy :: Proxy (CaptureAll "segments" String :> Raw))- (\ _captured -> Tagged $ \request_ 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 :<|> qpAge :<|> qpAges+qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges :<|> qpRaw :<|> qpDeep where qpNames (_:name2:_) = return alice { name = name2 } qpNames _ = return alice@@ -313,123 +399,183 @@ 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- let params = "?age=55"- response <- Network.Wai.Test.request defaultRequest{- rawQueryString = params,- queryString = parseQuery params,- pathInfo = ["param"]- }- liftIO $- decode' (simpleBody response) `shouldBe` Just alice{- age = 55- }+ 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- let params = "?age=foo"- response <- Network.Wai.Test.request defaultRequest{- rawQueryString = params,- queryString = parseQuery params,- pathInfo = ["param"]- }+ 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- let params = "?ages=10&ages=22"- response <- Network.Wai.Test.request defaultRequest{- rawQueryString = params,- queryString = parseQuery params,- pathInfo = ["multiparam"]- }- liftIO $- decode' (simpleBody response) `shouldBe` Just alice{- age = 32- }+ 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- let params = "?ages=2&ages=foo"- response <- Network.Wai.Test.request defaultRequest{- rawQueryString = params,- queryString = parseQuery params,- pathInfo = ["multiparam"]- }+ 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@@ -452,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 -- }}} ------------------------------------------------------------------------------@@ -513,31 +657,59 @@ rawApi = Proxy rawApplication :: Show a => (Request -> a) -> Tagged m Application-rawApplication f = Tagged $ \request_ respond ->- respond $ responseLBS ok200 []- (cs $ show $ f request_)+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 =@@ -561,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 {{{@@ -597,30 +763,51 @@ 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@@ -675,7 +862,7 @@ basicAuthServer :: Server BasicAuthAPI basicAuthServer = const (return jerry) :<|>- (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")+ Tagged (\ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext =@@ -686,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 -- }}} ------------------------------------------------------------------------------@@ -720,7 +903,7 @@ genAuthServer :: Server GenAuthAPI genAuthServer = const (return tweety)- :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")+ :<|> Tagged (\ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") type instance AuthServerData (AuthProtect "auth") = () @@ -733,23 +916,86 @@ 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 {{{@@ -781,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/doctests.hs
@@ -1,25 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Main (doctests)--- Copyright : (C) 2012-14 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ This module provides doctests for a project based on the actual versions--- of the packages it was built with. It requires a corresponding Setup.lhs--- to be added to the project-------------------------------------------------------------------------------module Main where--import Build_doctests (flags, pkgs, module_sources)-import Data.Foldable (traverse_)-import Test.DocTest--main :: IO ()-main = do- traverse_ putStrLn args- doctest args- where- args = flags ++ pkgs ++ module_sources