diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ----- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/example/greet.hs b/example/greet.hs --- a/example/greet.hs +++ b/example/greet.hs @@ -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 diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h new file mode 100644 --- /dev/null +++ b/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -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 diff --git a/src/Servant.hs b/src/Servant.hs --- a/src/Servant.hs +++ b/src/Servant.hs @@ -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 diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -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 , 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`. diff --git a/src/Servant/Server/Experimental/Auth.hs b/src/Servant/Server/Experimental/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Experimental/Auth.hs @@ -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 + diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -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 +-- . +-- 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 diff --git a/src/Servant/Server/Internal/BasicAuth.hs b/src/Servant/Server/Internal/BasicAuth.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/BasicAuth.hs @@ -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] } diff --git a/src/Servant/Server/Internal/Context.hs b/src/Servant/Server/Internal/Context.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/Context.hs @@ -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 diff --git a/src/Servant/Server/Internal/Enter.hs b/src/Servant/Server/Internal/Enter.hs --- a/src/Servant/Server/Internal/Enter.hs +++ b/src/Servant/Server/Internal/Enter.hs @@ -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) diff --git a/src/Servant/Server/Internal/Router.hs b/src/Servant/Server/Internal/Router.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/Router.hs @@ -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 = (<) diff --git a/src/Servant/Server/Internal/RoutingApplication.hs b/src/Servant/Server/Internal/RoutingApplication.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/RoutingApplication.hs @@ -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 , we cannot +do the more succint thing - just update the records we actually change. +-} diff --git a/src/Servant/Server/Internal/ServantErr.hs b/src/Servant/Server/Internal/ServantErr.hs --- a/src/Servant/Server/Internal/ServantErr.hs +++ b/src/Servant/Server/Internal/ServantErr.hs @@ -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 diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs --- a/src/Servant/Utils/StaticFiles.hs +++ b/src/Servant/Utils/StaticFiles.hs @@ -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. diff --git a/test/Doctests.hs b/test/Doctests.hs --- a/test/Doctests.hs +++ b/test/Doctests.hs @@ -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 diff --git a/test/Servant/Server/ErrorSpec.hs b/test/Servant/Server/ErrorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Server/ErrorSpec.hs @@ -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 +-- }}} diff --git a/test/Servant/Server/Internal/ContextSpec.hs b/test/Servant/Server/Internal/ContextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Server/Internal/ContextSpec.hs @@ -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) diff --git a/test/Servant/Server/Internal/EnterSpec.hs b/test/Servant/Server/Internal/EnterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Server/Internal/EnterSpec.hs @@ -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" diff --git a/test/Servant/Server/UsingContextSpec.hs b/test/Servant/Server/UsingContextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Server/UsingContextSpec.hs @@ -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\"" diff --git a/test/Servant/Server/UsingContextSpec/TestCombinators.hs b/test/Servant/Server/UsingContextSpec/TestCombinators.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Server/UsingContextSpec/TestCombinators.hs @@ -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 diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/ServerSpec.hs @@ -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 +-- }}} diff --git a/test/Servant/Utils/StaticFilesSpec.hs b/test/Servant/Utils/StaticFilesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Utils/StaticFilesSpec.hs @@ -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"