servant-server-0.11.0.1/0000755000000000000000000000000013173301562013105 5ustar0000000000000000servant-server-0.11.0.1/CHANGELOG.md0000644000000000000000000001172013173301562014717 0ustar00000000000000000.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.11.0.1/Setup.lhs0000644000000000000000000000121413173301562014713 0ustar0000000000000000\begin{code} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} module Main (main) where #ifndef MIN_VERSION_cabal_doctest #define MIN_VERSION_cabal_doctest(x,y,z) 0 #endif #if MIN_VERSION_cabal_doctest(1,0,0) import Distribution.Extra.Doctest ( defaultMainWithDoctests ) main :: IO () main = defaultMainWithDoctests "doctests" #else #ifdef MIN_VERSION_Cabal #warning You are configuring this package without cabal-doctest installed. \ The doctests test-suite will not work as a result. \ To fix this, install cabal-doctest before configuring. #endif import Distribution.Simple main :: IO () main = defaultMain #endif \end{code} servant-server-0.11.0.1/LICENSE0000644000000000000000000000306113173301562014112 0ustar0000000000000000Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 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.11.0.1/servant-server.cabal0000644000000000000000000001205113173301562017056 0ustar0000000000000000name: servant-server version: 0.11.0.1 synopsis: A family of combinators for defining webservices APIs and serving them 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, Servant Contributors category: Servant Web build-type: Custom cabal-version: >=1.10 tested-with: GHC==7.8.4 GHC==7.10.3 GHC==8.0.2 GHC==8.2.1 extra-source-files: include/*.h CHANGELOG.md README.md bug-reports: http://github.com/haskell-servant/servant/issues 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.1 && <1.1 library exposed-modules: Servant Servant.Server Servant.Server.Experimental.Auth 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.Utils.StaticFiles build-depends: base >= 4.7 && < 4.11 , base-compat >= 0.9 && < 0.10 , aeson >= 0.7 && < 1.3 , attoparsec >= 0.12 && < 0.14 , base64-bytestring >= 1.0 && < 1.1 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6 , exceptions >= 0.8 && < 0.9 , http-api-data >= 0.3 && < 0.4 , http-types >= 0.8 && < 0.11 , network-uri >= 2.6 && < 2.7 , monad-control >= 1.0.0.4 && < 1.1 , mtl >= 2 && < 2.3 , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4 , servant == 0.11.* , split >= 0.2 && < 0.3 , string-conversions >= 0.3 && < 0.5 , system-filepath >= 0.4 && < 0.5 , filepath >= 1 && < 1.5 , resourcet >= 1.1.6 && <1.2 , tagged >= 0.7.3 && <0.9 , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 , transformers-base >= 0.4.4 && < 0.5 , transformers-compat>= 0.4 && < 0.6 , wai >= 3.0 && < 3.3 , wai-app-static >= 3.1 && < 3.2 , warp >= 3.0 && < 3.3 , word8 >= 0.1 && < 0.2 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall if impl(ghc >= 8.0) ghc-options: -Wno-redundant-constraints include-dirs: include executable greet main-is: greet.hs hs-source-dirs: example ghc-options: -Wall default-language: Haskell2010 build-depends: base , servant , servant-server , aeson , warp , wai , text 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.StreamingSpec Servant.Server.UsingContextSpec Servant.Server.UsingContextSpec.TestCombinators Servant.ServerSpec Servant.Utils.StaticFilesSpec build-tool-depends: hspec-discover:hspec-discover build-depends: base == 4.* , base-compat , aeson , base64-bytestring , bytestring , directory , exceptions , hspec == 2.* , hspec-wai >= 0.8 && <0.9 , http-types , mtl , network >= 2.6 , parsec , QuickCheck , resourcet , safe , servant , servant-server , should-not-typecheck == 2.1.* , string-conversions , temporary , text , transformers , transformers-compat , wai , wai-extra , warp test-suite doctests build-depends: base , servant , doctest , filemanip , directory , filepath type: exitcode-stdio-1.0 main-is: test/doctests.hs buildable: True default-language: Haskell2010 ghc-options: -Wall -threaded if impl(ghc >= 8.2) x-doctest-options: -fdiagnostics-color=never include-dirs: include servant-server-0.11.0.1/README.md0000644000000000000000000000105413173301562014364 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.11.0.1/src/0000755000000000000000000000000013173301562013674 5ustar0000000000000000servant-server-0.11.0.1/src/Servant.hs0000644000000000000000000000125113173301562015651 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.Utils.Links, module Servant.Utils.StaticFiles, -- | Useful re-exports Proxy(..), throwError ) where import Control.Monad.Error.Class (throwError) import Data.Proxy import Servant.API import Servant.Server import Servant.Utils.Links import Servant.Utils.StaticFiles servant-server-0.11.0.1/src/Servant/0000755000000000000000000000000013173301562015316 5ustar0000000000000000servant-server-0.11.0.1/src/Servant/Server.hs0000644000000000000000000001356613173301562017133 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# 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 -- $enterDoc -- ** Basic functions and datatypes , enter , (:~>)(..) -- ** `Nat` utilities , liftNat , runReaderTNat , evalStateTLNat , evalStateTSNat , logWriterTLNat , logWriterTSNat -- ** Functions based on , hoistNat , embedNat , squashNat , generalizeNat , 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 import Servant.Utils.Enter -- * 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)))) -- | 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))) -- Documentation -- $enterDoc -- Sometimes our cherished `ExceptT` monad isn't quite the type you'd like for -- your handlers. Maybe you want to thread some configuration in a @Reader@ -- monad. Or have your types ensure that your handlers don't do any IO. Enter -- `enter`. -- -- With `enter`, you can provide a function, wrapped in the `(:~>)` / `NT` -- newtype, 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 -- >>> import qualified Control.Category as C -- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String :<|> Raw :<|> EmptyAPI -- >>> let readerServer = return 1797 :<|> ask :<|> Tagged (error "raw server") :<|> emptyServer :: ServerT ReaderAPI (Reader String) -- >>> let nt = generalizeNat C.. (runReaderTNat "hi") :: Reader String :~> Handler -- >>> let mainServer = enter nt readerServer :: Server ReaderAPI -- -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeOperators -- >>> import Servant.API -- >>> import Servant.Server servant-server-0.11.0.1/src/Servant/Server/0000755000000000000000000000000013173301562016564 5ustar0000000000000000servant-server-0.11.0.1/src/Servant/Server/Internal.hs0000644000000000000000000006027313173301562020704 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} #include "overlapping-compat.h" module Servant.Server.Internal ( module Servant.Server.Internal , module Servant.Server.Internal.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.Trans (liftIO) import Control.Monad.Trans.Resource (runResourceT) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL import Data.Maybe (fromMaybe, mapMaybe) import Data.Either (partitionEithers) import Data.String (fromString) import Data.String.Conversions (cs, (<>)) import Data.Tagged (Tagged(..), untag) import qualified Data.Text as T import Data.Typeable import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.Socket (SockAddr) import Network.Wai (Application, Request, Response, httpVersion, isSecure, lazyRequestBody, rawQueryString, remoteHost, requestHeaders, requestMethod, responseLBS, vault) import Prelude () import Prelude.Compat import Web.HttpApiData (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPieceMaybe, parseUrlPieces) import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture, CaptureAll, Verb, EmptyAPI, ReflectMethod(reflectMethod), IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, Vault, WithNamedContext) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), AllMime, canHandleAcceptH) import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) import Servant.Server.Internal.Context import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Handler import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr class HasServer api context where type ServerT api (m :: * -> *) :: * route :: Proxy api -> Context context -> Delayed env (Server api) -> Router env type Server api = ServerT api Handler -- * Instances -- | A server for @a ':<|>' b@ first tries to match the request against the route -- represented by @a@ and if it fails tries @b@. You must provide a request -- handler for each route. -- -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books -- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books -- > -- > server :: Server MyApi -- > server = listAllBooks :<|> postBook -- > where listAllBooks = ... -- > postBook book = ... instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) context where type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server)) (route pb context ((\ (_ :<|> b) -> b) <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b -- | If you use 'Capture' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by the 'Capture'. -- This lets servant worry about getting it from the URL and turning -- it into a value of the type you specify. -- -- You can control how it'll be converted from 'Text' to your type -- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- -- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book -- > -- > server :: Server MyApi -- > server = getBook -- > where getBook :: Text -> Handler Book -- > getBook isbn = ... instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) => HasServer (Capture capture a :> api) context where type ServerT (Capture capture a :> api) m = a -> ServerT api m route Proxy context d = CaptureRouter $ route (Proxy :: Proxy api) context (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of Nothing -> delayedFail err400 Just v -> return v ) -- | If you use 'CaptureAll' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a -- function that takes an argument of a list of the type specified by -- the 'CaptureAll'. This lets servant worry about getting values from -- the URL and turning them into values of the type you specify. -- -- You can control how they'll be converted from 'Text' to your type -- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- -- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile -- > -- > server :: Server MyApi -- > server = getSourceFile -- > where getSourceFile :: [Text] -> Handler Book -- > getSourceFile pathSegments = ... instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) => HasServer (CaptureAll capture a :> sublayout) context where type ServerT (CaptureAll capture a :> sublayout) m = [a] -> ServerT sublayout m route Proxy context d = CaptureAllRouter $ route (Proxy :: Proxy sublayout) context (addCapture d $ \ txts -> case parseUrlPieces txts of Left _ -> delayedFail err400 Right v -> return v ) allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead allowedMethod :: Method -> Request -> Bool allowedMethod method request = allowedMethodHead method request || requestMethod request == method processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method -> Maybe [(HeaderName, B.ByteString)] -> Request -> RouteResult Response processMethodRouter handleA status method headers request = case handleA of Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does Just (contentT, body) -> Route $ responseLBS status hdrs bdy where bdy = if allowedMethodHead method request then "" else body hdrs = (hContentType, cs contentT) : (fromMaybe [] headers) methodCheck :: Method -> Request -> DelayedIO () methodCheck method request | allowedMethod method request = return () | otherwise = delayedFail err405 -- This has switched between using 'Fail' and 'FailFatal' a number of -- times. If the 'acceptCheck' is run after the body check (which would -- be morally right), then we have to set this to 'FailFatal', because -- the body check is not reversible, and therefore backtracking after the -- body check is no longer an option. However, we now run the accept -- check before the body check and can therefore afford to make it -- recoverable. acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO () acceptCheck proxy accH | canHandleAcceptH proxy (AcceptHeader accH) = return () | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a) => Method -> Proxy ctypes -> Status -> Delayed env (Handler a) -> Router env methodRouter method proxy status action = leafRouter route' where route' env request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH ) env request respond $ \ output -> do let handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) => Method -> Proxy ctypes -> Status -> Delayed env (Handler (Headers h v)) -> Router env methodRouterHeaders method proxy status action = leafRouter route' where route' env request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH ) env request respond $ \ output -> do let headers = getHeaders output handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) processMethodRouter handleA status method (Just headers) request instance OVERLAPPABLE_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status ) => HasServer (Verb method status ctypes a) context where type ServerT (Verb method status ctypes a) m = m a route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) instance OVERLAPPING_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status , GetHeaders (Headers h a) ) => HasServer (Verb method status ctypes (Headers h a)) context where type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by 'Header'. -- This lets servant worry about extracting it from the request and turning -- it into a value of the type you specify. -- -- All it asks is for a 'FromHttpApiData' instance. -- -- Example: -- -- > newtype Referer = Referer Text -- > deriving (Eq, Show, FromHttpApiData) -- > -- > -- GET /view-my-referer -- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer -- > -- > server :: Server MyApi -- > server = viewReferer -- > where viewReferer :: Referer -> Handler referer -- > viewReferer referer = return referer instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) => HasServer (Header sym a :> api) context where type ServerT (Header sym a :> api) m = Maybe a -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addHeaderCheck` withRequest headerCheck where headerName = symbolVal (Proxy :: Proxy sym) headerCheck req = case lookup (fromString headerName) (requestHeaders req) of Nothing -> return Nothing Just txt -> case parseHeader txt of Left e -> delayedFailFatal err400 { errBody = cs $ "Error parsing header " <> fromString headerName <> " failed: " <> e } Right header -> return $ Just header -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @'Maybe' 'Text'@. -- -- This lets servant worry about looking it up in the query string -- and turning it into a value of the type you specify, enclosed -- in 'Maybe', because it may not be there and servant would then -- hand you 'Nothing'. -- -- You can control how it'll be converted from 'Text' to your type -- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- -- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooksBy -- > where getBooksBy :: Maybe Text -> Handler [Book] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author... instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) => HasServer (QueryParam sym a :> api) context where type ServerT (QueryParam sym a :> api) m = Maybe a -> ServerT api m route Proxy context subserver = let querytext req = parseQueryText $ rawQueryString req parseParam req = case lookup paramname (querytext req) of Nothing -> return Nothing -- param absent from the query string Just Nothing -> return Nothing -- param present with no value -> Nothing Just (Just v) -> case parseQueryParam v of Left e -> delayedFailFatal err400 { errBody = cs $ "Error parsing query parameter " <> paramname <> " failed: " <> e } Right param -> return $ Just param delayed = addParameterCheck subserver . withRequest $ \req -> parseParam req in route (Proxy :: Proxy api) context delayed where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @['Text']@. -- -- This lets servant worry about looking up 0 or more values in the query string -- associated to @authors@ and turning each of them into a value of -- the type you specify. -- -- You can control how the individual values are converted from 'Text' to your type -- by simply providing an instance of 'FromHttpApiData' for your type. -- -- Example: -- -- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooksBy -- > where getBooksBy :: [Text] -> Handler [Book] -- > getBooksBy authors = ...return all books by these authors... instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) => HasServer (QueryParams sym a :> api) context where type ServerT (QueryParams sym a :> api) m = [a] -> ServerT api m route Proxy context subserver = 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 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 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 ) => HasServer (ReqBody list a :> api) context where type ServerT (ReqBody list a :> api) m = a -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context $ addBodyCheck subserver 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 -> delayedFailFatal 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 mrqbody of Left e -> delayedFailFatal err400 { errBody = cs e } Right v -> return v -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @api@. instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where type ServerT (path :> api) m = ServerT api m route Proxy context subserver = pathRouter (cs (symbolVal proxyPath)) (route (Proxy :: Proxy api) context subserver) where proxyPath = Proxy :: Proxy path instance HasServer api context => HasServer (RemoteHost :> api) context where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver remoteHost) instance HasServer api context => HasServer (IsSecure :> api) context where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver secure) where secure req = if isSecure req then Secure else NotSecure instance HasServer api context => HasServer (Vault :> api) context where type ServerT (Vault :> api) m = Vault -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver vault) instance HasServer api context => HasServer (HttpVersion :> api) context where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver httpVersion) -- | 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 -- | Basic Authentication instance ( KnownSymbol realm , HasServer api context , HasContextEntry context (BasicAuthCheck usr) ) => HasServer (BasicAuth realm usr :> api) context where type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m route Proxy context subserver = route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck) where realm = BC8.pack $ symbolVal (Proxy :: Proxy realm) basicAuthContext = getContextEntry context authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext -- * helpers ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP -- * General Authentication -- * contexts instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) => HasServer (WithNamedContext name subContext subApi) context where type ServerT (WithNamedContext name subContext subApi) m = ServerT subApi m route Proxy context delayed = route subProxy subContext delayed where subProxy :: Proxy subApi subProxy = Proxy subContext :: Context subContext subContext = descendIntoNamedContext (Proxy :: Proxy name) context servant-server-0.11.0.1/src/Servant/Server/Experimental/0000755000000000000000000000000013173301562021221 5ustar0000000000000000servant-server-0.11.0.1/src/Servant/Server/Experimental/Auth.hs0000644000000000000000000000573513173301562022470 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} 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, ServerT, getContextEntry, route) import Servant.Server.Internal.RoutingApplication (addAuthCheck, delayedFailFatal, DelayedIO, withRequest) import Servant.Server.Internal.Handler (Handler, runHandler) -- * 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 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.11.0.1/src/Servant/Server/Internal/0000755000000000000000000000000013173301562020340 5ustar0000000000000000servant-server-0.11.0.1/src/Servant/Server/Internal/Handler.hs0000644000000000000000000000303513173301562022252 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# 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, 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 ) 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.11.0.1/src/Servant/Server/Internal/Router.hs0000644000000000000000000001773313173301562022167 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where import Data.Map (Map) import qualified Data.Map as M import Data.Monoid 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.11.0.1/src/Servant/Server/Internal/ServantErr.hs0000644000000000000000000003166613173301562023003 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} module Servant.Server.Internal.ServantErr where import Control.Exception (Exception) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import Data.Typeable (Typeable) import qualified Network.HTTP.Types as HTTP import Network.Wai (Response, responseLBS) data ServantErr = ServantErr { errHTTPCode :: Int , errReasonPhrase :: String , errBody :: LBS.ByteString , errHeaders :: [HTTP.Header] } deriving (Show, Eq, Read, Typeable) instance Exception ServantErr responseServantErr :: ServantErr -> Response responseServantErr ServantErr{..} = responseLBS status errHeaders errBody where status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase) -- | 'err300' Multiple Choices -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err300 { errBody = "I can't choose." } -- err300 :: ServantErr err300 = ServantErr { errHTTPCode = 300 , errReasonPhrase = "Multiple Choices" , errBody = "" , errHeaders = [] } -- | 'err301' Moved Permanently -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err301 -- err301 :: ServantErr err301 = ServantErr { errHTTPCode = 301 , errReasonPhrase = "Moved Permanently" , errBody = "" , errHeaders = [] } -- | 'err302' Found -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err302 -- err302 :: ServantErr err302 = ServantErr { errHTTPCode = 302 , errReasonPhrase = "Found" , errBody = "" , errHeaders = [] } -- | 'err303' See Other -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err303 -- err303 :: ServantErr err303 = ServantErr { errHTTPCode = 303 , errReasonPhrase = "See Other" , errBody = "" , errHeaders = [] } -- | 'err304' Not Modified -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err304 -- err304 :: ServantErr err304 = ServantErr { errHTTPCode = 304 , errReasonPhrase = "Not Modified" , errBody = "" , errHeaders = [] } -- | 'err305' Use Proxy -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err305 -- err305 :: ServantErr err305 = ServantErr { errHTTPCode = 305 , errReasonPhrase = "Use Proxy" , errBody = "" , errHeaders = [] } -- | 'err307' Temporary Redirect -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err307 -- err307 :: ServantErr err307 = ServantErr { errHTTPCode = 307 , errReasonPhrase = "Temporary Redirect" , errBody = "" , errHeaders = [] } -- | 'err400' Bad Request -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." } -- err400 :: ServantErr err400 = ServantErr { errHTTPCode = 400 , errReasonPhrase = "Bad Request" , errBody = "" , errHeaders = [] } -- | 'err401' Unauthorized -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." } -- err401 :: ServantErr err401 = ServantErr { errHTTPCode = 401 , errReasonPhrase = "Unauthorized" , errBody = "" , errHeaders = [] } -- | 'err402' Payment Required -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." } -- err402 :: ServantErr err402 = ServantErr { errHTTPCode = 402 , errReasonPhrase = "Payment Required" , errBody = "" , errHeaders = [] } -- | 'err403' Forbidden -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err403 { errBody = "Please login first." } -- err403 :: ServantErr err403 = ServantErr { errHTTPCode = 403 , errReasonPhrase = "Forbidden" , errBody = "" , errHeaders = [] } -- | 'err404' Not Found -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } -- err404 :: ServantErr err404 = ServantErr { errHTTPCode = 404 , errReasonPhrase = "Not Found" , errBody = "" , errHeaders = [] } -- | 'err405' Method Not Allowed -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." } -- err405 :: ServantErr err405 = ServantErr { errHTTPCode = 405 , errReasonPhrase = "Method Not Allowed" , errBody = "" , errHeaders = [] } -- | 'err406' Not Acceptable -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err406 -- err406 :: ServantErr err406 = ServantErr { errHTTPCode = 406 , errReasonPhrase = "Not Acceptable" , errBody = "" , errHeaders = [] } -- | 'err407' Proxy Authentication Required -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err407 -- err407 :: ServantErr err407 = ServantErr { errHTTPCode = 407 , errReasonPhrase = "Proxy Authentication Required" , errBody = "" , errHeaders = [] } -- | 'err409' Conflict -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" } -- err409 :: ServantErr err409 = ServantErr { errHTTPCode = 409 , errReasonPhrase = "Conflict" , errBody = "" , errHeaders = [] } -- | 'err410' Gone -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." } -- err410 :: ServantErr err410 = ServantErr { errHTTPCode = 410 , errReasonPhrase = "Gone" , errBody = "" , errHeaders = [] } -- | 'err411' Length Required -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError err411 -- err411 :: ServantErr err411 = ServantErr { errHTTPCode = 411 , errReasonPhrase = "Length Required" , errBody = "" , errHeaders = [] } -- | 'err412' Precondition Failed -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" } -- err412 :: ServantErr err412 = ServantErr { errHTTPCode = 412 , errReasonPhrase = "Precondition Failed" , errBody = "" , errHeaders = [] } -- | 'err413' Request Entity Too Large -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." } -- err413 :: ServantErr err413 = ServantErr { errHTTPCode = 413 , errReasonPhrase = "Request Entity Too Large" , errBody = "" , errHeaders = [] } -- | 'err414' Request-URI Too Large -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." } -- err414 :: ServantErr err414 = ServantErr { errHTTPCode = 414 , errReasonPhrase = "Request-URI Too Large" , errBody = "" , errHeaders = [] } -- | 'err415' Unsupported Media Type -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" } -- err415 :: ServantErr err415 = ServantErr { errHTTPCode = 415 , errReasonPhrase = "Unsupported Media Type" , errBody = "" , errHeaders = [] } -- | 'err416' Request range not satisfiable -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." } -- err416 :: ServantErr err416 = ServantErr { errHTTPCode = 416 , errReasonPhrase = "Request range not satisfiable" , errBody = "" , errHeaders = [] } -- | 'err417' Expectation Failed -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." } -- err417 :: ServantErr err417 = ServantErr { errHTTPCode = 417 , errReasonPhrase = "Expectation Failed" , errBody = "" , errHeaders = [] } -- | 'err418' Expectation Failed -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err418 { errBody = "Apologies, this is not a webserver but a teapot." } -- err418 :: ServantErr err418 = ServantErr { errHTTPCode = 418 , errReasonPhrase = "I'm a teapot" , errBody = "" , errHeaders = [] } -- | 'err422' Unprocessable Entity -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err422 { errBody = "I understood your request, but can't process it." } -- err422 :: ServantErr err422 = ServantErr { errHTTPCode = 422 , errReasonPhrase = "Unprocessable Entity" , errBody = "" , errHeaders = [] } -- | 'err500' Internal Server Error -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" } -- err500 :: ServantErr err500 = ServantErr { errHTTPCode = 500 , errReasonPhrase = "Internal Server Error" , errBody = "" , errHeaders = [] } -- | 'err501' Not Implemented -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." } -- err501 :: ServantErr err501 = ServantErr { errHTTPCode = 501 , errReasonPhrase = "Not Implemented" , errBody = "" , errHeaders = [] } -- | 'err502' Bad Gateway -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." } -- err502 :: ServantErr err502 = ServantErr { errHTTPCode = 502 , errReasonPhrase = "Bad Gateway" , errBody = "" , errHeaders = [] } -- | 'err503' Service Unavailable -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." } -- err503 :: ServantErr err503 = ServantErr { errHTTPCode = 503 , errReasonPhrase = "Service Unavailable" , errBody = "" , errHeaders = [] } -- | 'err504' Gateway Time-out -- -- Example: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." } -- err504 :: ServantErr err504 = ServantErr { errHTTPCode = 504 , errReasonPhrase = "Gateway Time-out" , errBody = "" , errHeaders = [] } -- | 'err505' HTTP Version not supported -- -- Example usage: -- -- > failingHandler :: Handler () -- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." } -- err505 :: ServantErr err505 = ServantErr { errHTTPCode = 505 , errReasonPhrase = "HTTP Version not supported" , errBody = "" , errHeaders = [] } servant-server-0.11.0.1/src/Servant/Server/Internal/RoutingApplication.hs0000644000000000000000000003405213173301562024513 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.RoutingApplication where import Control.Monad (ap, liftM) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch (MonadThrow (..)) import Control.Monad.Reader (MonadReader (..), ReaderT, runReaderT) import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..), defaultLiftBaseWith, defaultRestoreM) import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runResourceT, transResourceT) 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 , MonadBase IO , MonadThrow , MonadResource ) 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 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 $ do 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.11.0.1/src/Servant/Server/Internal/Context.hs0000644000000000000000000001032413173301562022320 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} #include "overlapping-compat.h" 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 'Servant.Utils.Enter'.) 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.11.0.1/src/Servant/Server/Internal/BasicAuth.hs0000644000000000000000000000534613173301562022547 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.11.0.1/src/Servant/Utils/0000755000000000000000000000000013173301562016416 5ustar0000000000000000servant-server-0.11.0.1/src/Servant/Utils/StaticFiles.hs0000644000000000000000000000670613173301562021175 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.Utils.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 (Server, Tagged (..)) import System.FilePath (addTrailingPathSeparator) #if !MIN_VERSION_wai_app_static(3,1,0) import Filesystem.Path.CurrentOS (decodeString) #endif import WaiAppStatic.Storage.Filesystem (ETagLookup) -- | 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 -> Server Raw serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath -- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`. serveDirectoryFileServer :: FilePath -> Server Raw serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath -- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'. serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> Server Raw serveDirectoryWebAppLookup etag = serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath -- | Uses 'embeddedSettings'. serveDirectoryEmbedded :: [(FilePath, ByteString)] -> Server Raw 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 -> Server Raw 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 -> Server Raw serveDirectory = serveDirectoryFileServer {-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-} fixPath :: FilePath -> FilePath fixPath = #if MIN_VERSION_wai_app_static(3,1,0) addTrailingPathSeparator #else decodeString . addTrailingPathSeparator #endif servant-server-0.11.0.1/example/0000755000000000000000000000000013173301562014540 5ustar0000000000000000servant-server-0.11.0.1/example/greet.hs0000644000000000000000000000401013173301562016175 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} import Data.Aeson import Data.Monoid 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.11.0.1/include/0000755000000000000000000000000013173301562014530 5ustar0000000000000000servant-server-0.11.0.1/include/overlapping-compat.h0000644000000000000000000000032213173301562020505 0ustar0000000000000000#if __GLASGOW_HASKELL__ >= 710 #define OVERLAPPABLE_ {-# OVERLAPPABLE #-} #define OVERLAPPING_ {-# OVERLAPPING #-} #else {-# LANGUAGE OverlappingInstances #-} #define OVERLAPPABLE_ #define OVERLAPPING_ #endif servant-server-0.11.0.1/test/0000755000000000000000000000000013173301562014064 5ustar0000000000000000servant-server-0.11.0.1/test/doctests.hs0000644000000000000000000000147213173301562016254 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, pkgs, module_sources) import Data.Foldable (traverse_) import Test.DocTest main :: IO () main = do traverse_ putStrLn args doctest args where args = flags ++ pkgs ++ module_sources servant-server-0.11.0.1/test/Spec.hs0000644000000000000000000000005413173301562015311 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} servant-server-0.11.0.1/test/Servant/0000755000000000000000000000000013173301562015506 5ustar0000000000000000servant-server-0.11.0.1/test/Servant/ServerSpec.hs0000644000000000000000000007143113173301562020131 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} module Servant.ServerSpec where import Control.Monad (forM_, when, unless) import Control.Monad.Error.Class (MonadError (..)) import Data.Aeson (FromJSON, ToJSON, decode', encode) import qualified Data.ByteString.Base64 as Base64 import Data.Char (toUpper) import Data.Monoid import Data.Proxy (Proxy (Proxy)) import Data.String (fromString) import Data.String.Conversions (cs) import qualified Data.Text as T import GHC.Generics (Generic) import Network.HTTP.Types (Status (..), hAccept, hContentType, methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut, ok200, #if MIN_VERSION_http_types(0,10,0) imATeapot418, #else imATeaPot418, #endif parseQuery) import Network.Wai (Application, Request, requestHeaders, pathInfo, queryString, rawQueryString, responseLBS) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody, simpleHeaders, simpleStatus) import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData(BasicAuthData), Capture, CaptureAll, Delete, Get, Header (..), Headers, HttpVersion, IsSecure (..), JSON, NoContent (..), Patch, PlainText, Post, Put, EmptyAPI, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Server (Server, Handler, Tagged (..), err401, err403, err404, serve, serveWithContext, Context((:.), EmptyContext), emptyServer) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import qualified Test.Hspec.Wai as THW import Test.Hspec.Wai (get, liftIO, matchHeaders, matchStatus, shouldRespondWith, with, (<:>)) import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck), BasicAuthResult(Authorized,Unauthorized)) import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) import Servant.Server.Internal.Context (NamedContext(..)) #if !MIN_VERSION_http_types(0,10,0) imATeapot418 :: Status imATeapot418 = imATeaPot418 #endif -- * 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 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 ) 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") 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")] 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 (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 expectsInt)) $ do let delete' x = THW.request methodDelete x [("MyHeader", "5")] it "passes the header to the handler (Int)" $ delete' "/" "" `shouldRespondWith` 200 with (return (serve headerApi expectsString)) $ do 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 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.11.0.1/test/Servant/ArbitraryMonadServerSpec.hs0000644000000000000000000000351513173301562022766 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Servant.ArbitraryMonadServerSpec where import qualified Control.Category as C import Control.Monad.Reader import Data.Functor.Identity import Data.Proxy import Servant.API import Servant.Server import Test.Hspec (Spec, describe, it) import Test.Hspec.Wai (get, matchStatus, post, shouldRespondWith, with) 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 combinedAPI :: Proxy CombinedAPI combinedAPI = Proxy readerServer' :: ServerT ReaderAPI (Reader String) readerServer' = return 1797 :<|> ask fReader :: Reader String :~> Handler fReader = generalizeNat C.. (runReaderTNat "hi") readerServer :: Server ReaderAPI readerServer = enter fReader readerServer' combinedReaderServer' :: ServerT CombinedAPI (Reader String) combinedReaderServer' = readerServer' :<|> enter (generalizeNat :: Identity :~> Reader String) (return True) combinedReaderServer :: Server CombinedAPI combinedReaderServer = enter 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.11.0.1/test/Servant/Server/0000755000000000000000000000000013173301562016754 5ustar0000000000000000servant-server-0.11.0.1/test/Servant/Server/RouterSpec.hs0000644000000000000000000002243513173301562021411 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 Test.Hspec import Test.Hspec.Wai (get, shouldRespondWith, with) import Servant.API import Servant.Server import Servant.Server.Internal 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.11.0.1/test/Servant/Server/UsingContextSpec.hs0000644000000000000000000000712613173301562022563 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.11.0.1/test/Servant/Server/ErrorSpec.hs0000644000000000000000000002543313173301562021223 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 errorChoiceApi :: Proxy ErrorChoiceApi errorChoiceApi = Proxy errorChoiceServer :: Server ErrorChoiceApi errorChoiceServer = return 0 :<|> return 1 :<|> return 2 :<|> (\_ -> return 3) :<|> (\_ -> return 4) :<|> (\_ -> return 5) 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 -- }}} ------------------------------------------------------------------------------ -- * 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.11.0.1/test/Servant/Server/StreamingSpec.hs0000644000000000000000000000642113173301562022057 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.11.0.1/test/Servant/Server/UsingContextSpec/0000755000000000000000000000000013173301562022221 5ustar0000000000000000servant-server-0.11.0.1/test/Servant/Server/UsingContextSpec/TestCombinators.hs0000644000000000000000000000421713173301562025701 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 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 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 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.11.0.1/test/Servant/Server/Internal/0000755000000000000000000000000013173301562020530 5ustar0000000000000000servant-server-0.11.0.1/test/Servant/Server/Internal/ContextSpec.hs0000644000000000000000000000460413173301562023327 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-} module Servant.Server.Internal.ContextSpec (spec) where import Data.Proxy (Proxy (..)) import Test.Hspec (Spec, describe, it, shouldBe, context) 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.11.0.1/test/Servant/Server/Internal/RoutingApplicationSpec.hs0000644000000000000000000001142013173301562025510 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.Trans.Resource (register) import Control.Monad.IO.Class import Data.IORef import Data.Proxy import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import Servant import Servant.Server.Internal.RoutingApplication import Network.Wai (defaultRequest) import Test.Hspec import Test.Hspec.Wai (request, shouldRespondWith, with) import 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 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.11.0.1/test/Servant/Utils/0000755000000000000000000000000013173301562016606 5ustar0000000000000000servant-server-0.11.0.1/test/Servant/Utils/StaticFilesSpec.hs0000644000000000000000000000416113173301562022171 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Utils.StaticFilesSpec where import Control.Exception (bracket) import Data.Proxy (Proxy (Proxy)) import Network.Wai (Application) import System.Directory (createDirectory, getCurrentDirectory, setCurrentDirectory) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec (Spec, around_, describe, it) import Test.Hspec.Wai (get, shouldRespondWith, with) import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON) import Servant.Server (Server, serve) import Servant.ServerSpec (Person (Person)) import Servant.Utils.StaticFiles (serveDirectoryFileServer) 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"