servant-server 0.4.4.7 → 0.5
raw patch · 26 files changed
+2529/−1077 lines, 26 filesdep +base-compatdep +base64-bytestringdep +containersdep −eitherdep ~networkdep ~safedep ~servantsetup-changed
Dependencies added: base-compat, base64-bytestring, containers, http-api-data, should-not-typecheck, transformers-compat, word8
Dependencies removed: either
Dependency ranges changed: network, safe, servant
Files
- CHANGELOG.md +14/−3
- LICENSE +1/−1
- README.md +2/−9
- Setup.hs +1/−1
- example/greet.hs +14/−14
- include/overlapping-compat.h +8/−0
- servant-server.cabal +32/−8
- src/Servant.hs +5/−8
- src/Servant/Server.hs +32/−11
- src/Servant/Server/Experimental/Auth.hs +66/−0
- src/Servant/Server/Internal.hs +500/−982
- src/Servant/Server/Internal/BasicAuth.hs +69/−0
- src/Servant/Server/Internal/Context.hs +104/−0
- src/Servant/Server/Internal/Enter.hs +3/−11
- src/Servant/Server/Internal/Router.hs +93/−0
- src/Servant/Server/Internal/RoutingApplication.hs +269/−0
- src/Servant/Server/Internal/ServantErr.hs +10/−5
- src/Servant/Utils/StaticFiles.hs +6/−5
- test/Doctests.hs +29/−19
- test/Servant/Server/ErrorSpec.hs +256/−0
- test/Servant/Server/Internal/ContextSpec.hs +61/−0
- test/Servant/Server/Internal/EnterSpec.hs +59/−0
- test/Servant/Server/UsingContextSpec.hs +125/−0
- test/Servant/Server/UsingContextSpec/TestCombinators.hs +72/−0
- test/Servant/ServerSpec.hs +636/−0
- test/Servant/Utils/StaticFilesSpec.hs +62/−0
CHANGELOG.md view
@@ -1,7 +1,18 @@-0.4.3------+0.5+---- -* Bump aeson upper-bound to < 0.11+* 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 -----
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014, Zalora South East Asia Pte Ltd+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved.
README.md view
@@ -4,14 +4,7 @@ This library lets you *implement* an HTTP server with handlers for each endpoint of a servant API, handling most of the boilerplate for you. -## Tutorial--We've written a [tutorial](http://haskell-servant.github.io/tutorial/) that introduces the core types and features of servant.+## Getting started -## Repositories and Haddocks+We've written a [tutorial](http://haskell-servant.github.io/tutorial/) 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. -- The core [servant](http://github.com/haskell-servant/servant/tree/master/servant) package - [docs](http://hackage.haskell.org/package/servant)-- Implementing an HTTP server for a webservice API with [servant-server](http://github.com/haskell-servant/servant/tree/master/servant-server) - [docs](http://hackage.haskell.org/package/servant-server)-- (Haskell) client-side function generation with [servant-client](http://github.com/haskell-servant/servant/tree/master/servant-client) - [docs](http://hackage.haskell.org/package/servant-client)-- (Javascript) client-side function generation with [servant-jquery](http://github.com/haskell-servant/servant/tree/master/servant-jquery) - [docs](http://hackage.haskell.org/package/servant-jquery)-- API docs generation with [servant-docs](http://github.com/haskell-servant/servant/tree/master/servant-docs) - [docs](http://hackage.haskell.org/package/servant-docs)
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple+import Distribution.Simple main = defaultMain
example/greet.hs view
@@ -1,19 +1,19 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeOperators #-}+{-# 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 Data.Aeson+import Data.Monoid+import Data.Proxy+import Data.Text+import GHC.Generics+import Network.Wai+import Network.Wai.Handler.Warp -import Servant+import Servant -- * Example @@ -44,7 +44,7 @@ -- 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 'EitherT ServantErr IO' monad.+-- Each handler runs in the 'ExceptT ServantErr IO' monad. server :: Server TestApi server = helloH :<|> postGreetH :<|> deleteGreetH
+ include/overlapping-compat.h view
@@ -0,0 +1,8 @@+#if __GLASGOW_HASKELL__ >= 710+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}+#define OVERLAPPING_ {-# OVERLAPPING #-}+#else+{-# LANGUAGE OverlappingInstances #-}+#define OVERLAPPABLE_+#define OVERLAPPING_+#endif
servant-server.cabal view
@@ -1,5 +1,5 @@ name: servant-server-version: 0.4.4.7+version: 0.5 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them@@ -15,14 +15,15 @@ Bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE-author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni-maintainer: alpmestan@gmail.com-copyright: 2014 Zalora South East Asia Pte Ltd+author: Servant Contributors+maintainer: haskell-servant-maintainers@googlegroups.com+copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 7.8 extra-source-files:+ include/*.h CHANGELOG.md README.md bug-reports: http://github.com/haskell-servant/servant/issues@@ -35,35 +36,47 @@ exposed-modules: Servant Servant.Server+ Servant.Server.Experimental.Auth Servant.Server.Internal- Servant.Server.Internal.ServantErr+ Servant.Server.Internal.BasicAuth+ Servant.Server.Internal.Context Servant.Server.Internal.Enter+ Servant.Server.Internal.Router+ Servant.Server.Internal.RoutingApplication+ Servant.Server.Internal.ServantErr Servant.Utils.StaticFiles build-depends: base >= 4.7 && < 5+ , base-compat >= 0.9 , aeson >= 0.7 && < 0.12 , attoparsec >= 0.12 && < 0.14+ , base64-bytestring == 1.0.* , bytestring >= 0.10 && < 0.11- , either >= 4.3 && < 4.5+ , containers >= 0.5 && < 0.6+ , http-api-data >= 0.1 && < 0.3 , http-types >= 0.8 && < 0.10 , network-uri >= 2.6 && < 2.7 , mtl >= 2 && < 3 , mmorph >= 1+ , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4- , servant == 0.4.*+ , servant == 0.5.* , split >= 0.2 && < 0.3 , string-conversions >= 0.3 && < 0.5 , system-filepath >= 0.4 && < 0.5 , filepath >= 1 , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.5+ , transformers-compat>= 0.4 , wai >= 3.0 && < 3.3 , wai-app-static >= 3.0 && < 3.2 , warp >= 3.0 && < 3.3+ , word8 == 0.1.* hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall+ include-dirs: include executable greet main-is: greet.hs@@ -86,13 +99,20 @@ default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs+ other-modules:+ Servant.Server.ErrorSpec+ Servant.Server.Internal.ContextSpec+ Servant.Server.Internal.EnterSpec+ Servant.ServerSpec+ Servant.Server.UsingContextSpec+ Servant.Server.UsingContextSpec.TestCombinators+ Servant.Utils.StaticFilesSpec build-depends: base == 4.* , aeson , bytestring , bytestring-conversion , directory- , either , exceptions , hspec == 2.* , hspec-wai@@ -100,12 +120,15 @@ , network >= 2.6 , QuickCheck , parsec+ , safe , servant , servant-server , string-conversions+ , should-not-typecheck == 2.* , temporary , text , transformers+ , transformers-compat , mtl , wai , wai-extra@@ -123,3 +146,4 @@ buildable: True default-language: Haskell2010 ghc-options: -threaded+ include-dirs: include
src/Servant.hs view
@@ -5,8 +5,6 @@ module Servant.API, -- | For implementing servers for servant APIs. module Servant.Server,- -- | Using your types in request paths and query string parameters- module Servant.Common.Text, -- | Utilities on top of the servant core module Servant.Utils.Links, module Servant.Utils.StaticFiles,@@ -14,9 +12,8 @@ Proxy(..), ) where -import Data.Proxy-import Servant.API-import Servant.Common.Text-import Servant.Server-import Servant.Utils.Links-import Servant.Utils.StaticFiles+import Data.Proxy+import Servant.API+import Servant.Server+import Servant.Utils.Links+import Servant.Utils.StaticFiles
src/Servant/Server.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}@@ -8,6 +9,7 @@ module Servant.Server ( -- * Run a wai application from an API serve+ , serveWithContext , -- * Construct a wai Application from an API toApplication@@ -29,16 +31,29 @@ , evalStateTSNat , logWriterTLNat , logWriterTSNat-#if MIN_VERSION_mtl(2,2,1)- , fromExceptT-#endif -- ** Functions based on <https://hackage.haskell.org/package/mmorph mmorph> , 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@@ -67,7 +82,7 @@ , err415 , err416 , err417- -- * 5XX+ -- ** 5XX , err500 , err501 , err502@@ -77,11 +92,10 @@ ) where -import Data.Proxy (Proxy)-import Network.Wai (Application)+import Data.Proxy (Proxy)+import Network.Wai (Application) import Servant.Server.Internal import Servant.Server.Internal.Enter-import Servant.Server.Internal.ServantErr -- * Implementing Servers@@ -107,14 +121,21 @@ -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app ---serve :: HasServer layout => Proxy layout -> Server layout -> Application-serve p server = toApplication (route p server)+serve :: (HasServer layout '[]) => Proxy layout -> Server layout -> Application+serve p = serveWithContext p EmptyContext +serveWithContext :: (HasServer layout context)+ => Proxy layout -> Context context -> Server layout -> Application+serveWithContext p context server = toApplication (runRouter (route p context d))+ where+ d = Delayed r r r r (\ _ _ _ -> Route server)+ r = return (Route ()) + -- Documentation -- $enterDoc--- Sometimes our cherished `EitherT` monad isn't quite the type you'd like for+-- 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`.
+ src/Servant/Server/Experimental/Auth.hs view
@@ -0,0 +1,66 @@+{-# 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.Except (ExceptT,+ runExceptT)+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.Router (Router' (WithRequest))+import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route),+ addAuthCheck)+import Servant.Server.Internal.ServantErr (ServantErr)++-- * 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 -> ExceptT ServantErr IO usr }+ deriving (Generic, Typeable)++-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE+mkAuthHandler :: (r -> ExceptT ServantErr IO 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 = WithRequest $ \ request ->+ route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)+ where+ authHandler = unAuthHandler (getContextEntry context)+ authCheck = fmap (either FailFatal Route) . runExceptT . authHandler+
src/Servant/Server/Internal.hs view
@@ -1,982 +1,500 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-#if !MIN_VERSION_base(4,8,0)-{-# LANGUAGE OverlappingInstances #-}-#endif--module Servant.Server.Internal where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-import Data.Monoid (Monoid, mappend, mempty)-#endif-import Control.Monad.Trans.Either (EitherT, runEitherT)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.IORef (newIORef, readIORef, writeIORef)-import Data.List (unfoldr)-import Data.Maybe (catMaybes, fromMaybe)-import Data.String (fromString)-import Data.String.Conversions (cs, (<>))-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Data.Typeable-import GHC.TypeLits (KnownSymbol, symbolVal)-import Network.HTTP.Types hiding (Header, ResponseHeaders)-import Network.Wai (Application, Request, Response,- ResponseReceived, lazyRequestBody,- pathInfo, rawQueryString,- requestBody, requestHeaders,- requestMethod, responseLBS,- strictRequestBody)-import Servant.API ((:<|>) (..), (:>), Capture,- Delete, Get, Header,- MatrixFlag, MatrixParam, MatrixParams,- Patch, Post, Put, QueryFlag,- QueryParam, QueryParams, Raw,- ReqBody)-import Servant.API.ContentTypes (AcceptHeader (..),- AllCTRender (..),- AllCTUnrender (..))-import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,- getHeaders)-import Servant.Common.Text (FromText, fromText)--import Servant.Server.Internal.ServantErr--data ReqBodyState = Uncalled- | Called !B.ByteString- | Done !B.ByteString---toApplication :: RoutingApplication -> Application-toApplication ra request respond = do- reqBodyRef <- newIORef Uncalled- -- We may need to consume the requestBody more than once. In order to- -- maintain the illusion that 'requestBody' works as expected,- -- 'ReqBodyState' is introduced, and the complete body is memoized and- -- returned as many times as requested with empty "Done" marker chunks in- -- between.- -- See https://github.com/haskell-servant/servant/issues/3- let memoReqBody = do- ior <- readIORef reqBodyRef- case ior of- Uncalled -> do- r <- BL.toStrict <$> strictRequestBody request- writeIORef reqBodyRef $ Done r- return r- Called bs -> do- writeIORef reqBodyRef $ Done bs- return bs- Done bs -> do- writeIORef reqBodyRef $ Called bs- return B.empty-- ra request{ requestBody = memoReqBody } (routingRespond . routeResult)- where- routingRespond :: Either RouteMismatch Response -> IO ResponseReceived- routingRespond (Left NotFound) =- respond $ responseLBS notFound404 [] "not found"- routingRespond (Left WrongMethod) =- respond $ responseLBS methodNotAllowed405 [] "method not allowed"- routingRespond (Left (InvalidBody err)) =- respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err- routingRespond (Left UnsupportedMediaType) =- respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"- routingRespond (Left (HttpError status body)) =- respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body- routingRespond (Right response) =- respond response---- Note that the ordering of the constructors has great significance! It--- determines the Ord instance and, consequently, the monoid instance.--- * Route mismatch-data RouteMismatch =- NotFound -- ^ the usual "not found" error- | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error- | UnsupportedMediaType -- ^ request body has unsupported media type- | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error- | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.- deriving (Eq, Ord, Show)--instance Monoid RouteMismatch where- mempty = NotFound- -- The following isn't great, since it picks @InvalidBody@ based on- -- alphabetical ordering, but any choice would be arbitrary.- --- -- "As one judge said to the other, 'Be just and if you can't be just, be- -- arbitrary'" -- William Burroughs- mappend = max----- | A wrapper around @'Either' 'RouteMismatch' a@.-newtype RouteResult a =- RR { routeResult :: Either RouteMismatch a }- deriving (Eq, Show)--failWith :: RouteMismatch -> RouteResult a-failWith = RR . Left--succeedWith :: a -> RouteResult a-succeedWith = RR . Right--isMismatch :: RouteResult a -> Bool-isMismatch (RR (Left _)) = True-isMismatch _ = False---- | Like `null . pathInfo`, but works with redundant trailing slashes.-pathIsEmpty :: Request -> Bool-pathIsEmpty = f . processedPathInfo- where- f [] = True- f [""] = True- f _ = False---- | If we get a `Right`, it has precedence over everything else.------ This in particular means that if we could get several 'Right's,--- only the first we encounter would be taken into account.-instance Monoid (RouteResult a) where- mempty = RR $ Left mempty-- RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)- RR (Left _) `mappend` RR (Right y) = RR $ Right y- r `mappend` _ = r--type RoutingApplication =- Request -- ^ the request, the field 'pathInfo' may be modified by url routing- -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived--splitMatrixParameters :: Text -> (Text, Text)-splitMatrixParameters = T.break (== ';')--parsePathInfo :: Request -> [Text]-parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo- where mergePairs = concat . unfoldr pairToList- pairToList [] = Nothing- pairToList ((a, b):xs) = Just ([a, b], xs)---- | Returns a processed pathInfo from the request.------ In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be--- processed, so routing works as intended. Therefor this function should be used to access--- the pathInfo for routing purposes.-processedPathInfo :: Request -> [Text]-processedPathInfo r =- case pinfo of- (x:xs) | T.head x == ';' -> xs- _ -> pinfo- where pinfo = parsePathInfo r--class HasServer layout where- type ServerT layout (m :: * -> *) :: *-- route :: Proxy layout -> Server layout -> RoutingApplication--type Server layout = ServerT layout (EitherT ServantErr IO)---- * 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, HasServer b) => HasServer (a :<|> b) where-- type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m-- route Proxy (a :<|> b) request respond =- route pa a request $ \mResponse ->- if isMismatch mResponse- then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')- else respond mResponse-- where pa = Proxy :: Proxy a- pb = Proxy :: Proxy b--captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a-captured _ = fromText---- | 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 'FromText' for your type.------ Example:------ > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book--- >--- > server :: Server MyApi--- > server = getBook--- > where getBook :: Text -> EitherT ServantErr IO Book--- > getBook isbn = ...-instance (KnownSymbol capture, FromText a, HasServer sublayout)- => HasServer (Capture capture a :> sublayout) where-- type ServerT (Capture capture a :> sublayout) m =- a -> ServerT sublayout m-- route Proxy subserver request respond = case processedPathInfo request of- (first : rest)- -> case captured captureProxy first of- Nothing -> respond $ failWith NotFound- Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{- pathInfo = rest- } respond- _ -> respond $ failWith NotFound-- where captureProxy = Proxy :: Proxy (Capture capture a)----- | If you have a 'Delete' endpoint in your API,--- the handler for this endpoint is meant to delete--- a resource.------ The code of the handler will, just like--- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and--- 'Servant.API.Put.Put', run in @EitherT ServantErr IO ()@.--- The 'Int' represents the status code and the 'String' a message--- to be returned. You can use 'Control.Monad.Trans.Either.left' to--- painlessly error out if the conditions for a successful deletion--- are not met.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- ( AllCTRender ctypes a- ) => HasServer (Delete ctypes a) where-- type ServerT (Delete ctypes a) m = m a-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodDelete = do- e <- runEitherT action- respond $ case e of- Right output -> do- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request- case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of- Nothing -> failWith UnsupportedMediaType- Just (contentT, body) -> succeedWith $- responseLBS status200 [ ("Content-Type" , cs contentT)] body- Left err -> succeedWith $ responseServantErr err- | pathIsEmpty request && requestMethod request /= methodDelete =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound--instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- HasServer (Delete ctypes ()) where-- type ServerT (Delete ctypes ()) m = m ()-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodDelete = do- e <- runEitherT action- respond . succeedWith $ case e of- Right () -> responseLBS noContent204 [] ""- Left err -> responseServantErr err- | pathIsEmpty request && requestMethod request /= methodDelete =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound---- Add response headers-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- ( GetHeaders (Headers h v), AllCTRender ctypes v- ) => HasServer (Delete ctypes (Headers h v)) where-- type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodDelete = do- e <- runEitherT action- respond $ case e of- Right output -> do- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request- headers = getHeaders output- case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of- Nothing -> failWith UnsupportedMediaType- Just (contentT, body) -> succeedWith $- responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body- Left err -> succeedWith $ responseServantErr err- | pathIsEmpty request && requestMethod request /= methodDelete =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound---- | When implementing the handler for a 'Get' endpoint,--- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'--- and 'Servant.API.Put.Put', the handler code runs in the--- @EitherT ServantErr IO@ monad, where the 'Int' represents--- the status code and the 'String' a message, returned in case of--- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'--- to quickly fail if some conditions are not met.------ If successfully returning a value, we use the type-level list, combined--- with the request's @Accept@ header, to encode the value for you--- (returning a status code of 200). If there was no @Accept@ header or it--- was @*\/\*@, we return encode using the first @Content-Type@ type on the--- list.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where-- type ServerT (Get ctypes a) m = m a-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodGet = do- e <- runEitherT action- respond $ case e of- Right output -> do- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request- case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of- Nothing -> failWith UnsupportedMediaType- Just (contentT, body) -> succeedWith $- responseLBS ok200 [ ("Content-Type" , cs contentT)] body- Left err -> succeedWith $ responseServantErr err- | pathIsEmpty request && requestMethod request /= methodGet =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound---- '()' ==> 204 No Content-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- HasServer (Get ctypes ()) where-- type ServerT (Get ctypes ()) m = m ()-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodGet = do- e <- runEitherT action- respond . succeedWith $ case e of- Right () -> responseLBS noContent204 [] ""- Left err -> responseServantErr err- | pathIsEmpty request && requestMethod request /= methodGet =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound---- Add response headers-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- ( GetHeaders (Headers h v), AllCTRender ctypes v- ) => HasServer (Get ctypes (Headers h v)) where-- type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodGet = do- e <- runEitherT action- respond $ case e of- Right output -> do- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request- headers = getHeaders output- case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of- Nothing -> failWith UnsupportedMediaType- Just (contentT, body) -> succeedWith $- responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body- Left err -> succeedWith $ responseServantErr err- | pathIsEmpty request && requestMethod request /= methodGet =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound---- | 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 'FromText' instance.------ Example:------ > newtype Referer = Referer Text--- > deriving (Eq, Show, FromText, ToText)--- >--- > -- GET /view-my-referer--- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer--- >--- > server :: Server MyApi--- > server = viewReferer--- > where viewReferer :: Referer -> EitherT ServantErr IO referer--- > viewReferer referer = return referer-instance (KnownSymbol sym, FromText a, HasServer sublayout)- => HasServer (Header sym a :> sublayout) where-- type ServerT (Header sym a :> sublayout) m =- Maybe a -> ServerT sublayout m-- route Proxy subserver request respond = do- let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)- route (Proxy :: Proxy sublayout) (subserver mheader) request respond-- where str = fromString $ symbolVal (Proxy :: Proxy sym)---- | When implementing the handler for a 'Post' endpoint,--- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'--- and 'Servant.API.Put.Put', the handler code runs in the--- @EitherT ServantErr IO@ monad, where the 'Int' represents--- the status code and the 'String' a message, returned in case of--- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'--- to quickly fail if some conditions are not met.------ If successfully returning a value, we use the type-level list, combined--- with the request's @Accept@ header, to encode the value for you--- (returning a status code of 201). If there was no @Accept@ header or it--- was @*\/\*@, we return encode using the first @Content-Type@ type on the--- list.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- ( AllCTRender ctypes a- ) => HasServer (Post ctypes a) where-- type ServerT (Post ctypes a) m = m a-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodPost = do- e <- runEitherT action- respond $ case e of- Right output -> do- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request- case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of- Nothing -> failWith UnsupportedMediaType- Just (contentT, body) -> succeedWith $- responseLBS status201 [ ("Content-Type" , cs contentT)] body- Left err -> succeedWith $ responseServantErr err- | pathIsEmpty request && requestMethod request /= methodPost =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound--instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- HasServer (Post ctypes ()) where-- type ServerT (Post ctypes ()) m = m ()-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodPost = do- e <- runEitherT action- respond . succeedWith $ case e of- Right () -> responseLBS noContent204 [] ""- Left err -> responseServantErr err- | pathIsEmpty request && requestMethod request /= methodPost =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound---- Add response headers-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- ( GetHeaders (Headers h v), AllCTRender ctypes v- ) => HasServer (Post ctypes (Headers h v)) where-- type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodPost = do- e <- runEitherT action- respond $ case e of- Right output -> do- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request- headers = getHeaders output- case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of- Nothing -> failWith UnsupportedMediaType- Just (contentT, body) -> succeedWith $- responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body- Left err -> succeedWith $ responseServantErr err- | pathIsEmpty request && requestMethod request /= methodPost =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound---- | When implementing the handler for a 'Put' endpoint,--- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'--- and 'Servant.API.Post.Post', the handler code runs in the--- @EitherT ServantErr IO@ monad, where the 'Int' represents--- the status code and the 'String' a message, returned in case of--- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'--- to quickly fail if some conditions are not met.------ If successfully returning a value, we use the type-level list, combined--- with the request's @Accept@ header, to encode the value for you--- (returning a status code of 200). If there was no @Accept@ header or it--- was @*\/\*@, we return encode using the first @Content-Type@ type on the--- list.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- ( AllCTRender ctypes a) => HasServer (Put ctypes a) where-- type ServerT (Put ctypes a) m = m a-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodPut = do- e <- runEitherT action- respond $ case e of- Right output -> do- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request- case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of- Nothing -> failWith UnsupportedMediaType- Just (contentT, body) -> succeedWith $- responseLBS status200 [ ("Content-Type" , cs contentT)] body- Left err -> succeedWith $ responseServantErr err- | pathIsEmpty request && requestMethod request /= methodPut =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound--instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- HasServer (Put ctypes ()) where-- type ServerT (Put ctypes ()) m = m ()-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodPut = do- e <- runEitherT action- respond . succeedWith $ case e of- Right () -> responseLBS noContent204 [] ""- Left err -> responseServantErr err- | pathIsEmpty request && requestMethod request /= methodPut =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound---- Add response headers-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- ( GetHeaders (Headers h v), AllCTRender ctypes v- ) => HasServer (Put ctypes (Headers h v)) where-- type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodPut = do- e <- runEitherT action- respond $ case e of- Right output -> do- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request- headers = getHeaders output- case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of- Nothing -> failWith UnsupportedMediaType- Just (contentT, body) -> succeedWith $- responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body- Left err -> succeedWith $ responseServantErr err- | pathIsEmpty request && requestMethod request /= methodPut =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound---- | When implementing the handler for a 'Patch' endpoint,--- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'--- and 'Servant.API.Put.Put', the handler code runs in the--- @EitherT ServantErr IO@ monad, where the 'Int' represents--- the status code and the 'String' a message, returned in case of--- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'--- to quickly fail if some conditions are not met.------ If successfully returning a value, we just require that its type has--- a 'ToJSON' instance and servant takes care of encoding it for you,--- yielding status code 200 along the way.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where-- type ServerT (Patch ctypes a) m = m a-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodPatch = do- e <- runEitherT action- respond $ case e of- Right output -> do- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request- case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of- Nothing -> failWith UnsupportedMediaType- Just (contentT, body) -> succeedWith $- responseLBS status200 [ ("Content-Type" , cs contentT)] body- Left err -> succeedWith $ responseServantErr err- | pathIsEmpty request && requestMethod request /= methodPatch =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound--instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- HasServer (Patch ctypes ()) where-- type ServerT (Patch ctypes ()) m = m ()-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodPatch = do- e <- runEitherT action- respond . succeedWith $ case e of- Right () -> responseLBS noContent204 [] ""- Left err -> responseServantErr err- | pathIsEmpty request && requestMethod request /= methodPatch =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound---- Add response headers-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- ( GetHeaders (Headers h v), AllCTRender ctypes v- ) => HasServer (Patch ctypes (Headers h v)) where-- type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)-- route Proxy action request respond- | pathIsEmpty request && requestMethod request == methodPatch = do- e <- runEitherT action- respond $ case e of- Right outpatch -> do- let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request- headers = getHeaders outpatch- case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of- Nothing -> failWith UnsupportedMediaType- Just (contentT, body) -> succeedWith $- responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body- Left err -> succeedWith $ responseServantErr err- | pathIsEmpty request && requestMethod request /= methodPatch =- respond $ failWith WrongMethod- | otherwise = respond $ failWith NotFound---- | 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 'FromText' for your type.------ Example:------ > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]--- >--- > server :: Server MyApi--- > server = getBooksBy--- > where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book]--- > getBooksBy Nothing = ...return all books...--- > getBooksBy (Just author) = ...return books by the given author...-instance (KnownSymbol sym, FromText a, HasServer sublayout)- => HasServer (QueryParam sym a :> sublayout) where-- type ServerT (QueryParam sym a :> sublayout) m =- Maybe a -> ServerT sublayout m-- route Proxy subserver request respond = do- let querytext = parseQueryText $ rawQueryString request- param =- case lookup paramname querytext of- Nothing -> Nothing -- param absent from the query string- Just Nothing -> Nothing -- param present with no value -> Nothing- Just (Just v) -> fromText v -- if present, we try to convert to- -- the right type-- route (Proxy :: Proxy sublayout) (subserver param) request respond-- 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 'FromText' for your type.------ Example:------ > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]--- >--- > server :: Server MyApi--- > server = getBooksBy--- > where getBooksBy :: [Text] -> EitherT ServantErr IO [Book]--- > getBooksBy authors = ...return all books by these authors...-instance (KnownSymbol sym, FromText a, HasServer sublayout)- => HasServer (QueryParams sym a :> sublayout) where-- type ServerT (QueryParams sym a :> sublayout) m =- [a] -> ServerT sublayout m-- route Proxy subserver request respond = do- let querytext = parseQueryText $ rawQueryString request- -- if sym is "foo", we look for query string parameters- -- named "foo" or "foo[]" and call fromText on the- -- corresponding values- parameters = filter looksLikeParam querytext- values = catMaybes $ map (convert . snd) parameters-- route (Proxy :: Proxy sublayout) (subserver values) request respond-- where paramname = cs $ symbolVal (Proxy :: Proxy sym)- looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")- convert Nothing = Nothing- convert (Just v) = fromText v---- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,--- this automatically requires your server-side handler to be a function--- that takes an argument of type 'Bool'.------ Example:------ > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]--- >--- > server :: Server MyApi--- > server = getBooks--- > where getBooks :: Bool -> EitherT ServantErr IO [Book]--- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...-instance (KnownSymbol sym, HasServer sublayout)- => HasServer (QueryFlag sym :> sublayout) where-- type ServerT (QueryFlag sym :> sublayout) m =- Bool -> ServerT sublayout m-- route Proxy subserver request respond = do- let querytext = parseQueryText $ rawQueryString request- param = case lookup paramname querytext 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-- route (Proxy :: Proxy sublayout) (subserver param) request respond-- where paramname = cs $ symbolVal (Proxy :: Proxy sym)- examine v | v == "true" || v == "1" || v == "" = True- | otherwise = False--parseMatrixText :: B.ByteString -> QueryText-parseMatrixText = parseQueryText---- | If you use @'MatrixParam' "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 'FromText' for your type.------ Example:------ > type MyApi = "books" :> MatrixParam "author" Text :> Get [Book]--- >--- > server :: Server MyApi--- > server = getBooksBy--- > where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book]--- > getBooksBy Nothing = ...return all books...--- > getBooksBy (Just author) = ...return books by the given author...-instance (KnownSymbol sym, FromText a, HasServer sublayout)- => HasServer (MatrixParam sym a :> sublayout) where-- type ServerT (MatrixParam sym a :> sublayout) m =- Maybe a -> ServerT sublayout m-- route Proxy subserver request respond = case parsePathInfo request of- (first : _)- -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first- param = case lookup paramname querytext of- Nothing -> Nothing -- param absent from the query string- Just Nothing -> Nothing -- param present with no value -> Nothing- Just (Just v) -> fromText v -- if present, we try to convert to- -- the right type- route (Proxy :: Proxy sublayout) (subserver param) request respond- _ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond-- where paramname = cs $ symbolVal (Proxy :: Proxy sym)---- | If you use @'MatrixParams' "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 'FromText' for your type.------ Example:------ > type MyApi = "books" :> MatrixParams "authors" Text :> Get [Book]--- >--- > server :: Server MyApi--- > server = getBooksBy--- > where getBooksBy :: [Text] -> EitherT ServantErr IO [Book]--- > getBooksBy authors = ...return all books by these authors...-instance (KnownSymbol sym, FromText a, HasServer sublayout)- => HasServer (MatrixParams sym a :> sublayout) where-- type ServerT (MatrixParams sym a :> sublayout) m =- [a] -> ServerT sublayout m-- route Proxy subserver request respond = case parsePathInfo request of- (first : _)- -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first- -- if sym is "foo", we look for matrix parameters- -- named "foo" or "foo[]" and call fromText on the- -- corresponding values- parameters = filter looksLikeParam matrixtext- values = catMaybes $ map (convert . snd) parameters- route (Proxy :: Proxy sublayout) (subserver values) request respond- _ -> route (Proxy :: Proxy sublayout) (subserver []) request respond-- where paramname = cs $ symbolVal (Proxy :: Proxy sym)- looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")- convert Nothing = Nothing- convert (Just v) = fromText v---- | If you use @'MatrixFlag' "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" :> MatrixFlag "published" :> Get [Book]--- >--- > server :: Server MyApi--- > server = getBooks--- > where getBooks :: Bool -> EitherT ServantErr IO [Book]--- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...-instance (KnownSymbol sym, HasServer sublayout)- => HasServer (MatrixFlag sym :> sublayout) where-- type ServerT (MatrixFlag sym :> sublayout) m =- Bool -> ServerT sublayout m-- route Proxy subserver request respond = case parsePathInfo request of- (first : _)- -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first- param = case lookup paramname matrixtext 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-- route (Proxy :: Proxy sublayout) (subserver param) request respond-- _ -> route (Proxy :: Proxy sublayout) (subserver False) request respond-- 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 where-- type ServerT Raw m = Application-- route Proxy rawApplication request respond =- rawApplication request (respond . succeedWith)---- | 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@.--- 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 -> EitherT ServantErr IO Book--- > postBook book = ...insert into your db...-instance ( AllCTUnrender list a, HasServer sublayout- ) => HasServer (ReqBody list a :> sublayout) where-- type ServerT (ReqBody list a :> sublayout) m =- a -> ServerT sublayout m-- route Proxy subserver request respond = do- -- See HTTP RFC 2616, section 7.2.1- -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1- -- See also "W3C Internet Media Type registration, consistency of use"- -- http://www.w3.org/2001/tag/2002/0129-mime- let contentTypeH = fromMaybe "application/octet-stream"- $ lookup hContentType $ requestHeaders request- mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)- <$> lazyRequestBody request- case mrqbody of- Nothing -> respond . failWith $ UnsupportedMediaType- Just (Left e) -> respond . failWith $ InvalidBody e- Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond---- | Make sure the incoming request starts with @"/path"@, strip it and--- pass the rest of the request path to @sublayout@.-instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where-- type ServerT (path :> sublayout) m = ServerT sublayout m-- route Proxy subserver request respond = case processedPathInfo request of- (first : rest)- | first == cs (symbolVal proxyPath)- -> route (Proxy :: Proxy sublayout) subserver request{- pathInfo = rest- } respond- _ -> respond $ failWith NotFound-- where proxyPath = Proxy :: Proxy path--ct_wildcard :: B.ByteString-ct_wildcard = "*" <> "/" <> "*" -- Because CPP+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++#include "overlapping-compat.h"++module Servant.Server.Internal+ ( module Servant.Server.Internal+ , module Servant.Server.Internal.Context+ , module Servant.Server.Internal.BasicAuth+ , module Servant.Server.Internal.Router+ , module Servant.Server.Internal.RoutingApplication+ , module Servant.Server.Internal.ServantErr+ ) where++import Control.Monad.Trans.Except (ExceptT)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC8+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as M+import Data.Maybe (fromMaybe, mapMaybe)+import Data.String (fromString)+import Data.String.Conversions (cs, (<>))+import Data.Text (Text)+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, pathInfo,+ rawQueryString, remoteHost,+ requestHeaders, requestMethod,+ responseLBS, vault)+import Prelude ()+import Prelude.Compat+import Web.HttpApiData (FromHttpApiData)+import Web.HttpApiData.Internal (parseHeaderMaybe,+ parseQueryParamMaybe,+ parseUrlPieceMaybe)++import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,+ Verb, ReflectMethod(reflectMethod),+ IsSecure(..), Header,+ QueryFlag, QueryParam, QueryParams,+ Raw, RemoteHost, ReqBody, Vault,+ WithNamedContext)+import Servant.API.ContentTypes (AcceptHeader (..),+ AllCTRender (..),+ AllCTUnrender (..),+ AllMime,+ canHandleAcceptH)+import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,+ getResponse)++import Servant.Server.Internal.Context+import Servant.Server.Internal.BasicAuth+import Servant.Server.Internal.Router+import Servant.Server.Internal.RoutingApplication+import Servant.Server.Internal.ServantErr+++class HasServer layout context where+ type ServerT layout (m :: * -> *) :: *++ route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router++type Server layout = ServerT layout (ExceptT ServantErr IO)++-- * 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++captured :: FromHttpApiData a => proxy (Capture sym a) -> Text -> Maybe a+captured _ = parseUrlPieceMaybe++-- | 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 -> ExceptT ServantErr IO Book+-- > getBook isbn = ...+instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)+ => HasServer (Capture capture a :> sublayout) context where++ type ServerT (Capture capture a :> sublayout) m =+ a -> ServerT sublayout m++ route Proxy context d =+ DynamicRouter $ \ first ->+ route (Proxy :: Proxy sublayout)+ context+ (addCapture d $ case captured captureProxy first of+ Nothing -> return $ Fail err404+ Just v -> return $ Route v+ )+ where+ captureProxy = Proxy :: Proxy (Capture capture a)++allowedMethodHead :: Method -> Request -> Bool+allowedMethodHead method request = method == methodGet && requestMethod request == methodHead++allowedMethod :: Method -> Request -> Bool+allowedMethod method request = allowedMethodHead method request || requestMethod request == method++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 -> IO (RouteResult ())+methodCheck method request+ | allowedMethod method request = return $ Route ()+ | otherwise = return $ Fail err405++acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())+acceptCheck proxy accH+ | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()+ | otherwise = return $ FailFatal err406++methodRouter :: (AllCTRender ctypes a)+ => Method -> Proxy ctypes -> Status+ -> Delayed (ExceptT ServantErr IO a)+ -> Router+methodRouter method proxy status action = LeafRouter route'+ where+ route' request respond+ | pathIsEmpty request =+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ in runAction (action `addMethodCheck` methodCheck method request+ `addAcceptCheck` acceptCheck proxy accH+ ) respond $ \ output -> do+ let handleA = handleAcceptH proxy (AcceptHeader accH) output+ processMethodRouter handleA status method Nothing request+ | otherwise = respond $ Fail err404++methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)+ => Method -> Proxy ctypes -> Status+ -> Delayed (ExceptT ServantErr IO (Headers h v))+ -> Router+methodRouterHeaders method proxy status action = LeafRouter route'+ where+ route' request respond+ | pathIsEmpty request =+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+ in runAction (action `addMethodCheck` methodCheck method request+ `addAcceptCheck` acceptCheck proxy accH+ ) respond $ \ output -> do+ let headers = getHeaders output+ handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)+ processMethodRouter handleA status method (Just headers) request+ | otherwise = respond $ Fail err404++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, ToText)+-- >+-- > -- GET /view-my-referer+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer+-- >+-- > server :: Server MyApi+-- > server = viewReferer+-- > where viewReferer :: Referer -> ExceptT ServantErr IO referer+-- > viewReferer referer = return referer+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)+ => HasServer (Header sym a :> sublayout) context where++ type ServerT (Header sym a :> sublayout) m =+ Maybe a -> ServerT sublayout m++ route Proxy context subserver = WithRequest $ \ request ->+ let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)+ in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader)+ where str = fromString $ symbolVal (Proxy :: Proxy sym)++-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of type @'Maybe' 'Text'@.+--+-- This lets servant worry about looking it up in the query string+-- and turning it into a value of the type you specify, enclosed+-- in 'Maybe', because it may not be there and servant would then+-- hand you 'Nothing'.+--+-- You can control how it'll be converted from 'Text' to your type+-- by simply providing an instance of 'FromHttpApiData' for your type.+--+-- Example:+--+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooksBy+-- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book]+-- > getBooksBy Nothing = ...return all books...+-- > getBooksBy (Just author) = ...return books by the given author...+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)+ => HasServer (QueryParam sym a :> sublayout) context where++ type ServerT (QueryParam sym a :> sublayout) m =+ Maybe a -> ServerT sublayout m++ route Proxy context subserver = WithRequest $ \ request ->+ let querytext = parseQueryText $ rawQueryString request+ param =+ case lookup paramname querytext of+ Nothing -> Nothing -- param absent from the query string+ Just Nothing -> Nothing -- param present with no value -> Nothing+ Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to+ -- the right type+ in route (Proxy :: Proxy sublayout) context (passToServer subserver param)+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)++-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of type @['Text']@.+--+-- This lets servant worry about looking up 0 or more values in the query string+-- associated to @authors@ and turning each of them into a value of+-- the type you specify.+--+-- You can control how the individual values are converted from 'Text' to your type+-- by simply providing an instance of 'FromHttpApiData' for your type.+--+-- Example:+--+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooksBy+-- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book]+-- > getBooksBy authors = ...return all books by these authors...+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)+ => HasServer (QueryParams sym a :> sublayout) context where++ type ServerT (QueryParams sym a :> sublayout) m =+ [a] -> ServerT sublayout m++ route Proxy context subserver = WithRequest $ \ request ->+ let querytext = parseQueryText $ rawQueryString request+ -- if sym is "foo", we look for query string parameters+ -- named "foo" or "foo[]" and call parseQueryParam on the+ -- corresponding values+ parameters = filter looksLikeParam querytext+ values = mapMaybe (convert . snd) parameters+ in route (Proxy :: Proxy sublayout) context (passToServer subserver values)+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)+ looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")+ convert Nothing = Nothing+ convert (Just v) = parseQueryParamMaybe v++-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of type 'Bool'.+--+-- Example:+--+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooks+-- > where getBooks :: Bool -> ExceptT ServantErr IO [Book]+-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...+instance (KnownSymbol sym, HasServer sublayout context)+ => HasServer (QueryFlag sym :> sublayout) context where++ type ServerT (QueryFlag sym :> sublayout) m =+ Bool -> ServerT sublayout m++ route Proxy context subserver = WithRequest $ \ request ->+ let querytext = parseQueryText $ rawQueryString request+ param = case lookup paramname querytext 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 sublayout) context (passToServer subserver param)+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)+ examine v | v == "true" || v == "1" || v == "" = True+ | otherwise = False++-- | Just pass the request to the underlying application and serve its response.+--+-- Example:+--+-- > type MyApi = "images" :> Raw+-- >+-- > server :: Server MyApi+-- > server = serveDirectory "/var/www/images"+instance HasServer Raw context where++ type ServerT Raw m = Application++ route Proxy _ rawApplication = LeafRouter $ \ request respond -> do+ r <- runDelayed rawApplication+ case r of+ Route app -> app request (respond . Route)+ Fail a -> respond $ Fail a+ FailFatal e -> respond $ FailFatal e++-- | If you use 'ReqBody' in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of the type specified by 'ReqBody'.+-- The @Content-Type@ header is inspected, and the list provided is used to+-- attempt deserialization. If the request does not have a @Content-Type@+-- header, it is treated as @application/octet-stream@ (as specified in+-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.+-- This lets servant worry about extracting it from the request and turning+-- it into a value of the type you specify.+--+--+-- All it asks is for a 'FromJSON' instance.+--+-- Example:+--+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book+-- >+-- > server :: Server MyApi+-- > server = postBook+-- > where postBook :: Book -> ExceptT ServantErr IO Book+-- > postBook book = ...insert into your db...+instance ( AllCTUnrender list a, HasServer sublayout context+ ) => HasServer (ReqBody list a :> sublayout) context where++ type ServerT (ReqBody list a :> sublayout) m =+ a -> ServerT sublayout m++ route Proxy context subserver = WithRequest $ \ request ->+ route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request))+ where+ bodyCheck request = do+ -- See HTTP RFC 2616, section 7.2.1+ -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1+ -- See also "W3C Internet Media Type registration, consistency of use"+ -- http://www.w3.org/2001/tag/2002/0129-mime+ let contentTypeH = fromMaybe "application/octet-stream"+ $ lookup hContentType $ requestHeaders request+ mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)+ <$> lazyRequestBody request+ case mrqbody of+ Nothing -> return $ FailFatal err415+ Just (Left e) -> return $ FailFatal err400 { errBody = cs e }+ Just (Right v) -> return $ Route v++-- | Make sure the incoming request starts with @"/path"@, strip it and+-- pass the rest of the request path to @sublayout@.+instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> sublayout) context where++ type ServerT (path :> sublayout) m = ServerT sublayout m++ route Proxy context subserver = StaticRouter $+ M.singleton (cs (symbolVal proxyPath))+ (route (Proxy :: Proxy sublayout) 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 = WithRequest $ \req ->+ route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req)++instance HasServer api context => HasServer (IsSecure :> api) context where+ type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m++ route Proxy context subserver = WithRequest $ \req ->+ route (Proxy :: Proxy api) context (passToServer subserver $ secure req)++ 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 = WithRequest $ \req ->+ route (Proxy :: Proxy api) context (passToServer subserver $ vault req)++instance HasServer api context => HasServer (HttpVersion :> api) context where+ type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m++ route Proxy context subserver = WithRequest $ \req ->+ route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)++-- | 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 = WithRequest $ \ request ->+ route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)+ where+ realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)+ basicAuthContext = getContextEntry context+ authCheck req = runBasicAuth req realm basicAuthContext++-- * helpers++pathIsEmpty :: Request -> Bool+pathIsEmpty = go . pathInfo+ where go [] = True+ go [""] = True+ go _ = False++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
+ src/Servant/Server/Internal/BasicAuth.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Servant.Server.Internal.BasicAuth where++import Control.Monad (guard)+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 -> IO (RouteResult usr)+runBasicAuth req realm (BasicAuthCheck ba) =+ case decodeBAHdr req of+ Nothing -> plzAuthenticate+ Just e -> ba e >>= \res -> case res of+ BadPassword -> plzAuthenticate+ NoSuchUser -> plzAuthenticate+ Unauthorized -> return $ Fail err403+ Authorized usr -> return $ Route usr+ where plzAuthenticate = return $ Fail err401 { errHeaders = [mkBAChallengerHdr realm] }
+ src/Servant/Server/Internal/Context.hs view
@@ -0,0 +1,104 @@+{-# 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.Server.Internal.Enter.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
src/Servant/Server/Internal/Enter.hs view
@@ -10,9 +10,6 @@ {-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.Enter where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif import qualified Control.Category as C #if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except@@ -22,12 +19,12 @@ import Control.Monad.Reader import qualified Control.Monad.State.Lazy as LState import qualified Control.Monad.State.Strict as SState-#if MIN_VERSION_mtl(2,2,1)-import Control.Monad.Trans.Either-#endif import qualified Control.Monad.Writer.Lazy as LWriter import qualified Control.Monad.Writer.Strict as SWriter import Data.Typeable+import Prelude ()+import Prelude.Compat+ import Servant.API class Enter typ arg ret | typ arg -> ret, typ ret -> arg where@@ -82,11 +79,6 @@ (a, w) <- LWriter.runWriterT x liftIO $ logger w return a--#if MIN_VERSION_mtl(2,2,1)-fromExceptT :: ExceptT e m :~> EitherT e m-fromExceptT = Nat $ \x -> EitherT $ runExceptT x-#endif -- | Like @mmorph@'s `hoist`. hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n)
+ src/Servant/Server/Internal/Router.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE CPP #-}+module Servant.Server.Internal.Router where++import Data.Map (Map)+import qualified Data.Map as M+import Data.Text (Text)+import Network.Wai (Request, Response, pathInfo)+import Servant.Server.Internal.RoutingApplication+import Servant.Server.Internal.ServantErr++type Router = Router' RoutingApplication++-- | Internal representation of a router.+data Router' a =+ WithRequest (Request -> Router)+ -- ^ current request is passed to the router+ | StaticRouter (Map Text Router)+ -- ^ first path component used for lookup and removed afterwards+ | DynamicRouter (Text -> Router)+ -- ^ first path component used for lookup and removed afterwards+ | LeafRouter a+ -- ^ to be used for routes that match an empty path+ | Choice Router Router+ -- ^ left-biased choice between two routers+ deriving Functor++-- | Apply a transformation to the response of a `Router`.+tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router+tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))++-- | Smart constructor for the choice between routers.+-- We currently optimize the following cases:+--+-- * Two static routers can be joined by joining their maps.+-- * Two dynamic routers can be joined by joining their codomains.+-- * Two 'WithRequest' routers can be joined by passing them+-- the same request and joining their codomains.+-- * A 'WithRequest' router can be joined with anything else by+-- passing the same request to both but ignoring it in the+-- component that does not need it.+--+choice :: Router -> Router -> Router+choice (StaticRouter table1) (StaticRouter table2) =+ StaticRouter (M.unionWith choice table1 table2)+choice (DynamicRouter fun1) (DynamicRouter fun2) =+ DynamicRouter (\ first -> choice (fun1 first) (fun2 first))+choice (WithRequest router1) (WithRequest router2) =+ WithRequest (\ request -> choice (router1 request) (router2 request))+choice (WithRequest router1) router2 =+ WithRequest (\ request -> choice (router1 request) router2)+choice router1 (WithRequest router2) =+ WithRequest (\ request -> choice router1 (router2 request))+choice router1 router2 = Choice router1 router2++-- | Interpret a router as an application.+runRouter :: Router -> RoutingApplication+runRouter (WithRequest router) request respond =+ runRouter (router request) request respond+runRouter (StaticRouter table) request respond =+ case pathInfo request of+ first : rest+ | Just router <- M.lookup first table+ -> let request' = request { pathInfo = rest }+ in runRouter router request' respond+ _ -> respond $ Fail err404+runRouter (DynamicRouter fun) request respond =+ case pathInfo request of+ first : rest+ -> let request' = request { pathInfo = rest }+ in runRouter (fun first) request' respond+ _ -> respond $ Fail err404+runRouter (LeafRouter app) request respond = app request respond+runRouter (Choice r1 r2) request respond =+ runRouter r1 request $ \ mResponse1 -> case mResponse1 of+ Fail _ -> runRouter r2 request $ \ mResponse2 ->+ respond (highestPri mResponse1 mResponse2)+ _ -> respond mResponse1+ 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 = (<)
+ src/Servant/Server/Internal/RoutingApplication.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+module Servant.Server.Internal.RoutingApplication where++import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Network.Wai (Application, Request,+ Response, ResponseReceived)+import Prelude ()+import Prelude.Compat+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)++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++-- We currently mix up the order in which we perform checks+-- and the priority with which errors are reported.+--+-- For example, we perform Capture checks prior to method checks,+-- and therefore get 404 before 405.+--+-- However, we also perform body checks prior to method checks+-- now, and therefore get 415 before 405, which is wrong.+--+-- If we delay Captures, but perform method checks eagerly, we+-- end up potentially preferring 405 over 404, which is also bad.+--+-- So in principle, we'd like:+--+-- static routes (can cause 404)+-- delayed captures (can cause 404)+-- methods (can cause 405)+-- authentication and authorization (can cause 401, 403)+-- delayed body (can cause 415, 400)+-- accept header (can cause 406)+--+-- According to the HTTP decision diagram, the priority order+-- between HTTP status codes is as follows:+--++-- | A 'Delayed' is a representation of a handler with scheduled+-- delayed checks that can trigger errors.+--+-- Why would we want to delay checks?+--+-- There are two reasons:+--+-- 1. In a straight-forward implementation, the order in which we+-- perform checks will determine the error we generate. This is+-- because once an error occurs, we would abort and not perform+-- any subsequent checks, but rather return the current error.+--+-- This is not a necessity: we could continue doing other checks,+-- and choose the preferred error. However, that would in general+-- mean more checking, which leads us to the other reason.+--+-- 2. We really want to avoid doing certain checks too early. For+-- example, captures involve parsing, and are much more costly+-- than static route matches. In particular, if several paths+-- contain the "same" capture, we'd like as much as possible to+-- avoid trying the same parse many times. Also tricky is the+-- request body. Again, this involves parsing, but also, WAI makes+-- obtaining the request body a side-effecting operation. We+-- could/can work around this by manually caching the request body,+-- but we'd rather keep the number of times we actually try to+-- decode the request body to an absolute minimum.+--+-- We prefer to have the following relative priorities of error+-- codes:+--+-- @+-- 404+-- 405 (bad method)+-- 401 (unauthorized)+-- 415 (unsupported media type)+-- 400 (bad request)+-- 406 (not acceptable)+-- @+--+-- Therefore, while routing, we delay most checks so that they+-- will ultimately occur in the right order.+--+-- A 'Delayed' contains three delayed blocks of tests, and+-- the actual handler:+--+-- 1. Delayed captures. These can actually cause 404, and+-- while they're costly, they should be done first among the+-- delayed checks (at least as long as we do not decouple the+-- check order from the error reporting, see above). Delayed+-- captures can provide inputs to the actual handler.+--+-- 2. Method check(s). This can cause a 405. On success,+-- it does not provide an input for the handler. Method checks+-- are comparatively cheap.+--+-- 3. Body and accept header checks. The request body check can+-- cause both 400 and 415. This provides an input to the handler.+-- The accept header check can be performed as the final+-- computation in this block. It can cause a 406.+--+data Delayed c where+ Delayed :: { capturesD :: IO (RouteResult captures)+ , methodD :: IO (RouteResult ())+ , authD :: IO (RouteResult auth)+ , bodyD :: IO (RouteResult body)+ , serverD :: (captures -> auth -> body -> RouteResult c)+ } -> Delayed c++instance Functor Delayed where+ fmap f Delayed{..}+ = Delayed { capturesD = capturesD+ , methodD = methodD+ , authD = authD+ , bodyD = bodyD+ , serverD = (fmap.fmap.fmap.fmap) f serverD+ } -- Note [Existential Record Update]++-- | Add a capture to the end of the capture block.+addCapture :: Delayed (a -> b)+ -> IO (RouteResult a)+ -> Delayed b+addCapture Delayed{..} new+ = Delayed { capturesD = combineRouteResults (,) capturesD new+ , methodD = methodD+ , authD = authD+ , bodyD = bodyD+ , serverD = \ (x, v) y z -> ($ v) <$> serverD x y z+ } -- Note [Existential Record Update]++-- | Add a method check to the end of the method block.+addMethodCheck :: Delayed a+ -> IO (RouteResult ())+ -> Delayed a+addMethodCheck Delayed{..} new+ = Delayed { capturesD = capturesD+ , methodD = combineRouteResults const methodD new+ , authD = authD+ , bodyD = bodyD+ , serverD = serverD+ } -- Note [Existential Record Update]++-- | Add an auth check to the end of the auth block.+addAuthCheck :: Delayed (a -> b)+ -> IO (RouteResult a)+ -> Delayed b+addAuthCheck Delayed{..} new+ = Delayed { capturesD = capturesD+ , methodD = methodD+ , authD = combineRouteResults (,) authD new+ , bodyD = bodyD+ , serverD = \ x (y, v) z -> ($ v) <$> serverD x y z+ } -- Note [Existential Record Update]++-- | Add a body check to the end of the body block.+addBodyCheck :: Delayed (a -> b)+ -> IO (RouteResult a)+ -> Delayed b+addBodyCheck Delayed{..} new+ = Delayed { capturesD = capturesD+ , methodD = methodD+ , authD = authD+ , bodyD = combineRouteResults (,) bodyD new+ , serverD = \ x y (z, v) -> ($ v) <$> serverD x y z+ } -- Note [Existential Record Update]+++-- | Add an accept header check to the end of the body block.+-- The accept header check should occur after the body check,+-- but this will be the case, because the accept header check+-- is only scheduled by the method combinators.+addAcceptCheck :: Delayed a+ -> IO (RouteResult ())+ -> Delayed a+addAcceptCheck Delayed{..} new+ = Delayed { capturesD = capturesD+ , methodD = methodD+ , authD = authD+ , bodyD = combineRouteResults const bodyD new+ , serverD = serverD+ } -- 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 (a -> b) -> a -> Delayed b+passToServer d x = ($ x) <$> d++-- | The combination 'IO . RouteResult' is a monad, but we+-- don't explicitly wrap it in a newtype in order to make it+-- an instance. This is the '>>=' of that monad.+--+-- We stop on the first error.+bindRouteResults :: IO (RouteResult a) -> (a -> IO (RouteResult b)) -> IO (RouteResult b)+bindRouteResults m f = do+ r <- m+ case r of+ Fail e -> return $ Fail e+ FailFatal e -> return $ FailFatal e+ Route a -> f a++-- | Common special case of 'bindRouteResults', corresponding+-- to 'liftM2'.+combineRouteResults :: (a -> b -> c) -> IO (RouteResult a) -> IO (RouteResult b) -> IO (RouteResult c)+combineRouteResults f m1 m2 =+ m1 `bindRouteResults` \ a ->+ m2 `bindRouteResults` \ b ->+ return (Route (f a b))++-- | 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 a+ -> IO (RouteResult a)+runDelayed Delayed{..} =+ capturesD `bindRouteResults` \ c ->+ methodD `bindRouteResults` \ _ ->+ authD `bindRouteResults` \ a ->+ bodyD `bindRouteResults` \ b ->+ return (serverD c a b)++-- | 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 (ExceptT ServantErr IO a)+ -> (RouteResult Response -> IO r)+ -> (a -> RouteResult Response)+ -> IO r+runAction action respond k = runDelayed action >>= go >>= respond+ where+ go (Fail e) = return $ Fail e+ go (FailFatal e) = return $ FailFatal e+ go (Route a) = do+ e <- runExceptT a+ case e of+ Left err -> return . Route $ responseServantErr err+ Right x -> return $! k x++{- Note [Existential Record Update]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot+do the more succint thing - just update the records we actually change.+-}
src/Servant/Server/Internal/ServantErr.hs view
@@ -1,17 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-} module Servant.Server.Internal.ServantErr where -import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy as LBS-import qualified Network.HTTP.Types as HTTP-import Network.Wai (responseLBS, Response)+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)+ } deriving (Show, Eq, Read, Typeable)++instance Exception ServantErr responseServantErr :: ServantErr -> Response responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
src/Servant/Utils/StaticFiles.hs view
@@ -7,12 +7,13 @@ serveDirectory, ) where -import System.FilePath (addTrailingPathSeparator)-import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)-import Servant.API.Raw (Raw)-import Servant.Server (Server)+import Network.Wai.Application.Static (defaultFileServerSettings,+ staticApp)+import Servant.API.Raw (Raw)+import Servant.Server (Server)+import System.FilePath (addTrailingPathSeparator) #if !MIN_VERSION_wai_app_static(3,1,0)-import Filesystem.Path.CurrentOS (decodeString)+import Filesystem.Path.CurrentOS (decodeString) #endif -- | Serve anything under the specified directory as a 'Raw' endpoint.
test/Doctests.hs view
@@ -1,6 +1,6 @@ module Main where -import Data.List (isPrefixOf)+import Data.List (isPrefixOf) import System.Directory import System.FilePath import System.FilePath.Find@@ -9,23 +9,33 @@ main :: IO () main = do files <- find always (extension ==? ".hs") "src"- cabalMacrosFile <- getCabalMacrosFile- doctest $ [ "-isrc"- , "-optP-include"- , "-optP" ++ cabalMacrosFile- , "-XOverloadedStrings"- , "-XFlexibleInstances"- , "-XMultiParamTypeClasses"- , "-XDataKinds"- , "-XTypeOperators"- ] ++ files+ mCabalMacrosFile <- getCabalMacrosFile+ doctest $ "-isrc" : "-Iinclude" :+ (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) +++ "-XOverloadedStrings" :+ "-XFlexibleInstances" :+ "-XMultiParamTypeClasses" :+ "-XDataKinds" :+ "-XTypeOperators" :+ files -getCabalMacrosFile :: IO FilePath+getCabalMacrosFile :: IO (Maybe FilePath) getCabalMacrosFile = do- contents <- getDirectoryContents "dist"- let rest = "build" </> "autogen" </> "cabal_macros.h"- return $ case filter ("dist-sandbox-" `isPrefixOf`) contents of- [x] -> "dist" </> x </> rest- [] -> "dist" </> rest- xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"- ++ show xs ++ "\nTry cabal clean"+ exists <- doesDirectoryExist "dist"+ if exists+ then do+ contents <- getDirectoryContents "dist"+ let rest = "build" </> "autogen" </> "cabal_macros.h"+ whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of+ [x] -> "dist" </> x </> rest+ [] -> "dist" </> rest+ xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"+ ++ show xs ++ "\nTry cabal clean"+ else return Nothing+ where+ whenExists :: FilePath -> IO (Maybe FilePath)+ whenExists file = do+ exists <- doesFileExist file+ return $ if exists+ then Just file+ else Nothing
+ test/Servant/Server/ErrorSpec.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Servant.Server.ErrorSpec (spec) where++import Control.Monad.Trans.Except (throwE)+import Data.Aeson (encode)+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy.Char8 as BCL+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+ :> Post '[JSON] Int++errorOrderApi :: Proxy ErrorOrderApi+errorOrderApi = Proxy++errorOrderServer :: Server ErrorOrderApi+errorOrderServer = \_ _ _ -> throwE err402++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 = "home/nonexistent"+ badBody = "nonsense"+ badAuth = (hAuthorization, "Basic foofoofoo")+ goodContentType = (hContentType, "application/json")+ goodAccept = (hAccept, "application/json")+ goodMethod = methodPost+ goodUrl = "home/2"+ 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 goodUrl [badAuth, badContentType, badAccept] badBody+ `shouldRespondWith` 405++ it "has 401 as its third highest priority error (auth)" $ do+ request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody+ `shouldRespondWith` 401++ it "has 415 as its fourth highest priority error" $ do+ request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody+ `shouldRespondWith` 415++ it "has 400 as its fifth highest priority error" $ do+ request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody+ `shouldRespondWith` 400++ it "has 406 as its sixth highest priority error" $ do+ request goodMethod goodUrl [goodAuth, goodContentType, badAccept] goodBody+ `shouldRespondWith` 406++ 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+ = (\_ -> throwE 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 = Just $ encode (8 :: Int) }++ it "should continue when methods don't match" $ do+ request methodGet "a" [jsonCT, jsonAccept] jsonBody+ `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }++-- }}}+------------------------------------------------------------------------------+-- * 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+-- }}}
+ test/Servant/Server/Internal/ContextSpec.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -fdefer-type-errors #-}+module Servant.Server.Internal.ContextSpec (spec) where++import Data.Proxy (Proxy (..))+import Test.Hspec (Spec, describe, it, shouldBe, pending, 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+ let cxt = 'a' :. True :. EmptyContext+ it "has a Show instance" $ do+ show cxt `shouldBe` "'a' :. True :. EmptyContext"++ context "bracketing" $ do+ it "works" $ do+ show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)"++ it "works with operators" $ do+ let cxt = (1 :. '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)
+ test/Servant/Server/Internal/EnterSpec.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+module Servant.Server.Internal.EnterSpec where++import qualified Control.Category as C+import Control.Monad.Reader+import Control.Monad.Trans.Except+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 "module Servant.Server.Enter" $ 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 :~> ExceptT ServantErr IO+fReader = generalizeNat C.. (runReaderTNat "hi")++readerServer :: Server ReaderAPI+readerServer = enter fReader readerServer'++combinedReaderServer' :: ServerT CombinedAPI (Reader String)+combinedReaderServer' = readerServer' :<|> enter generalizeNat (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"
+ test/Servant/Server/UsingContextSpec.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Servant.Server.UsingContextSpec where++import Control.Monad.Trans.Except+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 -> ExceptT ServantErr IO 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\""
+ test/Servant/Server/UsingContextSpec/TestCombinators.hs view
@@ -0,0 +1,72 @@+{-# 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+import Servant.Server.Internal.RoutingApplication++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 context) delayed :: Delayed (Server subApi))+ where+ subProxy :: Proxy subApi+ subProxy = Proxy++ inject context 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
+ test/Servant/ServerSpec.hs view
@@ -0,0 +1,636 @@+{-# 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++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (forM_, when, unless)+import Control.Monad.Trans.Except (ExceptT, throwE)+import Data.Aeson (FromJSON, ToJSON, decode', encode)+import Data.ByteString.Conversion ()+import Data.Char (toUpper)+import Data.Proxy (Proxy (Proxy))+import Data.String (fromString)+import Data.String.Conversions (cs)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Network.HTTP.Types (Status (..), hAccept, hContentType,+ methodDelete, methodGet,+ methodHead, methodPatch,+ methodPost, methodPut, ok200,+ parseQuery)+import Network.Wai (Application, Request, requestHeaders, pathInfo,+ queryString, rawQueryString,+ responseBuilder, responseLBS)+import Network.Wai.Internal (Response (ResponseBuilder))+import Network.Wai.Test (defaultRequest, request,+ runSession, simpleBody,+ simpleHeaders, simpleStatus)+import Servant.API ((:<|>) (..), (:>), AuthProtect,+ BasicAuth, BasicAuthData(BasicAuthData),+ Capture, Delete, Get, Header (..),+ Headers, HttpVersion,+ IsSecure (..), JSON,+ NoContent (..), Patch, PlainText,+ Post, Put,+ QueryFlag, QueryParam, QueryParams,+ Raw, RemoteHost, ReqBody,+ StdMethod (..), Verb, addHeader)+import Servant.API.Internal.Test.ComprehensiveAPI+import Servant.Server (ServantErr (..), Server, err401, err404,+ serve, serveWithContext, Context((:.), EmptyContext))+import Test.Hspec (Spec, context, describe, it,+ shouldBe, shouldContain)+import qualified Test.Hspec.Wai as THW+import Test.Hspec.Wai (get, liftIO, matchHeaders,+ matchStatus, shouldRespondWith,+ with, (<:>))++import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck),+ BasicAuthResult(Authorized,Unauthorized))+import Servant.Server.Experimental.Auth+ (AuthHandler, AuthServerData,+ mkAuthHandler)+import Servant.Server.Internal.RoutingApplication+ (toApplication, RouteResult(..))+import Servant.Server.Internal.Router+ (tweakResponse, runRouter,+ Router, Router'(LeafRouter))+import Servant.Server.Internal.Context+ (NamedContext(..))++-- * comprehensive api test++-- This declaration simply checks that all instances are in place.+_ = serveWithContext comprehensiveAPI comprehensiveApiContext++comprehensiveApiContext :: Context '[NamedContext "foo" '[]]+comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext++-- * Specs++spec :: Spec+spec = do+ verbSpec+ captureSpec+ queryParamSpec+ reqBodySpec+ headerSpec+ rawSpec+ alternativeSpec+ responseHeadersSpec+ routerSpec+ 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)++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)+ 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++ it "sets the Content-Type header" $ do+ response <- THW.request method "" [] ""+ liftIO $ simpleHeaders response `shouldContain`+ [("Content-Type", "application/json")]++ 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 -> ExceptT ServantErr IO Animal+captureServer legs = case legs of+ 4 -> return jerry+ 2 -> return tweety+ _ -> throwE 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 404 if the decoding fails" $ do+ get "/notAnInt" `shouldRespondWith` 404++ with (return (serve+ (Proxy :: Proxy (Capture "captured" String :> Raw))+ (\ "captured" request_ respond ->+ respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do+ it "strips the captured path snippet from pathInfo" $ do+ get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))++-- }}}+------------------------------------------------------------------------------+-- * queryParamSpec {{{+------------------------------------------------------------------------------++type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person+ :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person+ :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person++queryParamApi :: Proxy QueryParamApi+queryParamApi = Proxy++qpServer :: Server QueryParamApi+qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize++ where qpNames (_:name2:_) = return alice { name = name2 }+ qpNames _ = return alice++ qpCapitalize False = return alice+ qpCapitalize True = return alice { name = map toUpper (name alice) }++ 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 "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] ()+headerApi :: Proxy (HeaderApi a)+headerApi = Proxy++headerSpec :: Spec+headerSpec = describe "Servant.API.Header" $ do++ let expectsInt :: Maybe Int -> ExceptT ServantErr IO ()+ expectsInt (Just x) = when (x /= 5) $ error "Expected 5"+ expectsInt Nothing = error "Expected an int"++ let expectsString :: Maybe String -> ExceptT ServantErr IO ()+ expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"+ 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++-- }}}+------------------------------------------------------------------------------+-- * rawSpec {{{+------------------------------------------------------------------------------++type RawApi = "foo" :> Raw++rawApi :: Proxy RawApi+rawApi = Proxy++rawApplication :: Show a => (Request -> a) -> Application+rawApplication f 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] ()++alternativeApi :: Proxy AlternativeApi+alternativeApi = Proxy++alternativeServer :: Server AlternativeApi+alternativeServer =+ return alice+ :<|> return jerry+ :<|> return "a string"+ :<|> return jerry+ :<|> return jerry+ :<|> return ()++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++-- }}}+------------------------------------------------------------------------------+-- * routerSpec {{{+------------------------------------------------------------------------------+routerSpec :: Spec+routerSpec = do+ describe "Servant.Server.Internal.Router" $ do+ let app' :: Application+ app' = toApplication $ runRouter router'++ router', router :: Router+ router' = tweakResponse (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++-- }}}+------------------------------------------------------------------------------+-- * miscCombinatorSpec {{{+------------------------------------------------------------------------------+type MiscCombinatorsAPI+ = "version" :> HttpVersion :> Get '[JSON] String+ :<|> "secure" :> IsSecure :> Get '[JSON] String+ :<|> "host" :> RemoteHost :> Get '[JSON] String++miscApi :: Proxy MiscCombinatorsAPI+miscApi = Proxy++miscServ :: Server MiscCombinatorsAPI+miscServ = versionHandler+ :<|> secureHandler+ :<|> hostHandler++ 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\""++ where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res++-- }}}+------------------------------------------------------------------------------+-- * Basic Authentication {{{+------------------------------------------------------------------------------++type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal++basicAuthApi :: Proxy BasicAuthAPI+basicAuthApi = Proxy+basicAuthServer :: Server BasicAuthAPI+basicAuthServer = const (return jerry)++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+ it "returns with 401 with bad password" $ do+ get "/basic" `shouldRespondWith` 401+ it "returns 200 with the right password" $ do+ THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200++-- }}}+------------------------------------------------------------------------------+-- * General Authentication {{{+------------------------------------------------------------------------------++type GenAuthAPI = AuthProtect "auth" :> "auth" :> Get '[JSON] Animal+authApi :: Proxy GenAuthAPI+authApi = Proxy+authServer :: Server GenAuthAPI+authServer = const (return tweety)++type instance AuthServerData (AuthProtect "auth") = ()++genAuthContext :: Context '[ AuthHandler Request () ]+genAuthContext =+ let authHandler = (\req ->+ if elem ("Auth", "secret") (requestHeaders req)+ then return ()+ else throwE err401+ )+ in mkAuthHandler authHandler :. EmptyContext++genAuthSpec :: Spec+genAuthSpec = do+ describe "Servant.API.Auth" $ do+ with (return (serveWithContext authApi genAuthContext authServer)) $ do++ context "Custom Auth Protection" $ do+ it "returns 401 when missing headers" $ do+ get "/auth" `shouldRespondWith` 401+ it "returns 200 with the right header" $ do+ THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200++-- }}}+------------------------------------------------------------------------------+-- * 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+-- }}}
+ test/Servant/Utils/StaticFilesSpec.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Servant.Utils.StaticFilesSpec where++import Control.Exception (bracket)+import Data.Proxy (Proxy (Proxy))+import Network.Wai (Application)+import System.Directory (createDirectory,+ getCurrentDirectory,+ setCurrentDirectory)+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec (Spec, around_, describe, it)+import Test.Hspec.Wai (get, shouldRespondWith, with)++import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)+import Servant.Server (Server, serve)+import Servant.ServerSpec (Person (Person))+import Servant.Utils.StaticFiles (serveDirectory)++type Api =+ "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person+ :<|> "static" :> Raw+++api :: Proxy Api+api = Proxy++app :: Application+app = serve api server++server :: Server Api+server =+ (\ name_ -> return (Person name_ 42))+ :<|> serveDirectory "static"++withStaticFiles :: IO () -> IO ()+withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->+ bracket (setup tmpDir) teardown (const action)+ where+ setup tmpDir = do+ outer <- getCurrentDirectory+ setCurrentDirectory tmpDir+ createDirectory "static"+ writeFile "static/foo.txt" "bar"+ writeFile "static/index.html" "index"+ return outer++ teardown outer = do+ setCurrentDirectory outer++spec :: Spec+spec = do+ around_ withStaticFiles $ with (return app) $ do+ describe "serveDirectory" $ do+ it "successfully serves files" $ do+ get "/static/foo.txt" `shouldRespondWith` "bar"++ it "serves the contents of index.html when requesting the root of a directory" $ do+ get "/static/" `shouldRespondWith` "index"