servant-server-0.19.2/0000755000000000000000000000000007346545000012762 5ustar0000000000000000servant-server-0.19.2/CHANGELOG.md0000644000000000000000000003342307346545000014600 0ustar0000000000000000[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.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) 0.19 ---- ### Significant changes - Drop support for GHC < 8.6. - Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet). - Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)), which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864) related to hash collisions. - Add `NamedRoutes` combinator, making support for records first-class in Servant ([#1388](https://github.com/haskell-servant/servant/pull/1388)). - Add custom type errors for partially applied combinators ([#1289](https://github.com/haskell-servant/servant/pull/1289), [#1486](https://github.com/haskell-servant/servant/pull/1486)). 0.18.3 ------ ### Significant changes - Add response header support to UVerb (#1420) ### Other changes - Support GHC-9.0.1. - Bump `bytestring`, `hspec` and `base64-bytestring` dependencies. 0.18.2 ------ ### Significant changes - Support `Fragment` combinator. 0.18.1 ------ ### Significant changes - Union verbs ### Other changes - Bump "tested-with" ghc versions - Allow newer dependencies 0.18 ---- ### Significant changes - Support for ghc8.8 (#1318, #1326, #1327) - Configurable error messages for automatic errors thrown by servant, like "no route" or "could not parse json body" (#1312, #1326, #1327) 0.17 ---- ### Significant changes - Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228) The `NoContent` API endpoints should now use `NoContentVerb` combinator. The API type changes are usually of the kind ```diff - :<|> PostNoContent '[JSON] NoContent + :<|> PostNoContent ``` i.e. one doesn't need to specify the content-type anymore. There is no content. - `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156) You can specify a lenient capture as ```haskell :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET ``` which will make the capture always succeed. Handlers will be of the type `Either String CapturedType`, where `Left err` represents the possible parse failure. - *servant-server* use queryString to parse QueryParam, QueryParams and QueryFlag [#1249](https://github.com/haskell-servant/servant/pull/1249) [#1262](https://github.com/haskell-servant/servant/pull/1262) Some APIs need query parameters rewriting, e.g. in order to support for multiple casing (camel, snake, etc) or something to that effect. This could be easily achieved by using WAI Middleware and modifying request's `Query`. But QueryParam, QueryParams and QueryFlag use `rawQueryString`. By using `queryString` rather then `rawQueryString` we can enable such rewritings. - *servant* *servant-server* Make packages `build-type: Simple` [#1263](https://github.com/haskell-servant/servant/pull/1263) We used `build-type: Custom`, but it's problematic e.g. for cross-compiling. The benefit is small, as the doctests can be run other ways too (though not so conveniently). 0.16.2 ------ * `singleton-bool-0.1.5` (`SBool` is re-exported) - Add `discreteBool :: Dec (a :~: b)` (GHC-7.8+) - Add `Show`, `Eq`, `Ord` `SBool b` instances. * dependencies update 0.16.1 ------ * Use `http-api-data-0.4.1` (a part of its API is re-exported) [#1181](https://github.com/haskell-servant/servant/pull/1181) 0.16 ---- - Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError` [#1131](https://github.com/haskell-servant/servant/pull/1131) - *servant-server* Reorder HTTP failure code priorities [#1103](https://github.com/haskell-servant/servant/pull/1103) - *servant-server* Re-organise internal modules [#1139](https://github.com/haskell-servant/servant/pull/1139) - Allow `network-3.0` [#1107](https://github.com/haskell-servant/servant/pull/1107) 0.15 ---- - Streaming refactoring. [#991](https://github.com/haskell-servant/servant/pull/991) [#1076](https://github.com/haskell-servant/servant/pull/1076) [#1077](https://github.com/haskell-servant/servant/pull/1077) The streaming functionality (`Servant.API.Stream`) is refactored to use `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation), which replaces both `StreamGenerator` and `ResultStream` types. New conversion type-classes are `ToSourceIO` and `FromSourceIO` (replacing `ToStreamGenerator` and `BuildFromStream`). There are instances for *conduit*, *pipes* and *machines* in new packages: [servant-conduit](https://hackage.haskell.org/package/servant-conduit) [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and [servant-machines](https://hackage.haskell.org/package/servant-machines) respectively. Writing new framing strategies is simpler. Check existing strategies for examples. This change shouldn't affect you, if you don't use streaming endpoints. - Drop support for GHC older than 8.0 [#1008](https://github.com/haskell-servant/servant/pull/1008) [#1009](https://github.com/haskell-servant/servant/pull/1009) - *servant* NewlineFraming encodes newline after each element (i.e last) [#1079](https://github.com/haskell-servant/servant/pull/1079) [#1011](https://github.com/haskell-servant/servant/issues/1011) - *servant* Add `lookupResponseHeader :: ... => Headers headers r -> ResponseHeader h a` [#1064](https://github.com/haskell-servant/servant/pull/1064) - *servant-server* Add `MonadMask Handler` [#1068](https://github.com/haskell-servant/servant/pull/1068) - *servant* Export `GetHeaders'` [#1052](https://github.com/haskell-servant/servant/pull/1052) - *servant* Add `Bitraversable` and other `Bi-` instances for `:<|>` [#1032](https://github.com/haskell-servant/servant/pull/1032) - *servant* Add `PutCreated` method type alias [#1024](https://github.com/haskell-servant/servant/pull/1024) - *servant* Add `ToSourceIO (NonEmpty a)` instance [#988](https://github.com/haskell-servant/servant/pull/988) 0.14.1 ------ - Merge in `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick)) into `servant` (`Servant.API.Generic`), `servant-client-code` (`Servant.Client.Generic`) and `servant-server` (`Servant.Server.Generic`). - *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`. 0.14 ---- - `Stream` takes a status code argument ```diff -Stream method framing ctype a +Stream method status framing ctype a ``` ([#966](https://github.com/haskell-servant/servant/pull/966) [#972](https://github.com/haskell-servant/servant/pull/972)) - `ToStreamGenerator` definition changed, so it's possible to write an instance for conduits. ```diff -class ToStreamGenerator f a where - toStreamGenerator :: f a -> StreamGenerator a +class ToStreamGenerator a b | a -> b where + toStreamGenerator :: a -> StreamGenerator b ``` ([#959](https://github.com/haskell-servant/servant/pull/959)) - Added `NoFraming` streaming strategy ([#959](https://github.com/haskell-servant/servant/pull/959)) - *servant-server* File serving in polymorphic monad. i.e. Generalised types of `serveDirectoryFileServer` etc functions in `Servant.Utils.StaticFiles` ([#953](https://github.com/haskell-servant/servant/pull/953)) - *servant-server* `ReqBody` content type check is recoverable. This allows writing APIs like: ```haskell ReqBody '[JSON] Int :> Post '[PlainText] Int :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int ``` which is useful when handlers are subtly different, for example may do less work. ([#937](https://github.com/haskell-servant/servant/pull/937)) 0.13.0.1 -------- - Support `base-compat-0.10` 0.13 ---- - Streaming endpoint support. ([#836](https://github.com/haskell-servant/servant/pull/836)) - *servant* Add `Servant.API.Modifiers` ([#873](https://github.com/haskell-servant/servant/pull/873)) 0.12 ---- ### Breaking changes * Added `hoistServer` member to the `HasServer` class, which is `HasServer` specific `enter`. ([#804](https://github.com/haskell-servant/servant/pull/804)) 0.11 ---- ### Breaking changes * Changed `HasServer` instances for `Header` to throw 400 when parsing fails ([#724](https://github.com/haskell-servant/servant/pull/724)) * Added `headersD` block to `Delayed` ([#724](https://github.com/haskell-servant/servant/pull/724)) ### Other changes * Add `err418`, `err422` error codes ([#739](https://github.com/haskell-servant/servant/pull/739)) 0.10 ---- ### Breaking changes * `Handler` is now an abstract datatype. Migration hint: change `throwE` to `throwError`. ([#641](https://github.com/haskell-servant/servant/issues/641)) * Changed `HasServer` instances for `QueryParam` and `QueryParam` to throw 400 when parsing fails ([#649](https://github.com/haskell-servant/servant/pull/649)) ### Other changes * Added `paramsD` block to `Delayed` * Add `err422` Unprocessable Entity ([#646](https://github.com/haskell-servant/servant/pull/646)) * Deprecate `serveDirectory` and introduce `serveDirectoryFileServer`, `serveDirectoryWebApp`, `serveDirectoryWebAppLookup`, `serveDirectoryEmbedded` and `serveDirectoryWith` which offer 4 default options and a more flexible one for serving static files. ([#658](https://github.com/haskell-servant/servant/pull/658)) * `DelayedIO` is an instance of `MonadResource`, allowing safe resource handling. ([#622](https://github.com/haskell-servant/servant/pull/622) , [#674](https://github.com/haskell-servant/servant/pull/674) , [#675](https://github.com/haskell-servant/servant/pull/675)) 0.7.1 ------ * Remove module `Servant.Server.Internal.Enter` (https://github.com/haskell-servant/servant/pull/478) * Support GHC 8.0 0.7 --- * The `Router` type has been changed. Static router tables should now be properly shared between requests, drastically increasing the number of situations where servers will be able to route requests efficiently. Functions `layout` and `layoutWithContext` have been added to visualize the router layout for debugging purposes. Test cases for expected router layouts have been added. * If an endpoint is discovered to have a non-matching "accept header", this is now a recoverable rather than a fatal failure, allowing different endpoints for the same route, but with different content types to be specified modularly. * Export `throwError` from module `Servant` * Add `Handler` type synonym 0.6.1 ----- * If servers use the `BasicAuth` combinator and receive requests with missing or invalid credentials, the resulting error responses (401 and 403) could be overwritten by subsequent alternative routes. Now `BasicAuth` uses `FailFatal` and the error responses can't be overwritten anymore. 0.6 --- * Query parameters that can't be parsed result in a `400` (was `404`). 0.5 --- * Add `Config` machinery (https://github.com/haskell-servant/servant/pull/327). This is a breaking change, as the signatures of both `route`, `serve` and the typeclass `HasServer` now take an additional parameter. * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Drop `EitherT` in favor of `ExceptT` * Use `http-api-data` instead of `Servant.Common.Text` * Remove matrix params. * Remove `RouteMismatch`. * Redefined constructors of `RouteResult`. * Added `Delayed` and related functions (`addMethodCheck`, `addAcceptCheck`, `addBodyCheck`, `runDelayed`) * Added support for Basic Authentication * Add generalized authentication support via the `AuthServerData` type family and `AuthHandler` handler 0.4.1 ----- * Bump attoparsec upper bound to < 0.14 * Bump wai-app-static upper bound to < 3.2 * Bump either upper bound to < 4.5 0.4 --- * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body * Add a `RouteMismatch` constructor for arbitrary HTTP response codes (https://github.com/haskell-servant/servant-server/pull/22) * Add support for the `Patch` combinator * Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.4* * Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29) * Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21) * Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28) * Add server support for response headers * Use `ServantErr` instead of `(Int,String)` in `EitherT` handlers * Add `errXXX` functions for HTTP errors with sensible default reason strings * Add `enter` function for applying natural transformations to handlers 0.2.4 ----- * Added support for matrix parameters, see e.g. http://www.w3.org/DesignIssues/MatrixURIs.html * Add support for serializing based on Accept header (https://github.com/haskell-servant/servant-server/issues/9) * Ignore trailing slashes (https://github.com/haskell-servant/servant-server/issues/5) 0.2.3 ----- * Fix consuming request body issue (https://github.com/haskell-servant/servant/issues/3) * Make code sample in Servant.Server complete servant-server-0.19.2/LICENSE0000644000000000000000000000307307346545000013772 0ustar0000000000000000Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Zalora South East Asia Pte Ltd nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. servant-server-0.19.2/README.md0000644000000000000000000000103507346545000014240 0ustar0000000000000000# servant-server ![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) This library lets you *implement* an HTTP server with handlers for each endpoint of a servant API, handling most of the boilerplate for you. ## Getting started 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. servant-server-0.19.2/Setup.hs0000644000000000000000000000007007346545000014413 0ustar0000000000000000import Distribution.Simple main = defaultMain servant-server-0.19.2/example/0000755000000000000000000000000007346545000014415 5ustar0000000000000000servant-server-0.19.2/example/greet.hs0000644000000000000000000000470207346545000016062 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} import Prelude () import Prelude.Compat import Data.Aeson import Data.Proxy import Data.Text import GHC.Generics import Network.Wai import Network.Wai.Handler.Warp import Servant import Servant.Server.Generic () -- * Example -- | A greet message data type newtype Greet = Greet { _msg :: Text } deriving (Generic, Show) instance FromJSON Greet instance ToJSON Greet -- API specification type TestApi = -- GET /hello/:name?capital={true, false} returns a Greet as JSON "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet -- POST /greet with a Greet as JSON in the request body, -- returns a Greet as JSON :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet -- 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 -- Server-side handlers. -- -- There's one handler per endpoint, which, just like in the type -- that represents the API, are glued together using :<|>. -- -- Each handler runs in the 'Handler' monad. server :: Server TestApi server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes where otherRoutes = OtherRoutes {..} 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 postGreetH greet = return greet deleteGreetH _ = return NoContent -- Turn the server into a WAI app. 'serve' is provided by servant, -- more precisely by the Servant.Server module. test :: Application test = serve testApi server -- Run the server. -- -- 'run' comes from Network.Wai.Handler.Warp runTestServer :: Port -> IO () runTestServer port = run port test -- Put this all to work! main :: IO () main = runTestServer 8001 servant-server-0.19.2/servant-server.cabal0000644000000000000000000001262407346545000016741 0ustar0000000000000000cabal-version: 2.2 name: servant-server version: 0.19.2 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 . . is a runnable example, with comments, that defines a dummy API and implements a webserver that serves this API, using this package. . homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 extra-source-files: CHANGELOG.md README.md source-repository head type: git location: http://github.com/haskell-servant/servant.git library exposed-modules: Servant Servant.Server Servant.Server.Experimental.Auth Servant.Server.Generic Servant.Server.Internal Servant.Server.Internal.BasicAuth Servant.Server.Internal.Context Servant.Server.Internal.Delayed Servant.Server.Internal.DelayedIO Servant.Server.Internal.ErrorFormatter Servant.Server.Internal.Handler Servant.Server.Internal.RouteResult Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServerError Servant.Server.StaticFiles Servant.Server.UVerb -- deprecated exposed-modules: Servant.Utils.StaticFiles -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 build-depends: base >= 4.9 && < 4.18 , bytestring >= 0.10.8.1 && < 0.12 , constraints >= 0.2 && < 0.14 , containers >= 0.5.7.1 && < 0.7 , mtl >= 2.2.2 && < 2.3 , text >= 1.2.3.0 && < 2.1 , transformers >= 0.5.2.0 && < 0.6 , filepath >= 1.4.1.1 && < 1.5 -- Servant dependencies -- strict dependency as we re-export 'servant' things. build-depends: servant >= 0.19 && < 0.20 , http-api-data >= 0.4.1 && < 0.5.1 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: base-compat >= 0.10.5 && < 0.13 , base64-bytestring >= 1.0.0.1 && < 1.3 , exceptions >= 0.10.0 && < 0.11 , http-media >= 0.7.1.3 && < 0.9 , http-types >= 0.12.2 && < 0.13 , network-uri >= 2.6.1.0 && < 2.8 , monad-control >= 1.0.2.3 && < 1.1 , network >= 2.8 && < 3.2 , sop-core >= 0.4.0.0 && < 0.6 , string-conversions >= 0.4.0.1 && < 0.5 , resourcet >= 1.2.2 && < 1.3 , tagged >= 0.8.6 && < 0.9 , transformers-base >= 0.4.5.2 && < 0.5 , wai >= 3.2.1.2 && < 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 -Wno-redundant-constraints executable greet main-is: greet.hs hs-source-dirs: example ghc-options: -Wall default-language: Haskell2010 build-depends: base , base-compat , servant , servant-server , wai , text build-depends: aeson >= 1.4.1.0 && < 3 , warp >= 3.2.25 && < 3.4 test-suite spec type: exitcode-stdio-1.0 ghc-options: -Wall default-language: Haskell2010 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 -- Dependencies inherited from the library. No need to specify bounds. build-depends: base , base-compat , base64-bytestring , bytestring , http-types , mtl , resourcet , safe , servant , servant-server , sop-core , string-conversions , text , transformers , transformers-compat , wai -- Additional dependencies build-depends: aeson >= 1.4.1.0 && < 3 , directory >= 1.3.0.0 && < 1.4 , hspec >= 2.6.0 && < 2.10 , hspec-wai >= 0.10.1 && < 0.12 , QuickCheck >= 2.12.6.1 && < 2.15 , should-not-typecheck >= 2.1.0 && < 2.2 , temporary >= 1.3 && < 1.4 , wai-extra >= 3.0.24.3 && < 3.2 build-tool-depends: hspec-discover:hspec-discover >= 2.6.0 && <2.10 servant-server-0.19.2/src/0000755000000000000000000000000007346545000013551 5ustar0000000000000000servant-server-0.19.2/src/Servant.hs0000644000000000000000000000126007346545000015526 0ustar0000000000000000module Servant ( -- | This module and its submodules can be used to define servant APIs. Note -- that these API definitions don't directly implement a server (or anything -- else). module Servant.API, -- | For implementing servers for servant APIs. module Servant.Server, -- | Utilities on top of the servant core module Servant.Links, module Servant.Server.StaticFiles, -- | Useful re-exports Proxy(..), throwError ) where import Control.Monad.Error.Class (throwError) import Data.Proxy import Servant.API import Servant.Links import Servant.Server import Servant.Server.StaticFiles servant-server-0.19.2/src/Servant/0000755000000000000000000000000007346545000015173 5ustar0000000000000000servant-server-0.19.2/src/Servant/Server.hs0000644000000000000000000001733507346545000017006 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | This module lets you implement 'Server's for defined APIs. You'll -- most likely just need 'serve'. module Servant.Server ( -- * Run a wai application from an API serve , serveWithContext , serveWithContextT , ServerContext , -- * Construct a wai Application from an API toApplication , -- * Handlers for all standard combinators HasServer(..) , Server , EmptyServer , emptyServer , Handler (..) , runHandler -- * Debugging the server layout , layout , layoutWithContext -- * Enter / hoisting server , hoistServer -- ** Functions based on , tweakResponse -- * Context , Context(..) , HasContextEntry(getContextEntry) , type (.++) , (.++) -- ** NamedContext , NamedContext(..) , descendIntoNamedContext -- * Basic Authentication , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck) , BasicAuthResult(..) -- * General Authentication -- , AuthHandler(unAuthHandler) -- , AuthServerData -- , mkAuthHandler -- * Default error type , ServerError(..) -- ** 3XX , err300 , err301 , err302 , err303 , err304 , err305 , err307 -- ** 4XX , err400 , err401 , err402 , err403 , err404 , err405 , err406 , err407 , err409 , err410 , err411 , err412 , err413 , err414 , err415 , err416 , err417 , err418 , err422 -- ** 5XX , err500 , err501 , err502 , err503 , 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 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 '[JSON] Book :> Post '[JSON] Book -- POST /books -- > -- > server :: Server MyApi -- > server = listAllBooks :<|> postBook -- > where listAllBooks = ... -- > postBook book = ... -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > -- > app :: Application -- > app = serve myApi server -- > -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -- serve :: (HasServer api '[]) => Proxy api -> Server api -> Application serve p = serveWithContext p EmptyContext -- | 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 = serveWithContextT p context id -- | A general 'serve' function that allows you to pass a custom context and hoisting function to -- apply on all routes. serveWithContextT :: forall api context m. (HasServer api context, ServerContext context) => Proxy api -> Context context -> (forall x. m x -> Handler x) -> ServerT api m -> Application serveWithContextT p context toHandler server = toApplication (runRouter format404 (route p context (emptyDelayed router))) where router = Route $ hoistServerWithContext p (Proxy :: Proxy context) toHandler server format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context -- | Hoist server implementation. -- -- Sometimes our cherished `Handler` monad isn't quite the type you'd like for -- your handlers. Maybe you want to thread some configuration in a @Reader@ -- monad. Or have your types ensure that your handlers don't do any IO. Use -- `hoistServer` (a successor of now deprecated @enter@). -- -- With `hoistServer`, you can provide a function, -- to convert any number of endpoints from one type constructor to -- another. For example -- -- /Note:/ 'Server' 'Raw' can also be entered. It will be retagged. -- -- >>> import Control.Monad.Reader -- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String :<|> Raw :<|> EmptyAPI -- >>> let readerApi = Proxy :: Proxy ReaderAPI -- >>> let readerServer = return 1797 :<|> ask :<|> Tagged (error "raw server") :<|> emptyServer :: ServerT ReaderAPI (Reader String) -- >>> let nt x = return (runReader x "hi") -- >>> let mainServer = hoistServer readerApi nt readerServer :: Server ReaderAPI -- hoistServer :: (HasServer api '[]) => Proxy api -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[]) -- | The function 'layout' produces a textual description of the internal -- router layout for debugging purposes. Note that the router layout is -- determined just by the API, not by the handlers. -- -- Example: -- -- For the following API -- -- > type API = -- > "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 -- -- we get the following output: -- -- > / -- > ├─ a/ -- > │ ├─ d/ -- > │ │ └─• -- > │ └─ e/ -- > │ └─• -- > ├─ b/ -- > │ └─ / -- > │ ├─• -- > │ ┆ -- > │ └─• -- > ├─ c/ -- > │ └─• -- > ┆ -- > └─ -- -- Explanation of symbols: -- -- [@├@] Normal lines reflect static branching via a table. -- -- [@a/@] Nodes reflect static path components. -- -- [@─•@] Leaves reflect endpoints. -- -- [@\/@] This is a delayed capture of a single -- path component named @x@, of expected type @Int@. -- -- [@\@] This is a part of the API we do not know anything about. -- -- [@┆@] Dashed lines suggest a dynamic choice between the part above -- and below. If there is a success for fatal failure in the first part, -- that one takes precedence. If both parts fail, the \"better\" error -- code will be returned. -- layout :: (HasServer api '[]) => Proxy api -> Text layout p = layoutWithContext p EmptyContext -- | Variant of 'layout' that takes an additional 'Context'. layoutWithContext :: (HasServer api context) => Proxy api -> Context context -> Text layoutWithContext p context = routerLayout (route p context (emptyDelayed (FailFatal err501))) -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeOperators -- >>> import Servant.API -- >>> import Servant.Server servant-server-0.19.2/src/Servant/Server/Experimental/0000755000000000000000000000000007346545000021076 5ustar0000000000000000servant-server-0.19.2/src/Servant/Server/Experimental/Auth.hs0000644000000000000000000000474607346545000022346 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveDataTypeable #-} {-# 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 Servant ((:>)) import Servant.API.Experimental.Auth import Servant.Server.Internal (DelayedIO, Handler, HasContextEntry, HasServer (..), addAuthCheck, delayedFailFatal, getContextEntry, runHandler, withRequest) -- * General Auth -- | Specify the type of data returned after we've authenticated a request. -- quite often this is some `User` datatype. -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE type family AuthServerData a :: * -- | 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) -- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr mkAuthHandler = AuthHandler -- | Known orphan instance. instance ( HasServer api context , HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag))) ) => HasServer (AuthProtect tag :> api) context where type ServerT (AuthProtect tag :> api) m = AuthServerData (AuthProtect tag) -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck) where authHandler :: Request -> Handler (AuthServerData (AuthProtect tag)) authHandler = unAuthHandler (getContextEntry context) authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag)) authCheck = (>>= either delayedFailFatal return) . liftIO . runHandler . authHandler servant-server-0.19.2/src/Servant/Server/0000755000000000000000000000000007346545000016441 5ustar0000000000000000servant-server-0.19.2/src/Servant/Server/Generic.hs0000644000000000000000000000660507346545000020360 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | @since 0.14.1 module Servant.Server.Generic ( AsServerT, AsServer, genericServe, genericServeT, genericServeTWithContext, genericServer, genericServerT ) where import Data.Proxy (Proxy (..)) import Servant.Server import Servant.API.Generic import Servant.Server.Internal -- | Transform a record of routes into a WAI 'Application'. genericServe :: forall routes. ( HasServer (ToServantApi routes) '[] , GenericServant routes AsServer , Server (ToServantApi routes) ~ ToServant routes AsServer ) => routes AsServer -> Application genericServe = serve (Proxy :: Proxy (ToServantApi routes)) . genericServer -- | Transform a record of routes with custom monad into a WAI 'Application', -- by providing a transformation to bring each handler back in the 'Handler' -- monad. genericServeT :: forall (routes :: * -> *) (m :: * -> *). ( 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 :: * -> *) (m :: * -> *) (ctx :: [*]). ( 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 -- . genericServerT :: GenericServant routes (AsServerT m) => routes (AsServerT m) -> ToServant routes (AsServerT m) genericServerT = toServant servant-server-0.19.2/src/Servant/Server/Internal.hs0000644000000000000000000011650707346545000020563 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal ( module Servant.Server.Internal , module Servant.Server.Internal.BasicAuth , module Servant.Server.Internal.Context , module Servant.Server.Internal.Delayed , module Servant.Server.Internal.DelayedIO , module Servant.Server.Internal.ErrorFormatter , module Servant.Server.Internal.Handler , module Servant.Server.Internal.Router , module Servant.Server.Internal.RouteResult , module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.ServerError ) where import Control.Monad (join, when) 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.Constraint (Constraint, Dict(..)) import Data.Either (partitionEithers) import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) import Data.String (IsString (..)) import Data.String.Conversions (cs) import Data.Tagged (Tagged (..), retag, untag) import qualified Data.Text as T import Data.Typeable import GHC.Generics import GHC.TypeLits (KnownNat, KnownSymbol, TypeError, symbolVal) import qualified Network.HTTP.Media as NHM import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.Socket (SockAddr) import Network.Wai (Application, Request, httpVersion, isSecure, lazyRequestBody, queryString, remoteHost, getRequestBodyChunk, requestHeaders, requestMethod, responseLBS, responseStream, vault) import Prelude () import Prelude.Compat import Servant.API ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture', CaptureAll, Description, EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..), FromSourceIO (..), Header', If, IsSecure (..), NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod), RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, WithNamedContext, 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.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 Data.Kind (Type) import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context import Servant.Server.Internal.Delayed import Servant.Server.Internal.DelayedIO import Servant.Server.Internal.ErrorFormatter import Servant.Server.Internal.Handler import Servant.Server.Internal.Router import Servant.Server.Internal.RouteResult import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError import GHC.TypeLits (ErrorMessage (..), TypeError) import Servant.API.TypeLevel (AtLeastOneFragment, FragmentUnique) class HasServer api context where type ServerT api (m :: * -> *) :: * route :: Proxy api -> Context context -> Delayed env (Server api) -> Router env hoistServerWithContext :: Proxy api -> Proxy context -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n type Server api = ServerT api Handler -- * Instances -- | A server for @a ':<|>' b@ first tries to match the request against the route -- represented by @a@ and if it fails tries @b@. You must provide a request -- handler for each route. -- -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books -- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books -- > -- > server :: Server MyApi -- > server = listAllBooks :<|> postBook -- > where listAllBooks = ... -- > postBook book = ... instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) context where type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server)) (route pb context ((\ (_ :<|> b) -> b) <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b -- | This is better than 'enter', as it's tailor made for 'HasServer'. hoistServerWithContext _ pc nt (a :<|> b) = hoistServerWithContext (Proxy :: Proxy a) pc nt a :<|> hoistServerWithContext (Proxy :: Proxy b) pc nt b -- | If you use 'Capture' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by the 'Capture'. -- This lets servant worry about getting it from the URL and turning -- it into a value of the type you specify. -- -- You can control how it'll be converted from 'Text' to your type -- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- -- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book -- > -- > server :: Server MyApi -- > server = getBook -- > where getBook :: Text -> Handler Book -- > getBook isbn = ... instance (KnownSymbol capture, FromHttpApiData a, Typeable a , HasServer api context, SBoolI (FoldLenient mods) , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (Capture' mods capture a :> api) context where type ServerT (Capture' mods capture a :> api) m = If (FoldLenient mods) (Either String a) a -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context d = CaptureRouter [hint] $ route (Proxy :: Proxy api) context (addCapture d $ \ txt -> withRequest $ \ request -> case ( sbool :: SBool (FoldLenient mods) , parseUrlPiece txt :: Either T.Text a) of (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e (SFalse, Right v) -> return v (STrue, piece) -> return $ (either (Left . cs) Right) piece) where rep = typeRep (Proxy :: Proxy Capture') formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a)) -- | If you use 'CaptureAll' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a -- function that takes an argument of a list of the type specified by -- the 'CaptureAll'. This lets servant worry about getting values from -- the URL and turning them into values of the type you specify. -- -- You can control how they'll be converted from 'Text' to your type -- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- -- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile -- > -- > server :: Server MyApi -- > server = getSourceFile -- > where getSourceFile :: [Text] -> Handler Book -- > getSourceFile pathSegments = ... instance (KnownSymbol capture, FromHttpApiData a, Typeable a , HasServer api context , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (CaptureAll capture a :> api) context where type ServerT (CaptureAll capture a :> api) m = [a] -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context d = CaptureAllRouter [hint] $ route (Proxy :: Proxy api) context (addCapture d $ \ txts -> withRequest $ \ request -> case parseUrlPieces txts of Left e -> delayedFail $ formatError rep request $ cs 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])) allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead allowedMethod :: Method -> Request -> Bool allowedMethod method request = allowedMethodHead method request || requestMethod request == method methodCheck :: Method -> Request -> DelayedIO () methodCheck method request | allowedMethod method request = return () | otherwise = delayedFail err405 -- This has switched between using 'Fail' and 'FailFatal' a number of -- times. If the 'acceptCheck' is run after the body check (which would -- be morally right), then we have to set this to 'FailFatal', because -- the body check is not reversible, and therefore backtracking after the -- body check is no longer an option. However, we now run the accept -- check before the body check and can therefore afford to make it -- recoverable. acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO () acceptCheck proxy accH | canHandleAcceptH proxy accH = return () | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a) => (b -> ([(HeaderName, B.ByteString)], a)) -> Method -> Proxy ctypes -> Status -> Delayed env (Handler b) -> Router env methodRouter splitHeaders method proxy status action = leafRouter route' where route' env request respond = let accH = getAcceptHeader request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH ) env request respond $ \ output -> do let (headers, b) = splitHeaders output case handleAcceptH proxy accH b of Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does Just (contentT, body) -> let bdy = if allowedMethodHead method request then "" else body in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy noContentRouter :: Method -> Status -> Delayed env (Handler b) -> Router env noContentRouter method status action = leafRouter route' where route' env request respond = runAction (action `addMethodCheck` methodCheck method request) env request respond $ \ _output -> Route $ responseLBS status [] "" instance {-# OVERLAPPABLE #-} ( AllCTRender ctypes a, ReflectMethod method, KnownNat status ) => HasServer (Verb method status ctypes a) context where type ServerT (Verb method status ctypes a) m = m a hoistServerWithContext _ _ nt s = nt s route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = statusFromNat (Proxy :: Proxy status) instance {-# OVERLAPPING #-} ( AllCTRender ctypes a, ReflectMethod method, KnownNat status , GetHeaders (Headers h a) ) => HasServer (Verb method status ctypes (Headers h a)) context where type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) hoistServerWithContext _ _ nt s = nt s route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = statusFromNat (Proxy :: Proxy status) instance (ReflectMethod method) => HasServer (NoContentVerb method) context where type ServerT (NoContentVerb method) m = m NoContent hoistServerWithContext _ _ nt s = nt s route Proxy _ = noContentRouter method status204 where method = reflectMethod (Proxy :: Proxy method) instance {-# OVERLAPPABLE #-} ( MimeRender ctype chunk, ReflectMethod method, KnownNat status, FramingRender framing, ToSourceIO chunk a ) => HasServer (Stream method status framing ctype a) context where type ServerT (Stream method status framing ctype a) m = m a hoistServerWithContext _ _ nt s = nt s route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) status = statusFromNat (Proxy :: Proxy status) instance {-# OVERLAPPING #-} ( MimeRender ctype chunk, ReflectMethod method, KnownNat status, FramingRender framing, ToSourceIO chunk a, GetHeaders (Headers h a) ) => HasServer (Stream method status framing ctype (Headers h a)) context where type ServerT (Stream method status framing ctype (Headers h a)) m = m (Headers h a) hoistServerWithContext _ _ nt s = nt s route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) status = statusFromNat (Proxy :: Proxy status) streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) => (c -> ([(HeaderName, B.ByteString)], a)) -> Method -> Status -> Proxy framing -> Proxy ctype -> Delayed env (Handler c) -> Router env streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond -> let AcceptHeader accH = getAcceptHeader request cmediatype = NHM.matchAccept [contentType ctypeproxy] accH accCheck = when (isNothing cmediatype) $ delayedFail err406 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype) in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` accCheck ) env request respond $ \ output -> let (headers, fa) = splitHeaders output sourceT = toSourceIO fa S.SourceT kStepLBS = framingRender framingproxy (mimeRender ctypeproxy :: chunk -> BL.ByteString) sourceT in Route $ responseStream status (contentHeader : headers) $ \write flush -> do let loop S.Stop = flush loop (S.Error err) = fail err -- TODO: throw better error loop (S.Skip s) = loop s loop (S.Effect ms) = ms >>= loop loop (S.Yield lbs s) = do write (BB.lazyByteString lbs) flush loop s kStepLBS loop -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by 'Header'. -- This lets servant worry about extracting it from the request and turning -- it into a value of the type you specify. -- -- All it asks is for a 'FromHttpApiData' instance. -- -- Example: -- -- > newtype Referer = Referer Text -- > deriving (Eq, Show, FromHttpApiData) -- > -- > -- GET /view-my-referer -- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer -- > -- > server :: Server MyApi -- > server = viewReferer -- > where viewReferer :: Referer -> Handler referer -- > viewReferer referer = return referer instance (KnownSymbol sym, FromHttpApiData a, HasServer api context , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (Header' mods sym a :> api) context where ------ type ServerT (Header' mods sym a :> api) m = RequestArgument mods a -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addHeaderCheck` withRequest headerCheck where rep = typeRep (Proxy :: Proxy Header') formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) headerName :: IsString n => n headerName = fromString $ symbolVal (Proxy :: Proxy sym) headerCheck :: Request -> DelayedIO (RequestArgument mods a) headerCheck req = unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev where mev :: Maybe (Either T.Text a) mev = fmap parseHeader $ lookup headerName (requestHeaders req) errReq = delayedFailFatal $ formatError rep req $ "Header " <> headerName <> " is required" errSt e = delayedFailFatal $ formatError rep req $ cs $ "Error parsing header " <> headerName <> " failed: " <> e -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @'Maybe' 'Text'@. -- -- This lets servant worry about looking it up in the query string -- and turning it into a value of the type you specify, enclosed -- in 'Maybe', because it may not be there and servant would then -- hand you 'Nothing'. -- -- You can control how it'll be converted from 'Text' to your type -- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- -- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooksBy -- > where getBooksBy :: Maybe Text -> Handler [Book] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author... instance ( KnownSymbol sym, FromHttpApiData a, HasServer api context , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (QueryParam' mods sym a :> api) context where ------ type ServerT (QueryParam' mods sym a :> api) m = RequestArgument mods a -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = let querytext = queryToQueryText . queryString paramname = cs $ symbolVal (Proxy :: Proxy sym) rep = typeRep (Proxy :: Proxy QueryParam') formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) parseParam :: Request -> DelayedIO (RequestArgument mods a) parseParam req = unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev where mev :: Maybe (Either T.Text a) mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req errReq = delayedFailFatal $ formatError rep req $ cs $ "Query parameter " <> paramname <> " is required" errSt e = delayedFailFatal $ formatError rep req $ cs $ "Error parsing query parameter " <> paramname <> " failed: " <> e delayed = addParameterCheck subserver . withRequest $ \req -> parseParam req in route (Proxy :: Proxy api) context delayed -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @['Text']@. -- -- This lets servant worry about looking up 0 or more values in the query string -- associated to @authors@ and turning each of them into a value of -- the type you specify. -- -- You can control how the individual values are converted from 'Text' to your type -- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- -- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooksBy -- > where getBooksBy :: [Text] -> Handler [Book] -- > getBooksBy authors = ...return all books by these authors... instance (KnownSymbol sym, FromHttpApiData a, HasServer api context , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters) => HasServer (QueryParams sym a :> api) context where type ServerT (QueryParams sym a :> api) m = [a] -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addParameterCheck` withRequest paramsCheck where rep = typeRep (Proxy :: Proxy QueryParams) formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) paramname = cs $ symbolVal (Proxy :: Proxy sym) paramsCheck req = case partitionEithers $ fmap parseQueryParam params of ([], parsed) -> return parsed (errs, _) -> delayedFailFatal $ formatError rep req $ cs $ "Error parsing query parameter(s) " <> paramname <> " failed: " <> T.intercalate ", " errs where params :: [T.Text] params = mapMaybe snd . filter (looksLikeParam . fst) . queryToQueryText . queryString $ req looksLikeParam name = name == paramname || name == (paramname <> "[]") -- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type 'Bool'. -- -- Example: -- -- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooks -- > where getBooks :: Bool -> Handler [Book] -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... instance (KnownSymbol sym, HasServer api context) => HasServer (QueryFlag sym :> api) context where type ServerT (QueryFlag sym :> api) m = Bool -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = let querytext = queryToQueryText . queryString param r = case lookup paramname (querytext r) of Just Nothing -> True -- param is there, with no value Just (Just v) -> examine v -- param with a value Nothing -> False -- param not in the query string in route (Proxy :: Proxy api) context (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False -- | Just pass the request to the underlying application and serve its response. -- -- Example: -- -- > type MyApi = "images" :> Raw -- > -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" instance HasServer Raw context where type ServerT Raw m = Tagged m Application hoistServerWithContext _ _ _ = retag route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do -- note: a Raw application doesn't register any cleanup -- but for the sake of consistency, we nonetheless run -- the cleanup once its done r <- runDelayed rawApplication env request liftIO $ go r request respond where go r request respond = case r of Route app -> untag app request (respond . Route) Fail a -> respond $ Fail a FailFatal e -> respond $ FailFatal e -- | If you use 'ReqBody' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by 'ReqBody'. -- The @Content-Type@ header is inspected, and the list provided is used to -- attempt deserialization. If the request does not have a @Content-Type@ -- header, it is treated as @application/octet-stream@ (as specified in -- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)). -- This lets servant worry about extracting it from the request and turning -- it into a value of the type you specify. -- -- -- All it asks is for a 'FromJSON' instance. -- -- Example: -- -- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- > -- > server :: Server MyApi -- > server = postBook -- > where postBook :: Book -> Handler Book -- > postBook book = ...insert into your db... instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods) , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (ReqBody' mods list a :> api) context where type ServerT (ReqBody' mods list a :> api) m = If (FoldLenient mods) (Either String a) a -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = route (Proxy :: Proxy api) context $ addBodyCheck subserver ctCheck bodyCheck where rep = typeRep (Proxy :: Proxy ReqBody') formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) -- Content-Type check, we only lookup we can try to parse the request body ctCheck = withRequest $ \ request -> do -- See HTTP RFC 2616, section 7.2.1 -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 -- See also "W3C Internet Media Type registration, consistency of use" -- http://www.w3.org/2001/tag/2002/0129-mime let contentTypeH = fromMaybe "application/octet-stream" $ lookup hContentType $ requestHeaders request case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of Nothing -> delayedFail err415 Just f -> return f -- Body check, we get a body parsing functions as the first argument. bodyCheck f = withRequest $ \ request -> do mrqbody <- f <$> liftIO (lazyRequestBody request) case sbool :: SBool (FoldLenient mods) of STrue -> return mrqbody SFalse -> case mrqbody of Left e -> delayedFailFatal $ formatError rep request e Right v -> return v instance ( FramingUnrender framing, FromSourceIO chunk a, MimeUnrender ctype chunk , HasServer api context ) => HasServer (StreamBody' mods framing ctype a :> api) context where type ServerT (StreamBody' mods framing ctype a :> api) m = a -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = route (Proxy :: Proxy api) context $ addBodyCheck subserver ctCheck bodyCheck where ctCheck :: DelayedIO (SourceIO chunk -> a) -- TODO: do content-type check ctCheck = return fromSourceIO bodyCheck :: (SourceIO chunk -> a) -> DelayedIO a bodyCheck fromRS = withRequest $ \req -> do let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.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 let rs' = fromRS $ framingUnrender' rs return rs' -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @api@. instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where type ServerT (path :> api) m = ServerT api m route Proxy context subserver = pathRouter (cs (symbolVal proxyPath)) (route (Proxy :: Proxy api) context subserver) where proxyPath = Proxy :: Proxy path hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s instance HasServer api context => HasServer (RemoteHost :> api) context where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver remoteHost) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s instance HasServer api context => HasServer (IsSecure :> api) context where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver secure) where secure req = if isSecure req then Secure else NotSecure hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s instance HasServer api context => HasServer (Vault :> api) context where type ServerT (Vault :> api) m = Vault -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver vault) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s instance HasServer api context => HasServer (HttpVersion :> api) context where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver httpVersion) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s -- | Ignore @'Summary'@ in server handlers. instance HasServer api ctx => HasServer (Summary desc :> api) ctx where type ServerT (Summary desc :> api) m = ServerT api m route _ = route (Proxy :: Proxy api) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s -- | Ignore @'Description'@ in server handlers. instance HasServer api ctx => HasServer (Description desc :> api) ctx where type ServerT (Description desc :> api) m = ServerT api m route _ = route (Proxy :: Proxy api) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s -- | Singleton type representing a server that serves an empty API. data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum) -- | Server for `EmptyAPI` emptyServer :: ServerT EmptyAPI m emptyServer = Tagged EmptyServer -- | The server for an `EmptyAPI` is `emptyServer`. -- -- > type MyApi = "nothing" :> EmptyApi -- > -- > server :: Server MyApi -- > server = emptyServer instance HasServer EmptyAPI context where type ServerT EmptyAPI m = Tagged m EmptyServer route Proxy _ _ = StaticRouter mempty mempty hoistServerWithContext _ _ _ = retag -- | Basic Authentication instance ( KnownSymbol realm , HasServer api context , HasContextEntry context (BasicAuthCheck usr) ) => HasServer (BasicAuth realm usr :> api) context where type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck) where realm = BC8.pack $ symbolVal (Proxy :: Proxy realm) basicAuthContext = getContextEntry context authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s -- * helpers ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" getAcceptHeader :: Request -> AcceptHeader getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders -- * General Authentication -- * contexts instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) => HasServer (WithNamedContext name subContext subApi) context where type ServerT (WithNamedContext name subContext subApi) m = ServerT subApi m route Proxy context delayed = route subProxy subContext delayed where subProxy :: Proxy subApi subProxy = Proxy subContext :: Context subContext subContext = descendIntoNamedContext (Proxy :: Proxy name) context hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s ------------------------------------------------------------------------------- -- Custom type errors ------------------------------------------------------------------------------- -- Erroring instance for 'HasServer' when a combinator is not fully applied instance TypeError (PartialApplication #if __GLASGOW_HASKELL__ >= 904 @(Type -> [Type] -> Constraint) #endif HasServer arr) => HasServer ((arr :: a -> b) :> sub) context where type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr) route = error "unreachable" hoistServerWithContext _ _ _ _ = error "unreachable" -- | This instance prevents from accidentally using '->' instead of ':>' -- -- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...") -- ... -- ...No instance HasServer (a -> b). -- ...Maybe you have used '->' instead of ':>' between -- ...Capture' '[] "foo" Int -- ...and -- ...Verb 'GET 200 '[JSON] Int -- ... -- -- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int) -- ... -- ...No instance HasServer (a -> b). -- ...Maybe you have used '->' instead of ':>' between -- ...Capture' '[] "foo" Int -- ...and -- ...Verb 'GET 200 '[JSON] Int -- ... -- instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context where type ServerT (a -> b) m = TypeError (HasServerArrowTypeError a b) route _ _ _ = error "servant-server panic: impossible happened in HasServer (a -> b)" hoistServerWithContext _ _ _ = id type HasServerArrowTypeError a b = 'Text "No instance HasServer (a -> b)." ':$$: 'Text "Maybe you have used '->' instead of ':>' between " ':$$: 'ShowType a ':$$: 'Text "and" ':$$: 'ShowType b -- Erroring instances for 'HasServer' for unknown API combinators -- XXX: This omits the @context@ parameter, e.g.: -- -- "There is no instance for HasServer (Bool :> …)". Do we care ? instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub #if __GLASGOW_HASKELL__ >= 904 @(Type -> [Type] -> Constraint) #endif HasServer ty) => HasServer (ty :> sub) context instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context -- | Ignore @'Fragment'@ in server handlers. -- See 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 (AtLeastOneFragment 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 :: * -> *) 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 :: * -> *) (m :: * -> *) 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 ) => 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 servant-server-0.19.2/src/Servant/Server/Internal/0000755000000000000000000000000007346545000020215 5ustar0000000000000000servant-server-0.19.2/src/Servant/Server/Internal/BasicAuth.hs0000644000000000000000000000544007346545000022417 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# 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.Typeable (Typeable) import Data.Word8 (isSpace, toLower, _colon) import GHC.Generics import Network.HTTP.Types (Header) import Network.Wai (Request, requestHeaders) 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 certain kinds of timing attacks. Decoding payloads does not take -- a fixed amount of time. -- | The result of authentication/authorization data BasicAuthResult usr = Unauthorized | BadPassword | NoSuchUser | Authorized usr deriving (Eq, Show, Read, Generic, Typeable, Functor) -- | Datatype wrapping a function used to check authentication. newtype BasicAuthCheck usr = BasicAuthCheck { unBasicAuthCheck :: BasicAuthData -> IO (BasicAuthResult usr) } deriving (Generic, Typeable, Functor) -- | Internal method to make a basic-auth challenge mkBAChallengerHdr :: BS.ByteString -> Header mkBAChallengerHdr realm = ("WWW-Authenticate", "Basic realm=\"" <> realm <> "\"") -- | Find and decode an 'Authorization' header from the request as Basic Auth decodeBAHdr :: Request -> Maybe BasicAuthData decodeBAHdr req = do ah <- lookup "Authorization" $ requestHeaders req let (b, rest) = BS.break isSpace ah guard (BS.map toLower b == "basic") let decoded = decodeLenient (BS.dropWhile isSpace rest) let (username, passWithColonAtHead) = BS.break (== _colon) decoded (_, password) <- BS.uncons passWithColonAtHead return (BasicAuthData username password) -- | Run and check basic authentication, returning the appropriate http error per -- the spec. runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> DelayedIO usr runBasicAuth req realm (BasicAuthCheck ba) = case decodeBAHdr req of Nothing -> plzAuthenticate Just e -> liftIO (ba e) >>= \res -> case res of BadPassword -> plzAuthenticate NoSuchUser -> plzAuthenticate Unauthorized -> delayedFailFatal err403 Authorized usr -> return usr where plzAuthenticate = delayedFailFatal err401 { errHeaders = [mkBAChallengerHdr realm] } servant-server-0.19.2/src/Servant/Server/Internal/Context.hs0000644000000000000000000001074507346545000022204 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Servant.Server.Internal.Context where import Data.Proxy import GHC.TypeLits -- | 'Context's are used to pass values to combinators. (They are __not__ meant -- to be used to pass parameters to your handlers, i.e. they should not replace -- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using -- with 'hoistServer'.) If you don't use combinators that -- require any context entries, you can just use 'Servant.Server.serve' as always. -- -- If you are using combinators that require a non-empty 'Context' you have to -- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all -- the values your combinators need. A 'Context' is essentially a 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 -- operator @(':.')@: -- -- >>> :type True :. () :. EmptyContext -- True :. () :. EmptyContext :: Context '[Bool, ()] data Context contextTypes where EmptyContext :: Context '[] (:.) :: x -> Context xs -> Context (x ': xs) infixr 5 :. instance Show (Context '[]) where show EmptyContext = "EmptyContext" instance (Show a, Show (Context as)) => Show (Context (a ': as)) where showsPrec outerPrecedence (a :. as) = showParen (outerPrecedence > 5) $ shows a . showString " :. " . shows as instance Eq (Context '[]) where _ == _ = True instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 -- | Append two type-level lists. -- -- Hint: import it as -- -- > import Servant.Server (type (.++)) type family (.++) (l1 :: [*]) (l2 :: [*]) where '[] .++ a = a (a ': as) .++ b = a ': (as .++ b) -- | 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: -- -- >>> getContextEntry (True :. False :. EmptyContext) :: Bool -- True -- -- If the 'Context' does not contain an entry of the requested type, you'll get -- an error: -- -- >>> getContextEntry (True :. False :. EmptyContext) :: String -- ... -- ...No instance for (HasContextEntry '[] [Char]) -- ... class HasContextEntry (context :: [*]) (val :: *) where getContextEntry :: Context context -> val instance {-# OVERLAPPABLE #-} HasContextEntry xs val => HasContextEntry (notIt ': xs) val where getContextEntry (_ :. xs) = getContextEntry xs instance {-# OVERLAPPING #-} HasContextEntry (val ': xs) val where getContextEntry (x :. _) = x -- * support for named subcontexts -- | Normally context entries are accessed by their types. In case you need -- 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 :: [*]) = NamedContext (Context subContext) -- | 'descendIntoNamedContext' allows you to access `NamedContext's. Usually you -- won't have to use it yourself but instead use a combinator like -- 'Servant.API.WithNamedContext.WithNamedContext'. -- -- This is how 'descendIntoNamedContext' works: -- -- >>> :set -XFlexibleContexts -- >>> let subContext = True :. EmptyContext -- >>> :type subContext -- subContext :: Context '[Bool] -- >>> let parentContext = False :. (NamedContext subContext :: NamedContext "subContext" '[Bool]) :. EmptyContext -- >>> :type parentContext -- parentContext :: Context '[Bool, NamedContext "subContext" '[Bool]] -- >>> descendIntoNamedContext (Proxy :: Proxy "subContext") parentContext :: Context '[Bool] -- True :. EmptyContext descendIntoNamedContext :: forall context name subContext . HasContextEntry context (NamedContext name subContext) => Proxy (name :: Symbol) -> Context context -> Context subContext descendIntoNamedContext Proxy context = let NamedContext subContext = getContextEntry context :: NamedContext name subContext in subContext servant-server-0.19.2/src/Servant/Server/Internal/Delayed.hs0000644000000000000000000002310007346545000022114 0ustar0000000000000000{-# 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 , we cannot do the more succinct thing - just update the records we actually change. -} servant-server-0.19.2/src/Servant/Server/Internal/DelayedIO.hs0000644000000000000000000000523507346545000022355 0ustar0000000000000000{-# 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 ( 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 servant-server-0.19.2/src/Servant/Server/Internal/ErrorFormatter.hs0000644000000000000000000000556607346545000023542 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} module Servant.Server.Internal.ErrorFormatter ( ErrorFormatters(..) , ErrorFormatter , NotFoundErrorFormatter , DefaultErrorFormatters , defaultErrorFormatters , MkContextWithErrorFormatter , mkContextWithErrorFormatter ) where import Data.String.Conversions (cs) import Data.Typeable import Network.Wai.Internal (Request) 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 :: [*]) = ctx .++ DefaultErrorFormatters mkContextWithErrorFormatter :: forall (ctx :: [*]). Context ctx -> Context (MkContextWithErrorFormatter ctx) mkContextWithErrorFormatter ctx = ctx .++ (defaultErrorFormatters :. EmptyContext) -- Internal err400Formatter :: ErrorFormatter err400Formatter _ _ e = err400 { errBody = cs 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 servant-server-0.19.2/src/Servant/Server/Internal/Handler.hs0000644000000000000000000000340607346545000022131 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Servant.Server.Internal.Handler where import Prelude () import Prelude.Compat 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, runExceptT) import Data.String (fromString) import GHC.Generics (Generic) import Servant.Server.Internal.ServerError (ServerError, errBody, err500) newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a } deriving ( Functor, Applicative, Monad, MonadIO, Generic , MonadError ServerError , MonadThrow, MonadCatch, MonadMask ) instance MonadFail Handler where fail str = throwError err500 { errBody = fromString str } instance MonadBase IO Handler where liftBase = Handler . liftBase instance MonadBaseControl IO Handler where type StM Handler a = Either ServerError a -- liftBaseWith :: (RunInBase Handler IO -> IO a) -> Handler a liftBaseWith f = Handler (liftBaseWith (\g -> f (g . runHandler'))) -- restoreM :: StM Handler a -> Handler a restoreM st = Handler (restoreM st) runHandler :: Handler a -> IO (Either ServerError a) runHandler = runExceptT . runHandler' servant-server-0.19.2/src/Servant/Server/Internal/RouteResult.hs0000644000000000000000000000502307346545000023046 0ustar0000000000000000{-# 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 = 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 servant-server-0.19.2/src/Servant/Server/Internal/Router.hs0000644000000000000000000002212207346545000022030 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where import Prelude () import Prelude.Compat import Data.Function (on) import Data.List (nub) import Data.Map (Map) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T 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.ServerError type Router env = Router' env RoutingApplication data CaptureHint = CaptureHint { captureName :: Text , captureType :: TypeRep } 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 -- expected as extra input by the routers at the leaves. The -- environment is filled while running the router, with path -- components that can be used to process captures. -- data Router' env a = StaticRouter (Map Text (Router' env a)) [env -> a] -- ^ 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 [CaptureHint] (Router' (Text, env) a) -- ^ first path component is passed to the child router in its -- environment and removed afterwards | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a) -- ^ all path components are passed to the child router in its -- environment and are removed afterwards | RawRouter (env -> a) -- ^ to be used for routes we do not know anything about | Choice (Router' env a) (Router' env a) -- ^ left-biased choice between two routers deriving Functor -- | Smart constructor for a single static path component. pathRouter :: Text -> Router' env a -> Router' env a pathRouter t r = StaticRouter (M.singleton t r) [] -- | Smart constructor for a leaf, i.e., a router that expects -- the empty path. -- leafRouter :: (env -> a) -> Router' env a leafRouter l = StaticRouter M.empty [l] -- | Smart constructor for the choice between routers. -- We currently optimize the following cases: -- -- * Two static routers can be joined by joining their maps -- and concatenating their leaf-lists. -- * Two dynamic routers can be joined by joining their codomains. -- * Choice nodes can be reordered. -- 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 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 -- | Datatype used for representing and debugging the -- structure of a router. Abstracts from the handlers -- at the leaves. -- -- Two 'Router's can be structurally compared by computing -- their 'RouterStructure' using 'routerStructure' and -- then testing for equality, see 'sameStructure'. -- data RouterStructure = StaticRouterStructure (Map Text RouterStructure) Int | CaptureRouterStructure [CaptureHint] RouterStructure | RawRouterStructure | ChoiceStructure RouterStructure RouterStructure deriving (Eq, Show) -- | Compute the structure of a router. -- -- Assumes that the request or text being passed -- in 'WithRequest' or 'CaptureRouter' does not -- affect the structure of the underlying tree. -- routerStructure :: Router' env a -> RouterStructure routerStructure (StaticRouter m ls) = StaticRouterStructure (fmap routerStructure m) (length ls) routerStructure (CaptureRouter hints router) = CaptureRouterStructure hints $ routerStructure router routerStructure (CaptureAllRouter hints router) = CaptureRouterStructure hints $ routerStructure router routerStructure (RawRouter _) = RawRouterStructure routerStructure (Choice r1 r2) = ChoiceStructure (routerStructure r1) (routerStructure r2) -- | Compare the structure of two routers. -- sameStructure :: Router' env a -> Router' env b -> Bool sameStructure router1 router2 = routerStructure router1 == routerStructure router2 -- | Provide a textual representation of the -- structure of a router. -- routerLayout :: Router' env a -> Text routerLayout router = T.unlines (["/"] ++ mkRouterLayout False (routerStructure router)) where mkRouterLayout :: Bool -> RouterStructure -> [Text] mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n mkRouterLayout c (CaptureRouterStructure hints r) = mkSubTree c (toCaptureTags hints) (mkRouterLayout False r) mkRouterLayout c RawRouterStructure = if c then ["├─ "] else ["└─ "] mkRouterLayout c (ChoiceStructure r1 r2) = mkRouterLayout True r1 ++ ["┆"] ++ mkRouterLayout c r2 mkSubTrees :: Bool -> [(Text, RouterStructure)] -> Int -> [Text] mkSubTrees _ [] 0 = [] mkSubTrees c [] n = concat (replicate (n - 1) (mkLeaf True) ++ [mkLeaf c]) mkSubTrees c [(t, r)] 0 = mkSubTree c t (mkRouterLayout False r) mkSubTrees c ((t, r) : trs) n = mkSubTree True t (mkRouterLayout False r) ++ mkSubTrees c trs n mkLeaf :: Bool -> [Text] mkLeaf True = ["├─•","┆"] mkLeaf False = ["└─•"] mkSubTree :: Bool -> Text -> [Text] -> [Text] mkSubTree True path children = ("├─ " <> path <> "/") : map ("│ " <>) children mkSubTree False path children = ("└─ " <> path <> "/") : map (" " <>) children -- | Apply a transformation to the response of a `Router`. tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env -> Router env tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) -- | Interpret a router as an application. runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication runRouter fmt r = runRouterEnv fmt r () runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication runRouterEnv fmt router env request respond = case router of StaticRouter table ls -> case pathInfo request of [] -> runChoice fmt ls env request respond -- This case is to handle trailing slashes. [""] -> runChoice fmt ls env request respond first : rest | Just router' <- M.lookup first table -> let request' = request { pathInfo = rest } in runRouterEnv fmt router' env request' respond _ -> respond $ Fail $ fmt request CaptureRouter _ router' -> case pathInfo request of [] -> respond $ Fail $ fmt request -- This case is to handle trailing slashes. [""] -> respond $ Fail $ fmt request first : rest -> let request' = request { pathInfo = rest } in runRouterEnv fmt router' (first, env) request' respond CaptureAllRouter _ router' -> let segments = pathInfo request request' = request { pathInfo = [] } in runRouterEnv fmt router' (segments, env) request' respond RawRouter app -> app env request respond Choice r1 r2 -> 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 :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication runChoice fmt ls = case ls of [] -> \ _ request respond -> respond (Fail $ fmt request) [r] -> r (r : rs) -> \ env request respond -> r env request $ \ response1 -> case response1 of Fail _ -> runChoice fmt rs env request $ \ response2 -> respond $ highestPri response1 response2 _ -> respond response1 where highestPri (Fail e1) (Fail e2) = if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2) then Fail e2 else Fail e1 highestPri (Fail _) y = y highestPri x _ = x -- Priority on HTTP codes. -- worseHTTPCode :: Int -> Int -> Bool 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 servant-server-0.19.2/src/Servant/Server/Internal/RoutingApplication.hs0000644000000000000000000000154707346545000024373 0ustar0000000000000000module Servant.Server.Internal.RoutingApplication where import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude () import Prelude.Compat 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 toApplication :: RoutingApplication -> Application toApplication ra request respond = ra request routingRespond where routingRespond :: RouteResult Response -> IO ResponseReceived routingRespond (Fail err) = respond $ responseServerError err routingRespond (FailFatal err) = respond $ responseServerError err routingRespond (Route v) = respond v servant-server-0.19.2/src/Servant/Server/Internal/ServerError.hs0000644000000000000000000003167007346545000023040 0ustar0000000000000000{-# 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 = [] } -- | '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 = [] } servant-server-0.19.2/src/Servant/Server/StaticFiles.hs0000644000000000000000000000644307346545000021216 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | This module defines server-side handlers that lets you serve static files. -- -- The most common needs for a web application are covered by -- 'serveDirectoryWebApp`, but the other variants allow you to use -- different `StaticSettings` and 'serveDirectoryWith' even allows you -- to specify arbitrary 'StaticSettings' to be used for serving static files. module Servant.Server.StaticFiles ( serveDirectoryWebApp , serveDirectoryWebAppLookup , serveDirectoryFileServer , serveDirectoryEmbedded , serveDirectoryWith , -- * Deprecated serveDirectory ) where import Data.ByteString (ByteString) import Network.Wai.Application.Static import Servant.API.Raw (Raw) import Servant.Server (ServerT, Tagged (..)) import System.FilePath (addTrailingPathSeparator) import WaiAppStatic.Storage.Filesystem (ETagLookup) -- | Serve anything under the specified directory as a 'Raw' endpoint. -- -- @ -- type MyApi = "static" :> Raw -- -- server :: Server MyApi -- server = serveDirectoryWebApp "\/var\/www" -- @ -- -- would capture any request to @\/static\/\@ and look for -- @\@ under @\/var\/www@. -- -- It will do its best to guess the MIME type for that file, based on the extension, -- and send an appropriate /Content-Type/ header if possible. -- -- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API -- as a webapp backend, you will most likely not want the static files to be hidden -- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectoryWebApp' -- handler in the last position, because /servant/ will try to match the handlers -- in order. -- -- Corresponds to the `defaultWebAppSettings` `StaticSettings` value. serveDirectoryWebApp :: FilePath -> ServerT Raw m serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath -- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`. serveDirectoryFileServer :: FilePath -> ServerT Raw m serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath -- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'. serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> ServerT Raw m serveDirectoryWebAppLookup etag = serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath -- | Uses 'embeddedSettings'. serveDirectoryEmbedded :: [(FilePath, ByteString)] -> ServerT Raw m serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files) -- | Alias for 'staticApp'. Lets you serve a directory -- with arbitrary 'StaticSettings'. Useful when you want -- particular settings not covered by the four other -- variants. This is the most flexible method. serveDirectoryWith :: StaticSettings -> ServerT Raw m serveDirectoryWith = Tagged . staticApp -- | Same as 'serveDirectoryFileServer'. It used to be the only -- file serving function in servant pre-0.10 and will be kept -- around for a few versions, but is deprecated. serveDirectory :: FilePath -> ServerT Raw m serveDirectory = serveDirectoryFileServer {-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-} fixPath :: FilePath -> FilePath fixPath = addTrailingPathSeparator servant-server-0.19.2/src/Servant/Server/UVerb.hs0000644000000000000000000001165607346545000020031 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} {-# 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 Data.Proxy (Proxy (Proxy)) import Data.SOP (I (I)) import Data.SOP.Constraint (All, And) import Data.String.Conversions (LBS, cs) import Network.HTTP.Types (Status, HeaderName, hContentType) import Network.Wai (responseLBS, Request) import Servant.API (ReflectMethod, reflectMethod) 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 :: *) (xs :: [*]) (f :: * -> *). (Applicative f, HasStatus x, IsMember x xs) => x -> f (Union xs) respond = pure . inject . I class IsServerResource (cts :: [*]) a where resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS) 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 (LBS, LBS), [(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 (LBS, LBS), [(HeaderName, B.ByteString)]) pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts) case pickResource output of (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does (status, Just (contentT, body), headers) -> let bdy = if allowedMethodHead method request then "" else body in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy servant-server-0.19.2/src/Servant/Utils/0000755000000000000000000000000007346545000016273 5ustar0000000000000000servant-server-0.19.2/src/Servant/Utils/StaticFiles.hs0000644000000000000000000000027107346545000021041 0ustar0000000000000000module Servant.Utils.StaticFiles {-# DEPRECATED "Use Servant.Server.StaticFiles." #-} ( module Servant.Server.StaticFiles ) where import Servant.Server.StaticFiles servant-server-0.19.2/test/Servant/0000755000000000000000000000000007346545000015363 5ustar0000000000000000servant-server-0.19.2/test/Servant/ArbitraryMonadServerSpec.hs0000644000000000000000000000351207346545000022640 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Servant.ArbitraryMonadServerSpec where import Control.Monad.Reader import Data.Functor.Identity import Data.Proxy import Servant.API import Servant.Server import Test.Hspec (Spec, describe, it) import Test.Hspec.Wai (get, matchStatus, post, shouldRespondWith, with) spec :: Spec spec = describe "Arbitrary monad server" $ do enterSpec type ReaderAPI = "int" :> Get '[JSON] Int :<|> "string" :> Post '[JSON] String type IdentityAPI = "bool" :> Get '[JSON] Bool type CombinedAPI = ReaderAPI :<|> IdentityAPI readerAPI :: Proxy ReaderAPI readerAPI = Proxy identityAPI :: Proxy IdentityAPI identityAPI = Proxy combinedAPI :: Proxy CombinedAPI combinedAPI = Proxy readerServer' :: ServerT ReaderAPI (Reader String) readerServer' = return 1797 :<|> ask fReader :: Reader String a -> Handler a fReader x = return (runReader x "hi") readerServer :: Server ReaderAPI readerServer = hoistServer readerAPI fReader readerServer' combinedReaderServer' :: ServerT CombinedAPI (Reader String) combinedReaderServer' = readerServer' :<|> hoistServer identityAPI (return . runIdentity) (return True) combinedReaderServer :: Server CombinedAPI combinedReaderServer = hoistServer combinedAPI fReader combinedReaderServer' enterSpec :: Spec enterSpec = describe "Enter" $ do with (return (serve readerAPI readerServer)) $ do it "allows running arbitrary monads" $ do get "int" `shouldRespondWith` "1797" post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 } with (return (serve combinedAPI combinedReaderServer)) $ do it "allows combnation of enters" $ do get "bool" `shouldRespondWith` "true" servant-server-0.19.2/test/Servant/HoistSpec.hs0000644000000000000000000000200407346545000017614 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} module Servant.HoistSpec where import Test.Hspec (Spec) import Servant ------------------------------------------------------------------------------- -- https://github.com/haskell-servant/servant/issues/734 ------------------------------------------------------------------------------- -- This didn't fail if executed in GHCi; cannot have as a doctest. newtype App a = App a type API = Get '[JSON] Int :<|> ReqBody '[JSON] String :> Get '[JSON] Bool api :: Proxy API api = Proxy server :: App Int :<|> (String -> App Bool) server = undefined -- Natural transformation still seems to need an explicit type. f :: App a -> App a f = id server' :: App Int :<|> (String -> App Bool) server' = hoistServer api f server ------------------------------------------------------------------------------- -- Spec ------------------------------------------------------------------------------- spec :: Spec spec = return () servant-server-0.19.2/test/Servant/Server/0000755000000000000000000000000007346545000016631 5ustar0000000000000000servant-server-0.19.2/test/Servant/Server/ErrorSpec.hs0000644000000000000000000003254607346545000021103 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Server.ErrorSpec (spec) where 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.Proxy import Data.String.Conversions (cs) import Network.HTTP.Types (hAccept, hAuthorization, hContentType, methodGet, methodPost, methodPut) import Safe (readMay) import Test.Hspec import Test.Hspec.Wai import Servant spec :: Spec spec = describe "HTTP Errors" $ do errorOrderSpec prioErrorsSpec errorRetrySpec errorChoiceSpec customFormattersSpec -- * Auth machinery (reused throughout) -- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password. errorOrderAuthCheck :: BasicAuthCheck () errorOrderAuthCheck = let check (BasicAuthData username password) = if username == "servant" && password == "server" then return (Authorized ()) else return Unauthorized in BasicAuthCheck check ------------------------------------------------------------------------------ -- * Error Order {{{ type ErrorOrderApi = "home" :> BasicAuth "error-realm" () :> ReqBody '[JSON] Int :> Capture "t" Int :> QueryParam "param" Int :> Post '[JSON] Int errorOrderApi :: Proxy ErrorOrderApi errorOrderApi = Proxy errorOrderServer :: Server ErrorOrderApi errorOrderServer = \_ _ _ _ -> throwError err402 -- On error priorities: -- -- We originally had -- -- 404, 405, 401, 415, 400, 406, 402 -- -- but we changed this to -- -- 404, 405, 401, 406, 415, 400, 402 -- -- for servant-0.7. -- -- This change is due to the body check being irreversible (to support -- streaming). Any check done after the body check has to be made fatal, -- breaking modularity. We've therefore moved the accept check before -- the body check, to allow it being recoverable and modular, and this -- goes along with promoting the error priority of 406. errorOrderSpec :: Spec errorOrderSpec = describe "HTTP error order" $ with (return $ serveWithContext errorOrderApi (errorOrderAuthCheck :. EmptyContext) errorOrderServer ) $ do let badContentType = (hContentType, "text/plain") badAccept = (hAccept, "text/plain") badMethod = methodGet badUrl = "nonexistent" badBody = "nonsense" badAuth = (hAuthorization, "Basic foofoofoo") goodContentType = (hContentType, "application/json") goodAccept = (hAccept, "application/json") goodMethod = methodPost goodUrl = "home/2?param=55" badParams = goodUrl <> "?param=foo" goodBody = encode (5 :: Int) -- username:password = servant:server goodAuth = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=") it "has 404 as its highest priority error" $ do request badMethod badUrl [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 404 it "has 405 as its second highest priority error" $ do request badMethod badParams [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 405 it "has 401 as its third highest priority error (auth)" $ do request goodMethod badParams [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 401 it "has 406 as its fourth highest priority error" $ do request goodMethod badParams [goodAuth, badContentType, badAccept] badBody `shouldRespondWith` 406 it "has 415 as its fifth highest priority error" $ do request goodMethod badParams [goodAuth, badContentType, goodAccept] badBody `shouldRespondWith` 415 it "has 400 as its sixth highest priority error" $ do badParamsRes <- request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody badBodyRes <- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody -- Both bad body and bad params result in 400 return badParamsRes `shouldRespondWith` 400 return badBodyRes `shouldRespondWith` 400 -- Param check should occur before body checks both <- request goodMethod badParams [goodAuth, goodContentType, goodAccept ] badBody when (both /= badParamsRes) $ liftIO $ expectationFailure $ "badParams + badBody /= badParams: " ++ show both ++ ", " ++ show badParamsRes when (both == badBodyRes) $ liftIO $ expectationFailure $ "badParams + badBody == badBody: " ++ show both it "has handler-level errors as last priority" $ do request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody `shouldRespondWith` 402 type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer prioErrorsApi :: Proxy PrioErrorsApi prioErrorsApi = Proxy -- Check whether matching continues even if a 'ReqBody' or similar construct -- is encountered early in a path. We don't want to see a complaint about the -- request body unless the path actually matches. prioErrorsSpec :: Spec prioErrorsSpec = describe "PrioErrors" $ do let server = return with (return $ serve prioErrorsApi server) $ do let check (mdescr, method) path (cdescr, ctype, body) resp = it fulldescr $ Test.Hspec.Wai.request method path [(hContentType, ctype)] body `shouldRespondWith` resp where fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr ++ " " ++ BC.unpack path ++ " (" ++ cdescr ++ ")" get' = ("GET", methodGet) put' = ("PUT", methodPut) txt = ("text" , "text/plain;charset=utf8" , "42" ) ijson = ("invalid json", "application/json;charset=utf8", "invalid" ) vjson = ("valid json" , "application/json;charset=utf8", encode (5 :: Int)) check get' "/" txt 404 check get' "/bar" txt 404 check get' "/foo" txt 415 check put' "/" txt 404 check put' "/bar" txt 404 check put' "/foo" txt 405 check get' "/" ijson 404 check get' "/bar" ijson 404 check get' "/foo" ijson 400 check put' "/" ijson 404 check put' "/bar" ijson 404 check put' "/foo" ijson 405 check get' "/" vjson 404 check get' "/bar" vjson 404 check get' "/foo" vjson 200 check put' "/" vjson 404 check put' "/bar" vjson 404 check put' "/foo" vjson 405 -- }}} ------------------------------------------------------------------------------ -- * Error Retry {{{ type ErrorRetryApi = "a" :> ReqBody '[JSON] Int :> Post '[JSON] Int -- err402 :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int -- 1 :<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2 :<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3 :<|> "a" :> ReqBody '[JSON] Int :> Get '[JSON] Int -- 4 :<|> "a" :> BasicAuth "bar-realm" () :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5 :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 6 :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 7 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 8 errorRetryApi :: Proxy ErrorRetryApi errorRetryApi = Proxy errorRetryServer :: Server ErrorRetryApi errorRetryServer = (\_ -> throwError err402) :<|> (\_ -> return 1) :<|> (\_ -> return 2) :<|> (\_ -> return 3) :<|> (\_ -> return 4) :<|> (\_ _ -> return 5) :<|> (\_ -> return 6) :<|> (\_ -> return 7) :<|> (\_ -> return 8) errorRetrySpec :: Spec errorRetrySpec = describe "Handler search" $ with (return $ serveWithContext errorRetryApi (errorOrderAuthCheck :. EmptyContext) errorRetryServer ) $ do let jsonCT = (hContentType, "application/json") jsonAccept = (hAccept, "application/json") jsonBody = encode (1797 :: Int) it "should continue when URLs don't match" $ do request methodPost "" [jsonCT, jsonAccept] jsonBody `shouldRespondWith` 200 { matchBody = mkBody $ encode (8 :: Int) } it "should continue when methods don't match" $ do request methodGet "a" [jsonCT, jsonAccept] jsonBody `shouldRespondWith` 200 { matchBody = mkBody $ encode (4 :: Int) } where mkBody b = MatchBody $ \_ b' -> if b == b' then Nothing else Just "body not correct\n" -- }}} ------------------------------------------------------------------------------ -- * Error Choice {{{ type ErrorChoiceApi = "path0" :> Get '[JSON] Int -- 0 :<|> "path1" :> Post '[JSON] Int -- 1 :<|> "path2" :> Post '[PlainText] Int -- 2 :<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 3 :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- 4 :<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- 5 :<|> "path5" :> (ReqBody '[JSON] Int :> Post '[PlainText] Int -- 6 :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- 7 errorChoiceApi :: Proxy ErrorChoiceApi errorChoiceApi = Proxy errorChoiceServer :: Server ErrorChoiceApi errorChoiceServer = return 0 :<|> return 1 :<|> return 2 :<|> (\_ -> return 3) :<|> ((\_ -> return 4) :<|> (\_ -> return 5)) :<|> ((\_ -> return 6) :<|> (\_ -> return 7)) errorChoiceSpec :: Spec errorChoiceSpec = describe "Multiple handlers return errors" $ with (return $ serve errorChoiceApi errorChoiceServer) $ do it "should respond with 404 if no path matches" $ do request methodGet "" [] "" `shouldRespondWith` 404 it "should respond with 405 if a path but not method matches" $ do request methodGet "path2" [] "" `shouldRespondWith` 405 it "should respond with the corresponding error if path and method match" $ do request methodPost "path3" [(hContentType, "text/plain;charset=utf-8")] "" `shouldRespondWith` 415 request methodPost "path3" [(hContentType, "application/json")] "" `shouldRespondWith` 400 request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"), (hAccept, "blah")] "5" `shouldRespondWith` 406 it "should respond with 415 only if none of the subservers supports the request's content type" $ do request methodPost "path5" [(hContentType, "text/plain;charset=utf-8")] "1" `shouldRespondWith` 200 request methodPost "path5" [(hContentType, "application/json")] "1" `shouldRespondWith` 200 request methodPost "path5" [(hContentType, "application/not-supported")] "" `shouldRespondWith` 415 -- }}} ------------------------------------------------------------------------------ -- * Custom errors {{{ customFormatter :: ErrorFormatter customFormatter _ _ err = err400 { errBody = "CUSTOM! " <> cs 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!" `BCL.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) instance MimeRender PlainText Int where mimeRender _ = BCL.pack . show -- }}} servant-server-0.19.2/test/Servant/Server/Internal/0000755000000000000000000000000007346545000020405 5ustar0000000000000000servant-server-0.19.2/test/Servant/Server/Internal/ContextSpec.hs0000644000000000000000000000463207346545000023205 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# 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, context, describe, it, shouldBe) import Test.ShouldNotTypecheck (shouldNotTypecheck) import Servant.API import Servant.Server.Internal.Context spec :: Spec spec = do describe "getContextEntry" $ do it "gets the context if a matching one exists" $ do let cxt = 'a' :. EmptyContext getContextEntry cxt `shouldBe` 'a' it "gets the first matching context" $ do let cxt = 'a' :. 'b' :. EmptyContext getContextEntry cxt `shouldBe` 'a' it "does not typecheck if type does not exist" $ do let cxt = 'a' :. EmptyContext x = getContextEntry cxt :: Bool shouldNotTypecheck x context "Show instance" $ do it "has a Show instance" $ do let cxt = 'a' :. True :. EmptyContext show cxt `shouldBe` "'a' :. True :. EmptyContext" context "bracketing" $ do it "works" $ do let cxt = 'a' :. True :. EmptyContext show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)" it "works with operators" $ do let cxt = (1 :: Integer) :. 'a' :. EmptyContext :<|> 'b' :. True :. EmptyContext show cxt `shouldBe` "1 :. 'a' :. EmptyContext :<|> 'b' :. True :. EmptyContext" describe "descendIntoNamedContext" $ do let cxt :: Context [Char, NamedContext "sub" '[Char]] cxt = 'a' :. (NamedContext subContext :: NamedContext "sub" '[Char]) :. EmptyContext subContext = 'b' :. EmptyContext it "allows extracting subcontexts" $ do descendIntoNamedContext (Proxy :: Proxy "sub") cxt `shouldBe` subContext it "allows extracting entries from subcontexts" $ do getContextEntry (descendIntoNamedContext (Proxy :: Proxy "sub") cxt :: Context '[Char]) `shouldBe` 'b' it "does not typecheck if subContext has the wrong type" $ do let x = descendIntoNamedContext (Proxy :: Proxy "sub") cxt :: Context '[Int] shouldNotTypecheck (show x) it "does not typecheck if subContext with that name doesn't exist" $ do let x = descendIntoNamedContext (Proxy :: Proxy "foo") cxt :: Context '[Char] shouldNotTypecheck (show x) servant-server-0.19.2/test/Servant/Server/Internal/RoutingApplicationSpec.hs0000644000000000000000000001223207346545000025367 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Servant.Server.Internal.RoutingApplicationSpec (spec) where import Prelude () import Prelude.Compat import Control.Exception hiding (Handler) import Control.Monad.IO.Class import Control.Monad.Trans.Resource (register) import Data.IORef import Data.Proxy import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import Network.Wai (defaultRequest) import Servant import Servant.Server.Internal import Test.Hspec import Test.Hspec.Wai (request, shouldRespondWith, with) import qualified Data.Text as T import System.IO.Unsafe (unsafePerformIO) data TestResource x = TestResourceNone | TestResource x | TestResourceFreed | TestResourceError deriving (Eq, Show) -- Let's not write to the filesystem delayedTestRef :: IORef (TestResource String) delayedTestRef = unsafePerformIO $ newIORef TestResourceNone fromTestResource :: a -> (b -> a) -> TestResource b -> a fromTestResource _ f (TestResource x) = f x fromTestResource x _ _ = x initTestResource :: IO () initTestResource = writeIORef delayedTestRef TestResourceNone writeTestResource :: String -> IO () writeTestResource x = modifyIORef delayedTestRef $ \r -> case r of TestResourceNone -> TestResource x _ -> TestResourceError freeTestResource :: IO () freeTestResource = modifyIORef delayedTestRef $ \r -> case r of TestResource _ -> TestResourceFreed _ -> TestResourceError delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ()) delayed body srv = Delayed { capturesD = \() -> return () , methodD = return () , authD = return () , acceptD = return () , contentD = return () , paramsD = return () , headersD = return () , bodyD = \() -> do liftIO (writeTestResource "hia" >> putStrLn "garbage created") _ <- register (freeTestResource >> putStrLn "garbage collected") body , serverD = \() () () () _body _req -> srv } simpleRun :: Delayed () (Handler ()) -> IO () simpleRun d = fmap (either ignoreE id) . try $ runAction d () defaultRequest (\_ -> return ()) (\_ -> FailFatal err500) where ignoreE :: SomeException -> () ignoreE = const () ------------------------------------------------------------------------------- -- Combinator example ------------------------------------------------------------------------------- -- | This data types writes 'sym' to 'delayedTestRef'. data Res (sym :: Symbol) instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m hoistServerWithContext _ nc nt s = hoistServerWithContext (Proxy :: Proxy api) nc nt . s route Proxy ctx server = route (Proxy :: Proxy api) ctx $ addBodyCheck server (return ()) check where sym = symbolVal (Proxy :: Proxy sym) check () = do liftIO $ writeTestResource sym _ <- register freeTestResource return delayedTestRef type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text resApi :: Proxy ResApi resApi = Proxy resServer :: Server ResApi resServer ref = liftIO $ fmap (fromTestResource "" T.pack) $ readIORef ref ------------------------------------------------------------------------------- -- Spec ------------------------------------------------------------------------------- spec :: Spec spec = do describe "Delayed" $ do it "actually runs clean up actions" $ do liftIO initTestResource _ <- simpleRun $ delayed (return ()) (Route $ return ()) res <- readIORef delayedTestRef res `shouldBe` TestResourceFreed it "even with exceptions in serverD" $ do liftIO initTestResource _ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero) res <- readIORef delayedTestRef res `shouldBe` TestResourceFreed it "even with routing failure in bodyD" $ do liftIO initTestResource _ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ()) res <- readIORef delayedTestRef res `shouldBe` TestResourceFreed it "even with exceptions in bodyD" $ do liftIO initTestResource _ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ()) res <- readIORef delayedTestRef res `shouldBe` TestResourceFreed describe "ResApi" $ with (return $ serve resApi resServer) $ do it "writes and cleanups resources" $ do liftIO initTestResource request "GET" "foobar" [] "" `shouldRespondWith` "foobar" liftIO $ do res <- readIORef delayedTestRef res `shouldBe` TestResourceFreed servant-server-0.19.2/test/Servant/Server/RouterSpec.hs0000644000000000000000000003270307346545000021265 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Servant.Server.RouterSpec (spec) where 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 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 "") [] "") twk :: Response -> Response twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b twk b = b 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 it "distributes endpoints through static paths" $ do endpoint `shouldHaveSameStructureAs` endpointRef it "distributes nested routes through static paths" $ do static `shouldHaveSameStructureAs` staticRef it "distributes nested routes through dynamic paths" $ do dynamic `shouldHaveSameStructureAs` dynamicRef it "properly reorders permuted static paths" $ do permute `shouldHaveSameStructureAs` permuteRef it "properly reorders permuted static paths in the presence of QueryParams" $ do permuteQuery `shouldHaveSameStructureAs` permuteRef it "properly reorders permuted static paths in the presence of Raw in end" $ do permuteRawEnd `shouldHaveSameStructureAs` permuteRawEndRef it "properly reorders permuted static paths in the presence of Raw in beginning" $ do permuteRawBegin `shouldHaveSameStructureAs` permuteRawBeginRef it "properly reorders permuted static paths in the presence of Raw in middle" $ do permuteRawMiddle `shouldHaveSameStructureAs` permuteRawMiddleRef it "properly reorders permuted static paths in the presence of a root endpoint in end" $ do permuteEndEnd `shouldHaveSameStructureAs` permuteEndRef it "properly reorders permuted static paths in the presence of a root endpoint in beginning" $ do permuteEndBegin `shouldHaveSameStructureAs` permuteEndRef it "properly reorders permuted static paths in the presence of a root endpoint in middle" $ do permuteEndMiddle `shouldHaveSameStructureAs` permuteEndRef 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)) type End = Get '[JSON] NoContent -- The latter version looks more efficient, -- but the former should be compiled to the -- same layout: type Endpoint = "a" :> End :<|> "a" :> End type EndpointRef = "a" :> (End :<|> End) endpoint :: Proxy Endpoint endpoint = Proxy endpointRef :: Proxy EndpointRef endpointRef = Proxy -- Again, the latter version looks more efficient, -- but the former should be compiled to the same -- layout: type Static = "a" :> "b" :> End :<|> "a" :> "c" :> End type StaticRef = "a" :> ("b" :> End :<|> "c" :> End) static :: Proxy Static static = Proxy staticRef :: Proxy StaticRef staticRef = Proxy -- Even for dynamic path components, we expect the -- router to simplify the layout, because captures -- are delayed and only actually performed once -- reaching an endpoint. So the former version and -- the latter should be compiled to the same router -- structure: type Dynamic = "a" :> Capture "foo" Int :> "b" :> End :<|> "a" :> Capture "foo" Int :> "c" :> End :<|> "a" :> Capture "foo" Int :> "d" :> End type DynamicRef = "a" :> Capture "foo" Int :> ("b" :> End :<|> "c" :> End :<|> "d" :> End) dynamic :: Proxy Dynamic dynamic = Proxy dynamicRef :: Proxy DynamicRef dynamicRef = Proxy -- A more complicated example of static route reordering. -- All the permuted paths should be correctly grouped, -- so both 'Permute' and 'PermuteRef' should compile to -- the same layout: type Permute = "a" :> "b" :> "c" :> End :<|> "b" :> "a" :> "c" :> End :<|> "a" :> "c" :> "b" :> End :<|> "c" :> "a" :> "b" :> End :<|> "b" :> "c" :> "a" :> End :<|> "c" :> "b" :> "a" :> End type PermuteRef = "a" :> ( "b" :> "c" :> End :<|> "c" :> "b" :> End ) :<|> "b" :> ( "a" :> "c" :> End :<|> "c" :> "a" :> End ) :<|> "c" :> ( "a" :> "b" :> End :<|> "b" :> "a" :> End ) permute :: Proxy Permute permute = Proxy permuteRef :: Proxy PermuteRef permuteRef = Proxy -- Adding a "QueryParam" should not affect structure type PermuteQuery = QueryParam "1" Int :> "a" :> "b" :> "c" :> End :<|> QueryParam "2" Int :> "b" :> "a" :> "c" :> End :<|> QueryParam "3" Int :> "a" :> "c" :> "b" :> End :<|> QueryParam "4" Int :> "c" :> "a" :> "b" :> End :<|> QueryParam "5" Int :> "b" :> "c" :> "a" :> End :<|> QueryParam "6" Int :> "c" :> "b" :> "a" :> End permuteQuery :: Proxy PermuteQuery permuteQuery = Proxy -- Adding a 'Raw' in one of the ends should have minimal -- effect on the grouping. type PermuteRawEnd = "a" :> "b" :> "c" :> End :<|> "b" :> "a" :> "c" :> End :<|> "a" :> "c" :> "b" :> End :<|> "c" :> "a" :> "b" :> End :<|> "b" :> "c" :> "a" :> End :<|> "c" :> "b" :> "a" :> End :<|> Raw type PermuteRawEndRef = PermuteRef :<|> Raw type PermuteRawBegin = Raw :<|> "a" :> "b" :> "c" :> End :<|> "b" :> "a" :> "c" :> End :<|> "a" :> "c" :> "b" :> End :<|> "c" :> "a" :> "b" :> End :<|> "b" :> "c" :> "a" :> End :<|> "c" :> "b" :> "a" :> End type PermuteRawBeginRef = Raw :<|> PermuteRef permuteRawBegin :: Proxy PermuteRawBegin permuteRawBegin = Proxy permuteRawBeginRef :: Proxy PermuteRawBeginRef permuteRawBeginRef = Proxy permuteRawEnd :: Proxy PermuteRawEnd permuteRawEnd = Proxy permuteRawEndRef :: Proxy PermuteRawEndRef permuteRawEndRef = Proxy -- Adding a 'Raw' in the middle will disrupt grouping, -- because we commute things past a 'Raw'. But the two -- halves should still be grouped. type PermuteRawMiddle = "a" :> "b" :> "c" :> End :<|> "b" :> "a" :> "c" :> End :<|> "a" :> "c" :> "b" :> End :<|> Raw :<|> "c" :> "a" :> "b" :> End :<|> "b" :> "c" :> "a" :> End :<|> "c" :> "b" :> "a" :> End type PermuteRawMiddleRef = "a" :> ( "b" :> "c" :> End :<|> "c" :> "b" :> End ) :<|> "b" :> "a" :> "c" :> End :<|> Raw :<|> "b" :> "c" :> "a" :> End :<|> "c" :> ( "a" :> "b" :> End :<|> "b" :> "a" :> End ) permuteRawMiddle :: Proxy PermuteRawMiddle permuteRawMiddle = Proxy permuteRawMiddleRef :: Proxy PermuteRawMiddleRef permuteRawMiddleRef = Proxy -- Adding an endpoint at the top-level in various places -- is also somewhat critical for grouping, but it should -- not disrupt grouping at all, even if it is placed in -- the middle. type PermuteEndEnd = "a" :> "b" :> "c" :> End :<|> "b" :> "a" :> "c" :> End :<|> "a" :> "c" :> "b" :> End :<|> "c" :> "a" :> "b" :> End :<|> "b" :> "c" :> "a" :> End :<|> "c" :> "b" :> "a" :> End :<|> End type PermuteEndBegin = End :<|> "a" :> "b" :> "c" :> End :<|> "b" :> "a" :> "c" :> End :<|> "a" :> "c" :> "b" :> End :<|> "c" :> "a" :> "b" :> End :<|> "b" :> "c" :> "a" :> End :<|> "c" :> "b" :> "a" :> End type PermuteEndMiddle = "a" :> "b" :> "c" :> End :<|> "b" :> "a" :> "c" :> End :<|> "a" :> "c" :> "b" :> End :<|> End :<|> "c" :> "a" :> "b" :> End :<|> "b" :> "c" :> "a" :> End :<|> "c" :> "b" :> "a" :> End type PermuteEndRef = PermuteRef :<|> End permuteEndEnd :: Proxy PermuteEndEnd permuteEndEnd = Proxy permuteEndBegin :: Proxy PermuteEndBegin permuteEndBegin = Proxy permuteEndMiddle :: Proxy PermuteEndMiddle permuteEndMiddle = Proxy permuteEndRef :: Proxy PermuteEndRef permuteEndRef = Proxy -- An API with routes on different nesting levels that -- is composed out of different fragments should still -- be reordered correctly. type LevelFragment1 = "a" :> "b" :> End :<|> "a" :> End type LevelFragment2 = "b" :> End :<|> "a" :> "c" :> End :<|> End type Level = LevelFragment1 :<|> LevelFragment2 type LevelRef = "a" :> ("b" :> End :<|> "c" :> End :<|> End) :<|> "b" :> End :<|> End level :: Proxy Level level = Proxy 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\ \│ └─ /\n\ \│ ├─•\n\ \│ ┆\n\ \│ └─•\n\ \├─ c/\n\ \│ └─•\n\ \┆\n\ \└─ \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\ \ └─ /\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\ \ └─ /\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\ \ └─ /\n\ \ └─•\n" servant-server-0.19.2/test/Servant/Server/StaticFilesSpec.hs0000644000000000000000000000414307346545000022214 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Server.StaticFilesSpec where import Control.Exception (bracket) import Data.Proxy (Proxy (Proxy)) import Network.Wai (Application) import System.Directory (createDirectory, getCurrentDirectory, setCurrentDirectory) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec (Spec, around_, describe, it) import Test.Hspec.Wai (get, shouldRespondWith, with) import Servant.API ((:<|>) ((:<|>)), (:>), Capture, Get, JSON, Raw) import Servant.Server (Server, serve) import Servant.Server.StaticFiles (serveDirectoryFileServer) import Servant.ServerSpec (Person (Person)) type Api = "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person :<|> "static" :> Raw api :: Proxy Api api = Proxy app :: Application app = serve api server server :: Server Api server = (\ name_ -> return (Person name_ 42)) :<|> serveDirectoryFileServer "static" withStaticFiles :: IO () -> IO () withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir -> bracket (setup tmpDir) teardown (const action) where setup tmpDir = do outer <- getCurrentDirectory setCurrentDirectory tmpDir createDirectory "static" writeFile "static/foo.txt" "bar" writeFile "static/index.html" "index" return outer teardown outer = do setCurrentDirectory outer spec :: Spec spec = do around_ withStaticFiles $ with (return app) $ do describe "serveDirectory" $ do it "successfully serves files" $ do get "/static/foo.txt" `shouldRespondWith` "bar" it "serves the contents of index.html when requesting the root of a directory" $ do get "/static/" `shouldRespondWith` "index" servant-server-0.19.2/test/Servant/Server/StreamingSpec.hs0000644000000000000000000000651007346545000021733 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# 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.Monad.IO.Class import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy import Network.HTTP.Types import Network.Wai import Network.Wai.Internal import Prelude () import Prelude.Compat import Servant import qualified System.Timeout import Test.Hspec type TestAPI = ReqBody '[OctetStream] Lazy.ByteString :> Get '[JSON] NoContent testAPI :: Proxy TestAPI testAPI = Proxy spec :: Spec spec = do -- The idea of this test is this: -- -- - The mock client will -- - send some data in the request body, but not all, -- - wait for the server to acknowledge (outside of http, through an MVar) -- that the server received some data, -- - send the rest of the request body. -- - The mock server will -- - receive some data, -- - notify the client that it received some data, -- - receive the rest of the data, -- - respond with an empty result. it "client to server can stream lazy ByteStrings" $ timeout $ do serverReceivedFirstChunk <- newWaiter -- - streams some test data -- - waits for serverReceivedFirstChunk -- - streams some more test data streamTestData <- do mvar :: MVar [IO Strict.ByteString] <- newMVar $ map return (replicate 1000 "foo") ++ (waitFor serverReceivedFirstChunk >> return "foo") : map return (replicate 1000 "foo") return $ modifyMVar mvar $ \ actions -> case actions of (a : r) -> (r, ) <$> a [] -> return ([], "") let request = defaultRequest { requestBody = streamTestData, requestBodyLength = ChunkedBody } -- - receives the first chunk -- - notifies serverReceivedFirstChunk -- - receives the rest of the request let handler :: Lazy.ByteString -> Handler NoContent handler input = liftIO $ do let prefix = Lazy.take 3 input prefix `shouldBe` "foo" notify serverReceivedFirstChunk () input `shouldBe` mconcat (replicate 2001 "foo") return NoContent app = serve testAPI handler response <- executeRequest app request statusCode (responseStatus response) `shouldBe` 200 executeRequest :: Application -> Request -> IO Response executeRequest app request = do responseMVar <- newEmptyMVar let respond response = do putMVar responseMVar response return ResponseReceived ResponseReceived <- app request respond takeMVar responseMVar timeout :: IO a -> IO a timeout action = do result <- System.Timeout.timeout 1000000 action maybe (throwIO $ ErrorCall "timeout") return result -- * waiter data Waiter a = Waiter { notify :: a -> IO (), waitFor :: IO a } newWaiter :: IO (Waiter a) newWaiter = do mvar <- newEmptyMVar return $ Waiter { notify = putMVar mvar, waitFor = readMVar mvar } servant-server-0.19.2/test/Servant/Server/UsingContextSpec.hs0000644000000000000000000000716307346545000022441 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Servant.Server.UsingContextSpec where import Network.Wai import Test.Hspec (Spec, describe, it) import Test.Hspec.Wai import Servant import Servant.Server.UsingContextSpec.TestCombinators spec :: Spec spec = do spec1 spec2 spec3 spec4 -- * API type OneEntryAPI = ExtractFromContext :> Get '[JSON] String testServer :: String -> Handler String testServer s = return s oneEntryApp :: Application oneEntryApp = serveWithContext (Proxy :: Proxy OneEntryAPI) context testServer where context :: Context '[String] context = "contextEntry" :. EmptyContext type OneEntryTwiceAPI = "foo" :> ExtractFromContext :> Get '[JSON] String :<|> "bar" :> ExtractFromContext :> Get '[JSON] String oneEntryTwiceApp :: Application oneEntryTwiceApp = serveWithContext (Proxy :: Proxy OneEntryTwiceAPI) context $ testServer :<|> testServer where context :: Context '[String] context = "contextEntryTwice" :. EmptyContext -- * tests spec1 :: Spec spec1 = do describe "accessing context entries from custom combinators" $ do with (return oneEntryApp) $ do it "allows retrieving a ContextEntry" $ do get "/" `shouldRespondWith` "\"contextEntry\"" with (return oneEntryTwiceApp) $ do it "allows retrieving the same ContextEntry twice" $ do get "/foo" `shouldRespondWith` "\"contextEntryTwice\"" get "/bar" `shouldRespondWith` "\"contextEntryTwice\"" type InjectAPI = InjectIntoContext :> "untagged" :> ExtractFromContext :> Get '[JSON] String :<|> InjectIntoContext :> "tagged" :> ExtractFromContext :> Get '[JSON] String injectApp :: Application injectApp = serveWithContext (Proxy :: Proxy InjectAPI) context $ (\ s -> return s) :<|> (\ s -> return ("tagged: " ++ s)) where context = EmptyContext spec2 :: Spec spec2 = do with (return injectApp) $ do describe "inserting context entries with custom combinators" $ do it "allows to inject context entries" $ do get "/untagged" `shouldRespondWith` "\"injected\"" it "allows to inject tagged context entries" $ do get "/tagged" `shouldRespondWith` "\"tagged: injected\"" type WithBirdfaceAPI = "foo" :> ExtractFromContext :> Get '[JSON] String :<|> NamedContextWithBirdface "sub" '[String] :> "bar" :> ExtractFromContext :> Get '[JSON] String withBirdfaceApp :: Application withBirdfaceApp = serveWithContext (Proxy :: Proxy WithBirdfaceAPI) context $ testServer :<|> testServer where context :: Context '[String, (NamedContext "sub" '[String])] context = "firstEntry" :. (NamedContext ("secondEntry" :. EmptyContext)) :. EmptyContext spec3 :: Spec spec3 = do with (return withBirdfaceApp) $ do it "allows retrieving different ContextEntries for the same combinator" $ do get "/foo" `shouldRespondWith` "\"firstEntry\"" get "/bar" `shouldRespondWith` "\"secondEntry\"" type NamedContextAPI = WithNamedContext "sub" '[String] ( ExtractFromContext :> Get '[JSON] String) namedContextApp :: Application namedContextApp = serveWithContext (Proxy :: Proxy NamedContextAPI) context return where context :: Context '[NamedContext "sub" '[String]] context = NamedContext ("descend" :. EmptyContext) :. EmptyContext spec4 :: Spec spec4 = do with (return namedContextApp) $ do describe "WithNamedContext" $ do it "allows descending into a subcontext for a given api" $ do get "/" `shouldRespondWith` "\"descend\"" servant-server-0.19.2/test/Servant/Server/UsingContextSpec/0000755000000000000000000000000007346545000022076 5ustar0000000000000000servant-server-0.19.2/test/Servant/Server/UsingContextSpec/TestCombinators.hs0000644000000000000000000000504507346545000025556 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | These are custom combinators for Servant.Server.UsingContextSpec. -- -- (For writing your own combinators you need to import Internal modules, for -- just *using* combinators that require a Context, you don't. This module is -- separate from Servant.Server.UsingContextSpec to test that the module imports -- work out this way.) module Servant.Server.UsingContextSpec.TestCombinators where import GHC.TypeLits import Servant data ExtractFromContext instance (HasContextEntry context String, HasServer subApi context) => HasServer (ExtractFromContext :> subApi) context where type ServerT (ExtractFromContext :> subApi) m = String -> ServerT subApi m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy subApi) pc nt . s route Proxy context delayed = route subProxy context (fmap inject delayed) where subProxy :: Proxy subApi subProxy = Proxy inject f = f (getContextEntry context) data InjectIntoContext instance (HasServer subApi (String ': context)) => HasServer (InjectIntoContext :> subApi) context where type ServerT (InjectIntoContext :> subApi) m = ServerT subApi m hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy (String ': context)) nt s route Proxy context delayed = route subProxy newContext delayed where subProxy :: Proxy subApi subProxy = Proxy newContext = ("injected" :: String) :. context data NamedContextWithBirdface (name :: Symbol) (subContext :: [*]) instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) => HasServer (NamedContextWithBirdface name subContext :> subApi) context where type ServerT (NamedContextWithBirdface name subContext :> subApi) m = ServerT subApi m hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s route Proxy context delayed = route subProxy subContext delayed where subProxy :: Proxy subApi subProxy = Proxy subContext :: Context subContext subContext = descendIntoNamedContext (Proxy :: Proxy name) context servant-server-0.19.2/test/Servant/ServerSpec.hs0000644000000000000000000010545507346545000020012 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -freduction-depth=100 #-} module Servant.ServerSpec where import Prelude () import Prelude.Compat import Control.Monad (forM_, unless, when) import Control.Monad.Error.Class (MonadError (..)) import Data.Aeson (FromJSON, ToJSON, decode', encode) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as Base64 import Data.Char (toUpper) import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (Proxy)) import Data.String (fromString) import Data.String.Conversions (cs) import qualified Data.Text as T import GHC.Generics (Generic) import Network.HTTP.Types (QueryItem, Status (..), hAccept, hContentType, imATeapot418, methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut, ok200, parseQuery) import Network.Wai (Application, Middleware, Request, pathInfo, queryString, rawQueryString, requestHeaders, responseLBS) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody, simpleHeaders, simpleStatus) import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header, Headers, HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict, UVerb, Union, Verb, WithStatus (..), addHeader) import Servant.Server (Context ((:.), EmptyContext), Handler, Server, Tagged (..), emptyServer, err401, err403, err404, 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, with, (<:>)) import qualified Test.Hspec.Wai as THW import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) import Servant.Server.Internal.BasicAuth (BasicAuthCheck (BasicAuthCheck), BasicAuthResult (Authorized, Unauthorized)) import Servant.Server.Internal.Context (NamedContext (..)) -- * comprehensive api test -- This declaration simply checks that all instances are in place. _ = serveWithContext comprehensiveAPI comprehensiveApiContext comprehensiveApiContext :: Context '[NamedContext "foo" '[]] comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext -- * Specs spec :: Spec spec = do verbSpec uverbSpec captureSpec captureAllSpec queryParamSpec fragmentSpec reqBodySpec headerSpec rawSpec alternativeSpec responseHeadersSpec uverbResponseHeadersSpec miscCombinatorSpec basicAuthSpec genAuthSpec ------------------------------------------------------------------------------ -- * verbSpec {{{ ------------------------------------------------------------------------------ type VerbApi method status = Verb method status '[JSON] Person :<|> "noContent" :> NoContentVerb method :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person) :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent) :<|> "accept" :> ( Verb method status '[JSON] Person :<|> Verb method status '[PlainText] String ) :<|> "stream" :> Stream method status NoFraming OctetStream (SourceIO BS.ByteString) verbSpec :: Spec verbSpec = describe "Servant.API.Verb" $ do let server :: Server (VerbApi method status) server = return alice :<|> return NoContent :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent) :<|> (return alice :<|> return "B") :<|> return (S.source ["bytestring"]) get200 = Proxy :: Proxy (VerbApi 'GET 200) post210 = Proxy :: Proxy (VerbApi 'POST 210) put203 = Proxy :: Proxy (VerbApi 'PUT 203) delete280 = Proxy :: Proxy (VerbApi 'DELETE 280) patch214 = Proxy :: Proxy (VerbApi 'PATCH 214) wrongMethod m = if m == methodPatch then methodPost else methodPatch test desc api method (status :: Int) = context desc $ with (return $ serve api server) $ do -- HEAD and 214/215 need not return bodies unless (status `elem` [214, 215] || method == methodHead) $ it "returns the person" $ do response <- THW.request method "/" [] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status liftIO $ decode' (simpleBody response) `shouldBe` Just alice it "returns no content on NoContent" $ do response <- THW.request method "/noContent" [] "" liftIO $ statusCode (simpleStatus response) `shouldBe` 204 liftIO $ simpleBody response `shouldBe` "" -- HEAD should not return body when (method == methodHead) $ it "HEAD returns no content body" $ do response <- THW.request method "/" [] "" liftIO $ simpleBody response `shouldBe` "" it "throws 405 on wrong method " $ do THW.request (wrongMethod method) "/" [] "" `shouldRespondWith` 405 it "returns headers" $ do response1 <- THW.request method "/header" [] "" liftIO $ statusCode (simpleStatus response1) `shouldBe` status liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")] response2 <- THW.request method "/header" [] "" liftIO $ statusCode (simpleStatus response2) `shouldBe` status liftIO $ simpleHeaders response2 `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 "responds if the Accept header is supported" $ do response <- THW.request method "" [(hAccept, "application/json")] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status unless (status `elem` [214, 215] || method == methodHead) $ it "allows modular specification of supported content types" $ do response <- THW.request method "/accept" [(hAccept, "text/plain")] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status liftIO $ simpleBody response `shouldBe` "B" it "sets the Content-Type header" $ do response <- THW.request method "" [] "" liftIO $ simpleHeaders response `shouldContain` [("Content-Type", "application/json;charset=utf-8")] it "works for Stream as for Result" $ do response <- THW.request method "/stream" [] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status liftIO $ simpleBody response `shouldBe` "bytestring" test "GET 200" get200 methodGet 200 test "POST 210" post210 methodPost 210 test "PUT 203" put203 methodPut 203 test "DELETE 280" delete280 methodDelete 280 test "PATCH 214" patch214 methodPatch 214 test "GET 200 with HEAD" get200 methodHead 200 -- }}} ------------------------------------------------------------------------------ -- * captureSpec {{{ ------------------------------------------------------------------------------ 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 :: 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 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 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" $ do get "/eyes/bla" `shouldRespondWith` 400 with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) (\ "captured" -> Tagged $ \request_ sendResponse -> sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) -- }}} ------------------------------------------------------------------------------ -- * captureAllSpec {{{ ------------------------------------------------------------------------------ type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal 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 captureAllSpec :: Spec captureAllSpec = do describe "Servant.API.CaptureAll" $ do with (return (serve captureAllApi captureAllServer)) $ do it "can capture a single element of the 'pathInfo'" $ do response <- get "/2" liftIO $ decode' (simpleBody response) `shouldBe` Just tweety it "can capture multiple elements of the 'pathInfo'" $ do response <- get "/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" liftIO $ decode' (simpleBody response) `shouldBe` Just jerry it "can capture when there are no elements in 'pathInfo'" $ do response <- get "/" 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, regardless of which element" $ do get "/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 with (return (serve (Proxy :: Proxy (CaptureAll "segments" String :> Raw)) (\ _captured -> Tagged $ \request_ sendResponse -> sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "consumes everything from pathInfo" $ do get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int]))) -- }}} ------------------------------------------------------------------------------ -- * queryParamSpec {{{ ------------------------------------------------------------------------------ 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 queryParamApi :: Proxy QueryParamApi queryParamApi = Proxy qpServer :: Server QueryParamApi qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges where qpNames (_:name2:_) = return alice { name = name2 } qpNames _ = return alice qpCapitalize False = return alice qpCapitalize True = return alice { name = map toUpper (name alice) } qpAge Nothing = return alice qpAge (Just age') = return alice{ age = age'} qpAges ages = return alice{ age = sum ages} 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 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 response2 <- mkRequest "?names[]=bob&names[]=john" ["a"] liftIO $ decode' (simpleBody response2) `shouldBe` Just alice { name = "john" } it "parses a query parameter" $ flip runSession (serve queryParamApi qpServer) $ do response <- mkRequest "?age=55" ["param"] liftIO $ decode' (simpleBody response) `shouldBe` Just alice { age = 55 } it "generates an error on query parameter parse failure" $ flip runSession (serve queryParamApi qpServer) $ do response <- mkRequest "?age=foo" ["param"] liftIO $ statusCode (simpleStatus response) `shouldBe` 400 return () it "parses multiple query parameters" $ flip runSession (serve queryParamApi qpServer) $ do response <- mkRequest "?ages=10&ages=22" ["multiparam"] liftIO $ decode' (simpleBody response) `shouldBe` Just alice { age = 32 } it "generates an error on parse failures of multiple parameters" $ flip runSession (serve queryParamApi qpServer) $ do response <- mkRequest "?ages=2&ages=foo" ["multiparam"] liftIO $ statusCode (simpleStatus response) `shouldBe` 400 return () it "allows retrieving value-less GET parameters" $ flip runSession (serve queryParamApi qpServer) $ do response3 <- mkRequest "?capitalize" ["b"] liftIO $ decode' (simpleBody response3) `shouldBe` Just alice { name = "ALICE" } response3' <- mkRequest "?capitalize=" ["b"] liftIO $ decode' (simpleBody response3') `shouldBe` Just alice { name = "ALICE" } response3'' <- mkRequest "?unknown=" ["b"] liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice { name = "Alice" } describe "Uses queryString instead of rawQueryString" $ do -- test query parameters rewriter let queryRewriter :: Middleware queryRewriter app req = app req { queryString = fmap 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" $ do it "ignores fragment even if it is present in query" $ do flip runSession (serve fragmentApi fragServer) $ do response1 <- mkRequest "#Alice" ["name"] liftIO $ decode' (simpleBody response1) `shouldBe` Just alice -- }}} ------------------------------------------------------------------------------ -- * reqBodySpec {{{ ------------------------------------------------------------------------------ type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person :<|> "blah" :> ReqBody '[JSON] Person :> Put '[JSON] Integer reqBodyApi :: Proxy ReqBodyApi reqBodyApi = Proxy reqBodySpec :: Spec reqBodySpec = describe "Servant.API.ReqBody" $ do let server :: Server ReqBodyApi server = return :<|> return . age mkReq method x = THW.request method x [(hContentType, "application/json;charset=utf-8")] with (return $ serve reqBodyApi server) $ do it "passes the argument to the handler" $ do 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 "responds with 415 if the request body media type is unsupported" $ do THW.request methodPost "/" [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415 -- }}} ------------------------------------------------------------------------------ -- * headerSpec {{{ ------------------------------------------------------------------------------ type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] NoContent headerApi :: Proxy a -> Proxy (HeaderApi a) headerApi _ = Proxy headerSpec :: Spec headerSpec = describe "Servant.API.Header" $ do let expectsInt :: Maybe Int -> Handler NoContent expectsInt (Just x) = do when (x /= 5) $ error "Expected 5" return NoContent expectsInt Nothing = error "Expected an int" let expectsString :: Maybe String -> Handler NoContent expectsString (Just x) = do when (x /= "more from you") $ error "Expected more from you" return NoContent expectsString Nothing = error "Expected a string" with (return (serve (headerApi (Proxy :: Proxy Int)) expectsInt)) $ do let delete' x = THW.request methodDelete x [("MyHeader", "5")] it "passes the header to the handler (Int)" $ delete' "/" "" `shouldRespondWith` 200 with (return (serve (headerApi (Proxy :: Proxy String)) expectsString)) $ do let delete' x = THW.request methodDelete x [("MyHeader", "more from you")] it "passes the header to the handler (String)" $ delete' "/" "" `shouldRespondWith` 200 with (return (serve (headerApi (Proxy :: Proxy Int)) expectsInt)) $ do let delete' x = THW.request methodDelete x [("MyHeader", "not a number")] it "checks for parse errors" $ delete' "/" "" `shouldRespondWith` 400 -- }}} ------------------------------------------------------------------------------ -- * rawSpec {{{ ------------------------------------------------------------------------------ type RawApi = "foo" :> Raw rawApi :: Proxy RawApi rawApi = Proxy rawApplication :: Show a => (Request -> a) -> Tagged m Application rawApplication f = Tagged $ \request_ sendResponse -> sendResponse $ responseLBS ok200 [] (cs $ 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" 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]) -- }}} ------------------------------------------------------------------------------ -- * alternativeSpec {{{ ------------------------------------------------------------------------------ type AlternativeApi = "foo" :> Get '[JSON] Person :<|> "bar" :> Get '[JSON] Animal :<|> "foo" :> Get '[PlainText] T.Text :<|> "bar" :> Post '[JSON] Animal :<|> "bar" :> Put '[JSON] Animal :<|> "bar" :> Delete '[JSON] NoContent alternativeApi :: Proxy AlternativeApi alternativeApi = Proxy alternativeServer :: Server AlternativeApi alternativeServer = return alice :<|> return jerry :<|> return "a string" :<|> return jerry :<|> return jerry :<|> return NoContent alternativeSpec :: Spec alternativeSpec = do describe "Servant.API.Alternative" $ do 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 "checks all endpoints before returning 415" $ do get "/foo" `shouldRespondWith` 200 it "returns 404 if the path does not exist" $ do get "/nonexistent" `shouldRespondWith` 404 -- }}} ------------------------------------------------------------------------------ -- * responseHeaderSpec {{{ ------------------------------------------------------------------------------ type ResponseHeadersApi = Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) :<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) :<|> Put '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) :<|> Patch '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) responseHeadersServer :: Server ResponseHeadersApi responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi" in h :<|> h :<|> h :<|> h responseHeadersSpec :: Spec responseHeadersSpec = describe "ResponseHeaders" $ do with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do 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 "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 -- }}} ------------------------------------------------------------------------------ -- * 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" $ do with (return $ serve (Proxy :: Proxy UVerbResponseHeadersApi) uverbResponseHeadersServer) $ do it "includes the headers in the response" $ THW.request methodGet "/true" [] "" `shouldRespondWith` "\"foo\"" { matchHeaders = ["H1" <:> "5"] , matchStatus = 200 } -- }}} ------------------------------------------------------------------------------ -- * miscCombinatorSpec {{{ ------------------------------------------------------------------------------ type MiscCombinatorsAPI = "version" :> HttpVersion :> Get '[JSON] String :<|> "secure" :> IsSecure :> Get '[JSON] String :<|> "host" :> RemoteHost :> Get '[JSON] String :<|> "empty" :> EmptyAPI miscApi :: Proxy MiscCombinatorsAPI miscApi = Proxy miscServ :: Server MiscCombinatorsAPI miscServ = versionHandler :<|> secureHandler :<|> hostHandler :<|> emptyServer where versionHandler = return . show secureHandler Secure = return "secure" secureHandler NotSecure = return "not secure" hostHandler = return . show miscCombinatorSpec :: Spec miscCombinatorSpec = with (return $ serve miscApi miscServ) $ describe "Misc. combinators for request inspection" $ do it "Successfully gets the HTTP version specified in the request" $ go "/version" "\"HTTP/1.0\"" it "Checks that hspec-wai uses HTTP, not HTTPS" $ go "/secure" "\"not secure\"" it "Checks that hspec-wai issues request from 0.0.0.0" $ go "/host" "\"0.0.0.0:0\"" it "Doesn't serve anything from the empty API" $ Test.Hspec.Wai.get "empty" `shouldRespondWith` 404 where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res -- }}} ------------------------------------------------------------------------------ -- * Basic Authentication {{{ ------------------------------------------------------------------------------ type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal :<|> Raw basicAuthApi :: Proxy BasicAuthAPI basicAuthApi = Proxy basicAuthServer :: Server BasicAuthAPI basicAuthServer = const (return jerry) :<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext = let basicHandler = BasicAuthCheck $ \(BasicAuthData usr pass) -> if usr == "servant" && pass == "server" then return (Authorized ()) else return Unauthorized 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 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 "plays nice with subsequent Raw endpoints" $ do get "/foo" `shouldRespondWith` 418 -- }}} ------------------------------------------------------------------------------ -- * General Authentication {{{ ------------------------------------------------------------------------------ type GenAuthAPI = AuthProtect "auth" :> "auth" :> Get '[JSON] Animal :<|> Raw genAuthApi :: Proxy GenAuthAPI genAuthApi = Proxy genAuthServer :: Server GenAuthAPI genAuthServer = const (return tweety) :<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") type instance AuthServerData (AuthProtect "auth") = () genAuthContext :: Context '[AuthHandler Request ()] genAuthContext = let authHandler = \req -> case lookup "Auth" (requestHeaders req) of Just "secret" -> return () Just _ -> throwError err403 Nothing -> throwError err401 in mkAuthHandler authHandler :. EmptyContext genAuthSpec :: Spec genAuthSpec = do describe "Servant.API.Auth" $ do with (return (serveWithContext genAuthApi genAuthContext genAuthServer)) $ do 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 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 -- }}} ------------------------------------------------------------------------------ -- * 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 {{{ ------------------------------------------------------------------------------ data Person = Person { name :: String, age :: Integer } deriving (Eq, Show, Generic) instance ToJSON Person instance FromJSON Person alice :: Person alice = Person "Alice" 42 data Animal = Animal { species :: String, numberOfLegs :: Integer } deriving (Eq, Show, Generic) instance ToJSON Animal instance FromJSON Animal jerry :: Animal jerry = Animal "Mouse" 4 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 -- }}} servant-server-0.19.2/test/0000755000000000000000000000000007346545000013741 5ustar0000000000000000servant-server-0.19.2/test/Spec.hs0000644000000000000000000000005407346545000015166 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-}