servant-server-0.15/0000755000000000000000000000000007346545000012616 5ustar0000000000000000servant-server-0.15/CHANGELOG.md0000755000000000000000000002266107346545000014441 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) 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.15/LICENSE0000644000000000000000000000307307346545000013626 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.15/README.md0000755000000000000000000000105407346545000014100 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://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples. servant-server-0.15/Setup.hs0000644000000000000000000000150107346545000014247 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} module Main (main) where #ifndef MIN_VERSION_cabal_doctest #define MIN_VERSION_cabal_doctest(x,y,z) 0 #endif #if MIN_VERSION_cabal_doctest(1,0,0) import Distribution.Extra.Doctest ( defaultMainWithDoctests ) main :: IO () main = defaultMainWithDoctests "doctests" #else #ifdef MIN_VERSION_Cabal -- If the macro is defined, we have new cabal-install, -- but for some reason we don't have cabal-doctest in package-db -- -- Probably we are running cabal sdist, when otherwise using new-build -- workflow #warning You are configuring this package without cabal-doctest installed. \ The doctests test-suite will not work as a result. \ To fix this, install cabal-doctest before configuring. #endif import Distribution.Simple main :: IO () main = defaultMain #endif servant-server-0.15/example/0000755000000000000000000000000007346545000014251 5ustar0000000000000000servant-server-0.15/example/greet.hs0000644000000000000000000000405007346545000015712 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# 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 -- * 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 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 where 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.15/servant-server.cabal0000644000000000000000000001305207346545000016571 0ustar0000000000000000cabal-version: >=1.10 name: servant-server version: 0.15 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://haskell-servant.readthedocs.org/ bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors build-type: Custom tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.2 extra-source-files: CHANGELOG.md README.md source-repository head type: git location: http://github.com/haskell-servant/servant.git custom-setup setup-depends: base >= 4 && <5, Cabal, cabal-doctest >= 1.0.6 && <1.1 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.Handler Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServantErr Servant.Server.StaticFiles -- 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.13 , bytestring >= 0.10.8.1 && < 0.11 , containers >= 0.5.7.1 && < 0.7 , mtl >= 2.2.2 && < 2.3 , text >= 1.2.3.0 && < 1.3 , 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.15 && < 0.15.1 , http-api-data >= 0.4 && < 0.4.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.11 , base64-bytestring >= 1.0.0.1 && < 1.1 , exceptions >= 0.10.0 && < 0.11 , http-media >= 0.7.1.3 && < 0.8 , http-types >= 0.12.2 && < 0.13 , network-uri >= 2.6.1.0 && < 2.7 , monad-control >= 1.0.2.3 && < 1.1 , network >= 2.8 && < 2.9 , 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 && < 1.5 , warp >= 3.2.25 && < 3.3 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 , string-conversions , text , transformers , transformers-compat , wai -- Additonal dependencies build-depends: aeson >= 1.4.1.0 && < 1.5 , directory >= 1.3.0.0 && < 1.4 , hspec >= 2.6.0 && < 2.7 , hspec-wai >= 0.9.0 && < 0.10 , QuickCheck >= 2.12.6.1 && < 2.13 , should-not-typecheck >= 2.1.0 && < 2.2 , temporary >= 1.3 && < 1.4 , wai-extra >= 3.0.24.3 && < 3.1 build-tool-depends: hspec-discover:hspec-discover >= 2.6.0 && <2.7 test-suite doctests build-depends: base , servant-server , doctest >= 0.16.0 && <0.17 type: exitcode-stdio-1.0 main-is: test/doctests.hs buildable: True default-language: Haskell2010 ghc-options: -Wall -threaded if impl(ghc >= 8.2) x-doctest-options: -fdiagnostics-color=never servant-server-0.15/src/0000755000000000000000000000000007346545000013405 5ustar0000000000000000servant-server-0.15/src/Servant.hs0000644000000000000000000000126007346545000015362 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.15/src/Servant/0000755000000000000000000000000007346545000015027 5ustar0000000000000000servant-server-0.15/src/Servant/Server.hs0000644000000000000000000001341607346545000016636 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -- | 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 , -- * 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) -- ** NamedContext , NamedContext(..) , descendIntoNamedContext -- * Basic Authentication , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck) , BasicAuthResult(..) -- * General Authentication -- , AuthHandler(unAuthHandler) -- , AuthServerData -- , mkAuthHandler -- * Default error type , ServantErr(..) -- ** 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 -- * Re-exports , Application , Tagged (..) ) where import Data.Proxy (Proxy (..)) import Data.Tagged (Tagged (..)) import Data.Text (Text) import Network.Wai (Application) import Servant.Server.Internal -- * Implementing Servers -- | 'serve' allows you to implement an API and produce a wai 'Application'. -- -- Example: -- -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books -- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books -- > -- > 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 serveWithContext :: (HasServer api context) => Proxy api -> Context context -> Server api -> Application serveWithContext p context server = toApplication (runRouter (route p context (emptyDelayed (Route server)))) -- | 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 path component. -- -- [@\@] 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.15/src/Servant/Server/Experimental/0000755000000000000000000000000007346545000020732 5ustar0000000000000000servant-server-0.15/src/Servant/Server/Experimental/Auth.hs0000644000000000000000000000512507346545000022172 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 (HasContextEntry, HasServer (..), getContextEntry) import Servant.Server.Internal.Handler (Handler, runHandler) import Servant.Server.Internal.RoutingApplication (DelayedIO, addAuthCheck, delayedFailFatal, 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.15/src/Servant/Server/0000755000000000000000000000000007346545000016275 5ustar0000000000000000servant-server-0.15/src/Servant/Server/Generic.hs0000644000000000000000000000653707346545000020220 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | @since 0.14.1 module Servant.Server.Generic ( AsServerT, AsServer, genericServe, genericServeT, genericServeTWithContext, genericServer, genericServerT, ) where import Data.Proxy (Proxy (..)) import Servant.API.Generic import Servant.Server -- | A type that specifies that an API record contains a server implementation. data AsServerT (m :: * -> *) instance GenericMode (AsServerT m) where type AsServerT m :- api = ServerT api m type AsServer = AsServerT Handler -- | Transform 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 , 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 record of endpoints into a 'Server'. genericServer :: GenericServant routes AsServer => routes AsServer -> ToServant routes AsServer genericServer = toServant genericServerT :: GenericServant routes (AsServerT m) => routes (AsServerT m) -> ToServant routes (AsServerT m) genericServerT = toServant servant-server-0.15/src/Servant/Server/Internal.hs0000644000000000000000000010213307346545000020405 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802 #define HAS_TYPE_ERROR #endif module Servant.Server.Internal ( module Servant.Server.Internal , module Servant.Server.Internal.BasicAuth , module Servant.Server.Internal.Context , module Servant.Server.Internal.Handler , module Servant.Server.Internal.Router , module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.ServantErr ) 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.Either (partitionEithers) import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) import Data.Semigroup ((<>)) import Data.String (IsString (..)) import Data.String.Conversions (cs) import Data.Tagged (Tagged (..), retag, untag) import qualified Data.Text as T import Data.Typeable import GHC.TypeLits (KnownNat, KnownSymbol, natVal, 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, rawQueryString, remoteHost, requestBody, requestHeaders, requestMethod, responseLBS, responseStream, vault) import Prelude () import Prelude.Compat import Servant.API ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture', CaptureAll, Description, EmptyAPI, FramingRender (..), FramingUnrender (..), FromSourceIO (..), Header', If, IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod), RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, WithNamedContext) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH) import Servant.API.Modifiers (FoldLenient, FoldRequired, RequestArgument, unfoldRequestArgument) import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) import qualified Servant.Types.SourceT as S import Web.HttpApiData (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPieceMaybe, parseUrlPieces) import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context import Servant.Server.Internal.Handler import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr #ifdef HAS_TYPE_ERROR import GHC.TypeLits (ErrorMessage (..), TypeError) #endif 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, HasServer api context) => HasServer (Capture' mods capture a :> api) context where type ServerT (Capture' mods capture a :> api) m = a -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context d = CaptureRouter $ route (Proxy :: Proxy api) context (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of Nothing -> delayedFail err400 Just v -> return v ) -- | If you use 'CaptureAll' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a -- function that takes an argument of a list of the type specified by -- the 'CaptureAll'. This lets servant worry about getting values from -- the URL and turning them into values of the type you specify. -- -- You can control how they'll be converted from 'Text' to your type -- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- -- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile -- > -- > server :: Server MyApi -- > server = getSourceFile -- > where getSourceFile :: [Text] -> Handler Book -- > getSourceFile pathSegments = ... instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) => 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 $ route (Proxy :: Proxy api) context (addCapture d $ \ txts -> case parseUrlPieces txts of Left _ -> delayedFail err400 Right v -> return v ) allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead allowedMethod :: Method -> Request -> Bool allowedMethod method request = allowedMethodHead method request || requestMethod request == method methodCheck :: Method -> Request -> DelayedIO () methodCheck method request | allowedMethod method request = return () | otherwise = delayedFail err405 -- This has switched between using 'Fail' and 'FailFatal' a number of -- times. If the 'acceptCheck' is run after the body check (which would -- be morally right), then we have to set this to 'FailFatal', because -- the body check is not reversible, and therefore backtracking after the -- body check is no longer an option. However, we now run the accept -- check before the body check and can therefore afford to make it -- recoverable. acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO () acceptCheck proxy accH | canHandleAcceptH proxy (AcceptHeader accH) = return () | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a) => (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 = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH ) env request respond $ \ output -> do let (headers, b) = splitHeaders output case handleAcceptH proxy (AcceptHeader 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 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 = toEnum . fromInteger $ natVal (Proxy :: Proxy status) instance {-# OVERLAPPING #-} ( AllCTRender ctypes a, ReflectMethod method, KnownNat status , GetHeaders (Headers h a) ) => HasServer (Verb method status ctypes (Headers h a)) context where type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) 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 = toEnum . fromInteger $ natVal (Proxy :: Proxy status) instance {-# OVERLAPPABLE #-} ( MimeRender ctype chunk, ReflectMethod method, KnownNat status, FramingRender framing, ToSourceIO chunk a ) => HasServer (Stream method status framing ctype a) context where type ServerT (Stream method status framing ctype a) m = m a hoistServerWithContext _ _ nt s = nt s route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) instance {-# OVERLAPPING #-} ( MimeRender ctype chunk, ReflectMethod method, KnownNat status, FramingRender framing, ToSourceIO chunk a, GetHeaders (Headers h a) ) => HasServer (Stream method status framing ctype (Headers h a)) context where type ServerT (Stream method status framing ctype (Headers h a)) m = m (Headers h a) hoistServerWithContext _ _ nt s = nt s route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) 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 accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders 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) ) => 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 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 err400 { errBody = "Header " <> headerName <> " is required" } errSt e = delayedFailFatal err400 { errBody = 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) ) => 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 req = parseQueryText $ rawQueryString req paramname = cs $ symbolVal (Proxy :: Proxy sym) 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 err400 { errBody = cs $ "Query parameter " <> paramname <> " is required" } errSt e = delayedFailFatal err400 { errBody = 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) => 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 paramname = cs $ symbolVal (Proxy :: Proxy sym) paramsCheck req = case partitionEithers $ fmap parseQueryParam params of ([], parsed) -> return parsed (errs, _) -> delayedFailFatal err400 { errBody = cs $ "Error parsing query parameter(s) " <> paramname <> " failed: " <> T.intercalate ", " errs } where params :: [T.Text] params = mapMaybe snd . filter (looksLikeParam . fst) . parseQueryText . rawQueryString $ 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 r = parseQueryText $ rawQueryString r param r = case lookup paramname (querytext r) of Just Nothing -> True -- param is there, with no value Just (Just v) -> examine v -- param with a value Nothing -> False -- param not in the query string in route (Proxy :: Proxy api) context (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False -- | Just pass the request to the underlying application and serve its response. -- -- Example: -- -- > type MyApi = "images" :> Raw -- > -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" instance HasServer Raw context where type ServerT Raw m = 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 -- . -- 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) ) => 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 -- 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 err400 { errBody = cs 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 = requestBody 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 `emptyAPIServer`. -- -- > type MyApi = "nothing" :> EmptyApi -- > -- > server :: Server MyApi -- > server = emptyAPIServer instance HasServer EmptyAPI context where type ServerT EmptyAPI m = Tagged m EmptyServer route Proxy _ _ = StaticRouter mempty mempty 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 = "*" <> "/" <> "*" -- Because CPP -- * General Authentication -- * contexts instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) => HasServer (WithNamedContext name subContext subApi) context where type ServerT (WithNamedContext name subContext subApi) m = ServerT subApi m route Proxy context delayed = route subProxy subContext delayed where subProxy :: Proxy subApi subProxy = Proxy subContext :: Context subContext subContext = descendIntoNamedContext (Proxy :: Proxy name) context hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s ------------------------------------------------------------------------------- -- TypeError helpers ------------------------------------------------------------------------------- #ifdef HAS_TYPE_ERROR -- | This instance catches mistakes when there are non-saturated -- type applications on LHS of ':>'. -- -- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...") -- ... -- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'. -- ...Maybe you haven't applied enough arguments to -- ...Capture' '[] "foo" -- ... -- -- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int) -- ... -- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'. -- ...Maybe you haven't applied enough arguments to -- ...Capture' '[] "foo" -- ... -- instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context where type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr) -- it doens't really matter what sub route we peak route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)" hoistServerWithContext _ _ _ = id -- Cannot have TypeError here, otherwise use of this symbol will error :) type HasServerArrowKindError arr = 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'." ':$$: 'Text "Maybe you haven't applied enough arguments to" ':$$: 'ShowType arr -- | 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 #endif -- $setup -- >>> import Servant servant-server-0.15/src/Servant/Server/Internal/0000755000000000000000000000000007346545000020051 5ustar0000000000000000servant-server-0.15/src/Servant/Server/Internal/BasicAuth.hs0000644000000000000000000000554407346545000022260 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.Monoid ((<>)) 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.RoutingApplication import Servant.Server.Internal.ServantErr -- * Basic Auth -- | servant-server's current implementation of basic authentication is not -- immune to certian 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.15/src/Servant/Server/Internal/Context.hs0000644000000000000000000001021507346545000022030 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# 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 heterogenous -- 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 -- | 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.15/src/Servant/Server/Internal/Handler.hs0000644000000000000000000000311207346545000021757 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) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Except (ExceptT, runExceptT) import GHC.Generics (Generic) import Servant.Server.Internal.ServantErr (ServantErr) newtype Handler a = Handler { runHandler' :: ExceptT ServantErr IO a } deriving ( Functor, Applicative, Monad, MonadIO, Generic , MonadError ServantErr , MonadThrow, MonadCatch, MonadMask ) instance MonadBase IO Handler where liftBase = Handler . liftBase instance MonadBaseControl IO Handler where type StM Handler a = Either ServantErr 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 ServantErr a) runHandler = runExceptT . runHandler' servant-server-0.15/src/Servant/Server/Internal/Router.hs0000644000000000000000000001771207346545000021675 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where import Prelude () import Prelude.Compat import Data.Map (Map) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T import Network.Wai (Response, pathInfo) import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr type Router env = Router' env RoutingApplication -- | 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 (Router' (Text, env) a) -- ^ first path component is passed to the child router in its -- environment and removed afterwards | CaptureAllRouter (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 router1) (CaptureRouter router2) = CaptureRouter (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 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 router) = CaptureRouterStructure $ routerStructure router routerStructure (CaptureAllRouter router) = CaptureRouterStructure $ 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 r1 r2 = routerStructure r1 == routerStructure r2 -- | 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 r) = mkSubTree c "" (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 :: Router () -> RoutingApplication runRouter r = runRouterEnv r () runRouterEnv :: Router env -> env -> RoutingApplication runRouterEnv router env request respond = case router of StaticRouter table ls -> case pathInfo request of [] -> runChoice ls env request respond -- This case is to handle trailing slashes. [""] -> runChoice ls env request respond first : rest | Just router' <- M.lookup first table -> let request' = request { pathInfo = rest } in runRouterEnv router' env request' respond _ -> respond $ Fail err404 CaptureRouter router' -> case pathInfo request of [] -> respond $ Fail err404 -- This case is to handle trailing slashes. [""] -> respond $ Fail err404 first : rest -> let request' = request { pathInfo = rest } in runRouterEnv router' (first, env) request' respond CaptureAllRouter router' -> let segments = pathInfo request request' = request { pathInfo = [] } in runRouterEnv router' (segments, env) request' respond RawRouter app -> app env request respond Choice r1 r2 -> runChoice [runRouterEnv r1, runRouterEnv r2] env request respond -- | Try a list of routing applications in order. -- We stop as soon as one fails fatally or succeeds. -- If all fail normally, we pick the "best" error. -- runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication runChoice ls = case ls of [] -> \ _ _ respond -> respond (Fail err404) [r] -> r (r : rs) -> \ env request respond -> r env request $ \ response1 -> case response1 of Fail _ -> runChoice 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. -- -- It just so happens that 404 < 405 < 406 as far as -- we are concerned here, so we can use (<). worseHTTPCode :: Int -> Int -> Bool worseHTTPCode = (<) servant-server-0.15/src/Servant/Server/Internal/RoutingApplication.hs0000644000000000000000000003436707346545000024235 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.RoutingApplication where import Control.Monad (ap, liftM) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch (MonadThrow (..)) import Control.Monad.Reader (MonadReader (..), ReaderT (..), runReaderT) import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..), defaultLiftBaseWith, defaultRestoreM) import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runInternalState, runResourceT, transResourceT, withInternalState) import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude () import Prelude.Compat import Servant.Server.Internal.Handler import Servant.Server.Internal.ServantErr type RoutingApplication = Request -- ^ the request, the field 'pathInfo' may be modified by url routing -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived -- | The result of matching against a path in the route tree. data RouteResult a = Fail ServantErr -- ^ Keep trying other paths. The @ServantErr@ -- should only be 404, 405 or 406. | FailFatal !ServantErr -- ^ Don't try other paths. | Route !a deriving (Eq, Show, Read, Functor) instance Applicative RouteResult where pure = return (<*>) = ap instance Monad RouteResult where return = Route Route a >>= f = f a Fail e >>= _ = Fail e FailFatal e >>= _ = FailFatal e newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) } deriving (Functor) instance MonadTrans RouteResultT where lift = RouteResultT . liftM Route instance (Functor m, Monad m) => Applicative (RouteResultT m) where pure = return (<*>) = ap instance Monad m => Monad (RouteResultT m) where return = RouteResultT . return . Route m >>= k = RouteResultT $ do a <- runRouteResultT m case a of Fail e -> return $ Fail e FailFatal e -> return $ FailFatal e Route b -> runRouteResultT (k b) instance MonadIO m => MonadIO (RouteResultT m) where liftIO = lift . liftIO instance MonadBase b m => MonadBase b (RouteResultT m) where liftBase = lift . liftBase instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where type StM (RouteResultT m) a = ComposeSt RouteResultT m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM instance MonadTransControl RouteResultT where type StT RouteResultT a = RouteResult a liftWith f = RouteResultT $ liftM return $ f runRouteResultT restoreT = RouteResultT instance MonadThrow m => MonadThrow (RouteResultT m) where throwM = lift . throwM toApplication :: RoutingApplication -> Application toApplication ra request respond = ra request routingRespond where routingRespond :: RouteResult Response -> IO ResponseReceived routingRespond (Fail err) = respond $ responseServantErr err routingRespond (FailFatal err) = respond $ responseServantErr err routingRespond (Route v) = respond v -- | A 'Delayed' is a representation of a handler with scheduled -- delayed checks that can trigger errors. -- -- Why would we want to delay checks? -- -- There are two reasons: -- -- 1. In a straight-forward implementation, the order in which we -- perform checks will determine the error we generate. This is -- because once an error occurs, we would abort and not perform -- any subsequent checks, but rather return the current error. -- -- This is not a necessity: we could continue doing other checks, -- and choose the preferred error. However, that would in general -- mean more checking, which leads us to the other reason. -- -- 2. We really want to avoid doing certain checks too early. For -- example, captures involve parsing, and are much more costly -- than static route matches. In particular, if several paths -- contain the "same" capture, we'd like as much as possible to -- avoid trying the same parse many times. Also tricky is the -- request body. Again, this involves parsing, but also, WAI makes -- obtaining the request body a side-effecting operation. We -- could/can work around this by manually caching the request body, -- but we'd rather keep the number of times we actually try to -- decode the request body to an absolute minimum. -- -- We prefer to have the following relative priorities of error -- codes: -- -- @ -- 404 -- 405 (bad method) -- 401 (unauthorized) -- 415 (unsupported media type) -- 406 (not acceptable) -- 400 (bad request) -- @ -- -- Therefore, while routing, we delay most checks so that they -- will ultimately occur in the right order. -- -- A 'Delayed' contains many delayed blocks of tests, and -- the actual handler: -- -- 1. Delayed captures. These can actually cause 404, and -- while they're costly, they should be done first among the -- delayed checks (at least as long as we do not decouple the -- check order from the error reporting, see above). Delayed -- captures can provide inputs to the actual handler. -- -- 2. Method check(s). This can cause a 405. On success, -- it does not provide an input for the handler. Method checks -- are comparatively cheap. -- -- 3. Authentication checks. This can cause 401. -- -- 4. Accept and content type header checks. These checks -- can cause 415 and 406 errors. -- -- 5. Query parameter checks. They require parsing and can cause 400 if the -- parsing fails. Query parameter checks provide inputs to the handler -- -- 6. Header Checks. They also require parsing and can cause 400 if parsing fails. -- -- 7. Body check. The request body check can cause 400. -- data Delayed env c where Delayed :: { capturesD :: env -> DelayedIO captures , methodD :: DelayedIO () , authD :: DelayedIO auth , acceptD :: DelayedIO () , contentD :: DelayedIO contentType , paramsD :: DelayedIO params , headersD :: DelayedIO headers , bodyD :: contentType -> DelayedIO body , serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult c } -> Delayed env c instance Functor (Delayed env) where fmap f Delayed{..} = Delayed { serverD = \ c p h a b req -> f <$> serverD c p h a b req , .. } -- Note [Existential Record Update] -- | Computations used in a 'Delayed' can depend on the -- incoming 'Request', may perform 'IO, and result in a -- 'RouteResult, meaning they can either suceed, fail -- (with the possibility to recover), or fail fatally. -- newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a } deriving ( Functor, Applicative, Monad , MonadIO, MonadReader Request , MonadThrow , MonadResource ) instance MonadBase IO DelayedIO where liftBase = liftIO liftRouteResult :: RouteResult a -> DelayedIO a liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x instance MonadBaseControl IO DelayedIO where -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO') -- restoreM = DelayedIO . restoreM type StM DelayedIO a = RouteResult a liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s -> liftBaseWith $ \runInBase -> f $ \x -> runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s) restoreM = DelayedIO . lift . withInternalState . const . restoreM runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a) runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req -- | A 'Delayed' without any stored checks. emptyDelayed :: RouteResult a -> Delayed env a emptyDelayed result = Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result) where r = return () -- | Fail with the option to recover. delayedFail :: ServantErr -> DelayedIO a delayedFail err = liftRouteResult $ Fail err -- | Fail fatally, i.e., without any option to recover. delayedFailFatal :: ServantErr -> DelayedIO a delayedFailFatal err = liftRouteResult $ FailFatal err -- | Gain access to the incoming request. withRequest :: (Request -> DelayedIO a) -> DelayedIO a withRequest f = do req <- ask f req -- | Add a capture to the end of the capture block. addCapture :: Delayed env (a -> b) -> (captured -> DelayedIO a) -> Delayed (captured, env) b addCapture Delayed{..} new = Delayed { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req , .. } -- Note [Existential Record Update] -- | Add a parameter check to the end of the params block addParameterCheck :: Delayed env (a -> b) -> DelayedIO a -> Delayed env b addParameterCheck Delayed {..} new = Delayed { paramsD = (,) <$> paramsD <*> new , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req , .. } -- | Add a parameter check to the end of the params block addHeaderCheck :: Delayed env (a -> b) -> DelayedIO a -> Delayed env b addHeaderCheck Delayed {..} new = Delayed { headersD = (,) <$> headersD <*> new , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req , .. } -- | Add a method check to the end of the method block. addMethodCheck :: Delayed env a -> DelayedIO () -> Delayed env a addMethodCheck Delayed{..} new = Delayed { methodD = methodD <* new , .. } -- Note [Existential Record Update] -- | Add an auth check to the end of the auth block. addAuthCheck :: Delayed env (a -> b) -> DelayedIO a -> Delayed env b addAuthCheck Delayed{..} new = Delayed { authD = (,) <$> authD <*> new , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req , .. } -- Note [Existential Record Update] -- | Add a content type and body checks around parameter checks. -- -- We'll report failed content type check (415), before trying to parse -- query parameters (400). Which, in turn, happens before request body parsing. addBodyCheck :: Delayed env (a -> b) -> DelayedIO c -- ^ content type check -> (c -> DelayedIO a) -- ^ body check -> Delayed env b addBodyCheck Delayed{..} newContentD newBodyD = Delayed { contentD = (,) <$> contentD <*> newContentD , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req , .. } -- Note [Existential Record Update] -- | Add an accept header check before handling parameters. -- In principle, we'd like -- to take a bad body (400) response take precedence over a -- failed accept check (406). BUT to allow streaming the body, -- we cannot run the body check and then still backtrack. -- We therefore do the accept check before the body check, -- when we can still backtrack. There are other solutions to -- this, but they'd be more complicated (such as delaying the -- body check further so that it can still be run in a situation -- where we'd otherwise report 406). addAcceptCheck :: Delayed env a -> DelayedIO () -> Delayed env a addAcceptCheck Delayed{..} new = Delayed { acceptD = acceptD *> new , .. } -- Note [Existential Record Update] -- | Many combinators extract information that is passed to -- the handler without the possibility of failure. In such a -- case, 'passToServer' can be used. passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b passToServer Delayed{..} x = Delayed { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req , .. } -- Note [Existential Record Update] -- | Run a delayed server. Performs all scheduled operations -- in order, and passes the results from the capture and body -- blocks on to the actual handler. -- -- This should only be called once per request; otherwise the guarantees about -- effect and HTTP error ordering break down. runDelayed :: Delayed env a -> env -> Request -> ResourceT IO (RouteResult a) runDelayed Delayed{..} env = runDelayedIO $ do r <- ask c <- capturesD env methodD a <- authD acceptD content <- contentD p <- paramsD -- Has to be before body parsing, but after content-type checks h <- headersD b <- bodyD content liftRouteResult (serverD c p h a b r) -- | Runs a delayed server and the resulting action. -- Takes a continuation that lets us send a response. -- Also takes a continuation for how to turn the -- result of the delayed server into a response. runAction :: Delayed env (Handler a) -> env -> Request -> (RouteResult Response -> IO r) -> (a -> RouteResult Response) -> IO r runAction action env req respond k = runResourceT $ runDelayed action env req >>= go >>= liftIO . respond where go (Fail e) = return $ Fail e go (FailFatal e) = return $ FailFatal e go (Route a) = liftIO $ do e <- runHandler a case e of Left err -> return . Route $ responseServantErr err Right x -> return $! k x {- Note [Existential Record Update] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Due to GHC issue , we cannot do the more succint thing - just update the records we actually change. -} servant-server-0.15/src/Servant/Server/Internal/ServantErr.hs0000644000000000000000000003174107346545000022506 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Servant.Server.Internal.ServantErr where import Control.Exception (Exception) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import Data.Typeable (Typeable) import qualified Network.HTTP.Types as HTTP import Network.Wai (Response, responseLBS) data ServantErr = ServantErr { errHTTPCode :: Int , errReasonPhrase :: String , errBody :: LBS.ByteString , errHeaders :: [HTTP.Header] } deriving (Show, Eq, Read, Typeable) instance Exception ServantErr responseServantErr :: ServantErr -> Response responseServantErr ServantErr{..} = responseLBS status errHeaders errBody where status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase) -- | 'err300' Multiple Choices -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err300 { errBody = "I can't choose." } -- err300 :: ServantErr err300 = ServantErr { errHTTPCode = 300 , errReasonPhrase = "Multiple Choices" , errBody = "" , errHeaders = [] } -- | 'err301' Moved Permanently -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err301 -- err301 :: ServantErr err301 = ServantErr { errHTTPCode = 301 , errReasonPhrase = "Moved Permanently" , errBody = "" , errHeaders = [] } -- | 'err302' Found -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err302 -- err302 :: ServantErr err302 = ServantErr { errHTTPCode = 302 , errReasonPhrase = "Found" , errBody = "" , errHeaders = [] } -- | 'err303' See Other -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err303 -- err303 :: ServantErr err303 = ServantErr { errHTTPCode = 303 , errReasonPhrase = "See Other" , errBody = "" , errHeaders = [] } -- | 'err304' Not Modified -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err304 -- err304 :: ServantErr err304 = ServantErr { errHTTPCode = 304 , errReasonPhrase = "Not Modified" , errBody = "" , errHeaders = [] } -- | 'err305' Use Proxy -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err305 -- err305 :: ServantErr err305 = ServantErr { errHTTPCode = 305 , errReasonPhrase = "Use Proxy" , errBody = "" , errHeaders = [] } -- | 'err307' Temporary Redirect -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err307 -- err307 :: ServantErr err307 = ServantErr { errHTTPCode = 307 , errReasonPhrase = "Temporary Redirect" , errBody = "" , errHeaders = [] } -- | 'err400' Bad Request -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." } -- err400 :: ServantErr err400 = ServantErr { errHTTPCode = 400 , errReasonPhrase = "Bad Request" , errBody = "" , errHeaders = [] } -- | 'err401' Unauthorized -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." } -- err401 :: ServantErr err401 = ServantErr { errHTTPCode = 401 , errReasonPhrase = "Unauthorized" , errBody = "" , errHeaders = [] } -- | 'err402' Payment Required -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." } -- err402 :: ServantErr err402 = ServantErr { errHTTPCode = 402 , errReasonPhrase = "Payment Required" , errBody = "" , errHeaders = [] } -- | 'err403' Forbidden -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err403 { errBody = "Please login first." } -- err403 :: ServantErr err403 = ServantErr { errHTTPCode = 403 , errReasonPhrase = "Forbidden" , errBody = "" , errHeaders = [] } -- | 'err404' Not Found -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } -- err404 :: ServantErr err404 = ServantErr { errHTTPCode = 404 , errReasonPhrase = "Not Found" , errBody = "" , errHeaders = [] } -- | 'err405' Method Not Allowed -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." } -- err405 :: ServantErr err405 = ServantErr { errHTTPCode = 405 , errReasonPhrase = "Method Not Allowed" , errBody = "" , errHeaders = [] } -- | 'err406' Not Acceptable -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err406 -- err406 :: ServantErr err406 = ServantErr { errHTTPCode = 406 , errReasonPhrase = "Not Acceptable" , errBody = "" , errHeaders = [] } -- | 'err407' Proxy Authentication Required -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err407 -- err407 :: ServantErr err407 = ServantErr { errHTTPCode = 407 , errReasonPhrase = "Proxy Authentication Required" , errBody = "" , errHeaders = [] } -- | 'err409' Conflict -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" } -- err409 :: ServantErr err409 = ServantErr { errHTTPCode = 409 , errReasonPhrase = "Conflict" , errBody = "" , errHeaders = [] } -- | 'err410' Gone -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." } -- err410 :: ServantErr err410 = ServantErr { errHTTPCode = 410 , errReasonPhrase = "Gone" , errBody = "" , errHeaders = [] } -- | 'err411' Length Required -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err411 -- err411 :: ServantErr err411 = ServantErr { errHTTPCode = 411 , errReasonPhrase = "Length Required" , errBody = "" , errHeaders = [] } -- | 'err412' Precondition Failed -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" } -- err412 :: ServantErr err412 = ServantErr { errHTTPCode = 412 , errReasonPhrase = "Precondition Failed" , errBody = "" , errHeaders = [] } -- | 'err413' Request Entity Too Large -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." } -- err413 :: ServantErr err413 = ServantErr { errHTTPCode = 413 , errReasonPhrase = "Request Entity Too Large" , errBody = "" , errHeaders = [] } -- | 'err414' Request-URI Too Large -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." } -- err414 :: ServantErr err414 = ServantErr { errHTTPCode = 414 , errReasonPhrase = "Request-URI Too Large" , errBody = "" , errHeaders = [] } -- | 'err415' Unsupported Media Type -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" } -- err415 :: ServantErr err415 = ServantErr { errHTTPCode = 415 , errReasonPhrase = "Unsupported Media Type" , errBody = "" , errHeaders = [] } -- | 'err416' Request range not satisfiable -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." } -- err416 :: ServantErr err416 = ServantErr { errHTTPCode = 416 , errReasonPhrase = "Request range not satisfiable" , errBody = "" , errHeaders = [] } -- | 'err417' Expectation Failed -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." } -- err417 :: ServantErr err417 = ServantErr { errHTTPCode = 417 , errReasonPhrase = "Expectation Failed" , errBody = "" , errHeaders = [] } -- | 'err418' Expectation Failed -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err418 { errBody = "Apologies, this is not a webserver but a teapot." } -- err418 :: ServantErr err418 = ServantErr { errHTTPCode = 418 , errReasonPhrase = "I'm a teapot" , errBody = "" , errHeaders = [] } -- | 'err422' Unprocessable Entity -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err422 { errBody = "I understood your request, but can't process it." } -- err422 :: ServantErr err422 = ServantErr { errHTTPCode = 422 , errReasonPhrase = "Unprocessable Entity" , errBody = "" , errHeaders = [] } -- | 'err500' Internal Server Error -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" } -- err500 :: ServantErr err500 = ServantErr { errHTTPCode = 500 , errReasonPhrase = "Internal Server Error" , errBody = "" , errHeaders = [] } -- | 'err501' Not Implemented -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." } -- err501 :: ServantErr err501 = ServantErr { errHTTPCode = 501 , errReasonPhrase = "Not Implemented" , errBody = "" , errHeaders = [] } -- | 'err502' Bad Gateway -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." } -- err502 :: ServantErr err502 = ServantErr { errHTTPCode = 502 , errReasonPhrase = "Bad Gateway" , errBody = "" , errHeaders = [] } -- | 'err503' Service Unavailable -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." } -- err503 :: ServantErr err503 = ServantErr { errHTTPCode = 503 , errReasonPhrase = "Service Unavailable" , errBody = "" , errHeaders = [] } -- | 'err504' Gateway Time-out -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." } -- err504 :: ServantErr err504 = ServantErr { errHTTPCode = 504 , errReasonPhrase = "Gateway Time-out" , errBody = "" , errHeaders = [] } -- | 'err505' HTTP Version not supported -- -- Example usage: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." } -- err505 :: ServantErr err505 = ServantErr { errHTTPCode = 505 , errReasonPhrase = "HTTP Version not supported" , errBody = "" , errHeaders = [] } servant-server-0.15/src/Servant/Server/StaticFiles.hs0000644000000000000000000000644307346545000021052 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.15/src/Servant/Utils/0000755000000000000000000000000007346545000016127 5ustar0000000000000000servant-server-0.15/src/Servant/Utils/StaticFiles.hs0000644000000000000000000000027107346545000020675 0ustar0000000000000000module Servant.Utils.StaticFiles {-# DEPRECATED "Use Servant.Server.StaticFiles." #-} ( module Servant.Server.StaticFiles ) where import Servant.Server.StaticFiles servant-server-0.15/test/Servant/0000755000000000000000000000000007346545000015217 5ustar0000000000000000servant-server-0.15/test/Servant/ArbitraryMonadServerSpec.hs0000644000000000000000000000351207346545000022474 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.15/test/Servant/HoistSpec.hs0000644000000000000000000000200407346545000017450 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.15/test/Servant/Server/0000755000000000000000000000000007346545000016465 5ustar0000000000000000servant-server-0.15/test/Servant/Server/ErrorSpec.hs0000644000000000000000000002651407346545000020735 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.Monoid ((<>)) import Data.Proxy 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 -- * 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 -- }}} ------------------------------------------------------------------------------ -- * 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.15/test/Servant/Server/Internal/0000755000000000000000000000000007346545000020241 5ustar0000000000000000servant-server-0.15/test/Servant/Server/Internal/ContextSpec.hs0000644000000000000000000000460007346545000023034 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-} 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.15/test/Servant/Server/Internal/RoutingApplicationSpec.hs0000644000000000000000000001231107346545000025221 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.RoutingApplication 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.15/test/Servant/Server/RouterSpec.hs0000644000000000000000000002245707346545000021126 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 (unpack) 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 routerSpec :: Spec routerSpec = do let app' :: Application app' = toApplication $ runRouter 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 describe "tweakResponse" . with (return app') $ do it "calls f on route result" $ do get "" `shouldRespondWith` 202 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 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)) 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 "bar" Bool :> "c" :> End :<|> "a" :> Capture "baz" Char :> "d" :> End type DynamicRef = "a" :> Capture "anything" () :> ("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 servant-server-0.15/test/Servant/Server/StaticFilesSpec.hs0000644000000000000000000000414307346545000022050 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.15/test/Servant/Server/StreamingSpec.hs0000644000000000000000000000651007346545000021567 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.15/test/Servant/Server/UsingContextSpec.hs0000644000000000000000000000716307346545000022275 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.15/test/Servant/Server/UsingContextSpec/0000755000000000000000000000000007346545000021732 5ustar0000000000000000servant-server-0.15/test/Servant/Server/UsingContextSpec/TestCombinators.hs0000644000000000000000000000504507346545000025412 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.15/test/Servant/ServerSpec.hs0000644000000000000000000007056507346545000017651 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# 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.Proxy (Proxy (Proxy)) import Data.String (fromString) import Data.String.Conversions (cs) import qualified Data.Text as T import GHC.Generics (Generic) import Network.HTTP.Types (Status (..), hAccept, hContentType, imATeapot418, methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut, ok200, parseQuery) import Network.Wai (Application, Request, pathInfo, queryString, rawQueryString, requestHeaders, responseLBS) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody, simpleHeaders, simpleStatus) import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData (BasicAuthData), Capture, CaptureAll, Delete, EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..), JSON, NoContent (..), NoFraming, OctetStream, Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Verb, addHeader) import Servant.Server (Context ((:.), EmptyContext), Handler, Server, Tagged (..), emptyServer, err401, err403, err404, 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 captureSpec captureAllSpec queryParamSpec reqBodySpec headerSpec rawSpec alternativeSpec responseHeadersSpec miscCombinatorSpec basicAuthSpec genAuthSpec ------------------------------------------------------------------------------ -- * verbSpec {{{ ------------------------------------------------------------------------------ type VerbApi method status = Verb method status '[JSON] Person :<|> "noContent" :> Verb method status '[JSON] NoContent :<|> "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` status 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 captureApi :: Proxy CaptureApi captureApi = Proxy captureServer :: Integer -> Handler Animal captureServer legs = case legs of 4 -> return jerry 2 -> return tweety _ -> 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 with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) (\ "captured" -> Tagged $ \request_ respond -> respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) -- }}} ------------------------------------------------------------------------------ -- * 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_ respond -> respond $ 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 describe "Servant.API.QueryParam" $ do it "allows retrieving simple GET parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params1 = "?name=bob" response1 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params1, queryString = parseQuery params1 } liftIO $ do decode' (simpleBody response1) `shouldBe` Just alice{ name = "bob" } it "allows retrieving lists in GET parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params2 = "?names[]=bob&names[]=john" response2 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params2, queryString = parseQuery params2, pathInfo = ["a"] } liftIO $ decode' (simpleBody response2) `shouldBe` Just alice{ name = "john" } it "parses a query parameter" $ (flip runSession) (serve queryParamApi qpServer) $ do let params = "?age=55" response <- Network.Wai.Test.request defaultRequest{ rawQueryString = params, queryString = parseQuery params, pathInfo = ["param"] } liftIO $ decode' (simpleBody response) `shouldBe` Just alice{ age = 55 } it "generates an error on query parameter parse failure" $ (flip runSession) (serve queryParamApi qpServer) $ do let params = "?age=foo" response <- Network.Wai.Test.request defaultRequest{ rawQueryString = params, queryString = parseQuery params, pathInfo = ["param"] } liftIO $ statusCode (simpleStatus response) `shouldBe` 400 return () it "parses multiple query parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params = "?ages=10&ages=22" response <- Network.Wai.Test.request defaultRequest{ rawQueryString = params, queryString = parseQuery params, pathInfo = ["multiparam"] } liftIO $ decode' (simpleBody response) `shouldBe` Just alice{ age = 32 } it "generates an error on parse failures of multiple parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params = "?ages=2&ages=foo" response <- Network.Wai.Test.request defaultRequest{ rawQueryString = params, queryString = parseQuery params, pathInfo = ["multiparam"] } liftIO $ statusCode (simpleStatus response) `shouldBe` 400 return () it "allows retrieving value-less GET parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params3 = "?capitalize" response3 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params3, queryString = parseQuery params3, pathInfo = ["b"] } liftIO $ decode' (simpleBody response3) `shouldBe` Just alice{ name = "ALICE" } let params3' = "?capitalize=" response3' <- Network.Wai.Test.request defaultRequest{ rawQueryString = params3', queryString = parseQuery params3', pathInfo = ["b"] } liftIO $ decode' (simpleBody response3') `shouldBe` Just alice{ name = "ALICE" } let params3'' = "?unknown=" response3'' <- Network.Wai.Test.request defaultRequest{ rawQueryString = params3'', queryString = parseQuery params3'', pathInfo = ["b"] } liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice{ name = "Alice" } -- }}} ------------------------------------------------------------------------------ -- * 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_ respond -> respond $ 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 -- }}} ------------------------------------------------------------------------------ -- * 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 $ \ _ respond -> respond $ 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 $ \ _ respond -> respond $ 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 -- }}} ------------------------------------------------------------------------------ -- * 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 beholder :: Animal beholder = Animal "Beholder" 0 -- }}} servant-server-0.15/test/0000755000000000000000000000000007346545000013575 5ustar0000000000000000servant-server-0.15/test/Spec.hs0000644000000000000000000000005407346545000015022 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} servant-server-0.15/test/doctests.hs0000644000000000000000000000157207346545000015766 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Main (doctests) -- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module provides doctests for a project based on the actual versions -- of the packages it was built with. It requires a corresponding Setup.lhs -- to be added to the project ----------------------------------------------------------------------------- module Main where import Build_doctests (flags, module_sources, pkgs) import Data.Foldable (traverse_) import Test.DocTest main :: IO () main = do traverse_ putStrLn args doctest args where args = flags ++ pkgs ++ module_sources