servant-server 0.19.2 → 0.20
raw patch · 7 files changed
+176/−30 lines, 7 filesdep ~basedep ~bytestringdep ~constraints
Dependency ranges changed: base, bytestring, constraints, containers, hspec, http-api-data, mtl, network, resourcet, servant, text, transformers, warp
Files
- CHANGELOG.md +8/−0
- servant-server.cabal +12/−12
- src/Servant/Server/Experimental/Auth.hs +2/−1
- src/Servant/Server/Internal.hs +80/−9
- src/Servant/Server/Internal/Context.hs +1/−1
- src/Servant/Server/Internal/Router.hs +19/−1
- test/Servant/ServerSpec.hs +54/−6
CHANGELOG.md view
@@ -3,6 +3,13 @@ Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions. +0.20+----++- Add API docs for ServerT [#1573](https://github.com/haskell-servant/servant/pull/1573)+- Add Functor instance to AuthHandler. [#1638](https://github.com/haskell-servant/servant/pull/1638)+- Compatibility with GHC 9.6. [#1680](https://github.com/haskell-servant/servant/pull/1680)+ 0.19.2 ------ @@ -13,6 +20,7 @@ - Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545) - Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)+- Add capture hints in `Router` type for debug and display purposes [PR #1556] (https://github.com/haskell-servant/servant/pull/1556) 0.19 ----
servant-server.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: servant-server-version: 0.19.2+version: 0.20 synopsis: A family of combinators for defining webservices APIs and serving them category: Servant, Web@@ -23,7 +23,7 @@ maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple-tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1+tested-with: GHC==8.6.5, GHC==8.8.4, GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.7, GHC ==9.4.4 extra-source-files: CHANGELOG.md@@ -60,25 +60,25 @@ -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 build-depends:- base >= 4.9 && < 4.18+ base >= 4.9 && < 4.19 , bytestring >= 0.10.8.1 && < 0.12 , constraints >= 0.2 && < 0.14 , containers >= 0.5.7.1 && < 0.7- , mtl >= 2.2.2 && < 2.3+ , mtl ^>= 2.2.2 || ^>= 2.3.1 , text >= 1.2.3.0 && < 2.1- , transformers >= 0.5.2.0 && < 0.6+ , transformers >= 0.5.2.0 && < 0.7 , filepath >= 1.4.1.1 && < 1.5 -- Servant dependencies -- strict dependency as we re-export 'servant' things. build-depends:- servant >= 0.19 && < 0.20- , http-api-data >= 0.4.1 && < 0.5.1+ servant >= 0.20 && < 0.21+ , http-api-data >= 0.4.1 && < 0.6 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends:- base-compat >= 0.10.5 && < 0.13+ base-compat >= 0.10.5 && < 0.14 , base64-bytestring >= 1.0.0.1 && < 1.3 , exceptions >= 0.10.0 && < 0.11 , http-media >= 0.7.1.3 && < 0.9@@ -88,10 +88,10 @@ , network >= 2.8 && < 3.2 , sop-core >= 0.4.0.0 && < 0.6 , string-conversions >= 0.4.0.1 && < 0.5- , resourcet >= 1.2.2 && < 1.3+ , resourcet >= 1.2.2 && < 1.4 , tagged >= 0.8.6 && < 0.9 , transformers-base >= 0.4.5.2 && < 0.5- , wai >= 3.2.1.2 && < 3.3+ , wai >= 3.2.2.1 && < 3.3 , wai-app-static >= 3.1.6.2 && < 3.2 , word8 >= 0.1.3 && < 0.2 @@ -159,7 +159,7 @@ build-depends: aeson >= 1.4.1.0 && < 3 , directory >= 1.3.0.0 && < 1.4- , hspec >= 2.6.0 && < 2.10+ , hspec >= 2.6.0 && < 2.11 , hspec-wai >= 0.10.1 && < 0.12 , QuickCheck >= 2.12.6.1 && < 2.15 , should-not-typecheck >= 2.1.0 && < 2.2@@ -167,4 +167,4 @@ , wai-extra >= 3.0.24.3 && < 3.2 build-tool-depends:- hspec-discover:hspec-discover >= 2.6.0 && <2.10+ hspec-discover:hspec-discover >= 2.6.0 && <2.11
src/Servant/Server/Experimental/Auth.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -44,7 +45,7 @@ -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE newtype AuthHandler r usr = AuthHandler { unAuthHandler :: r -> Handler usr }- deriving (Generic, Typeable)+ deriving (Functor, Generic, Typeable) -- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
src/Servant/Server/Internal.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-}@@ -35,9 +36,10 @@ import Control.Monad (join, when) import Control.Monad.Trans- (liftIO)+ (liftIO, lift) import Control.Monad.Trans.Resource- (runResourceT)+ (runResourceT, ReleaseKey)+import Data.Acquire import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BC8@@ -64,7 +66,7 @@ import Network.Socket (SockAddr) import Network.Wai- (Application, Request, httpVersion, isSecure, lazyRequestBody,+ (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody, queryString, remoteHost, getRequestBodyChunk, requestHeaders, requestMethod, responseLBS, responseStream, vault) import Prelude ()@@ -74,10 +76,10 @@ CaptureAll, Description, EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..), FromSourceIO (..), Header', If, IsSecure (..), NoContentVerb, QueryFlag,- QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),+ QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod), RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,- WithNamedContext, NamedRoutes)+ WithNamedContext, WithResource, NamedRoutes) import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),@@ -115,6 +117,10 @@ (AtLeastOneFragment, FragmentUnique) class HasServer api context where+ -- | The type of a server for this API, given a monad to run effects in.+ --+ -- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike+ -- what the @T@ in the name might suggest. type ServerT api (m :: * -> *) :: * route ::@@ -244,6 +250,42 @@ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a])) +-- | If you use 'WithResource' in one of the endpoints for your API Servant+-- will provide the handler for this endpoint an argument of the specified type.+-- The lifespan of this resource will be automatically managed by Servant. This+-- resource will be created before the handler starts and it will be destoyed+-- after it ends. A new resource is created for each request to the endpoint.++-- The creation and destruction are done using a 'Data.Acquire.Acquire'+-- provided via server 'Context'.+--+-- Example+--+-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent+-- >+-- > server :: Server MyApi+-- > server = writeToFile+-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent+-- > writeToFile (_, h) = hPutStrLn h "message"+--+-- In addition to the resource, the handler will also receive a 'ReleaseKey'+-- which can be used to deallocate the resource before the end of the request+-- if desired.++instance (HasServer api ctx, HasContextEntry ctx (Acquire a))+ => HasServer (WithResource a :> api) ctx where++ type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s++ route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)+ where+ allocateResource :: DelayedIO (ReleaseKey, a)+ allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)+++ allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead @@ -611,6 +653,35 @@ Fail a -> respond $ Fail a FailFatal e -> respond $ FailFatal e +-- | 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 RawM context where+ type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived++ route+ :: Proxy RawM+ -> Context context+ -> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env+ route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do+ routeResult <- runDelayed handleDelayed env request+ let respond' = liftIO . respond+ liftIO $ case routeResult of+ Route handler -> runHandler (handler request (respond . Route)) >>=+ \case+ Left e -> respond' $ FailFatal e+ Right a -> pure a+ Fail e -> respond' $ Fail e+ FailFatal e -> respond' $ FailFatal e++ hoistServerWithContext _ _ f srvM = \req respond -> f (srvM req respond)++ -- | 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'.@@ -681,18 +752,17 @@ route Proxy context subserver = route (Proxy :: Proxy api) context $ addBodyCheck subserver ctCheck bodyCheck where- ctCheck :: DelayedIO (SourceIO chunk -> a)+ ctCheck :: DelayedIO (SourceIO chunk -> IO a) -- TODO: do content-type check ctCheck = return fromSourceIO - bodyCheck :: (SourceIO chunk -> a) -> DelayedIO a+ bodyCheck :: (SourceIO chunk -> IO a) -> DelayedIO a bodyCheck fromRS = withRequest $ \req -> do let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk let body = getRequestBodyChunk req let rs = S.fromAction B.null body- let rs' = fromRS $ framingUnrender' rs- return rs'+ liftIO $ fromRS $ framingUnrender' rs -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @api@.@@ -942,6 +1012,7 @@ ( HasServer (ToServantApi api) context , forall m. Generic (api (AsServerT m)) , forall m. GServer api m+ , ErrorIfNoGeneric api ) => HasServer (NamedRoutes api) context where type ServerT (NamedRoutes api) m = api (AsServerT m)
src/Servant/Server/Internal/Context.hs view
@@ -71,7 +71,7 @@ -- -- >>> getContextEntry (True :. False :. EmptyContext) :: String -- ...--- ...No instance for (HasContextEntry '[] [Char])+-- ...No instance for ...HasContextEntry '[] [Char]... -- ... class HasContextEntry (context :: [*]) (val :: *) where getContextEntry :: Context context -> val
src/Servant/Server/Internal/Router.hs view
@@ -28,9 +28,12 @@ type Router env = Router' env RoutingApplication +-- | Holds information about pieces of url that are captured as variables. data CaptureHint = CaptureHint { captureName :: Text+ -- ^ Holds the name of the captured variable , captureType :: TypeRep+ -- ^ Holds the type of the captured variable } deriving (Show, Eq) @@ -54,10 +57,21 @@ -- for the empty path, to be tried in order | CaptureRouter [CaptureHint] (Router' (Text, env) a) -- ^ first path component is passed to the child router in its- -- environment and removed afterwards+ -- environment and removed afterwards.+ -- The first argument is a list of hints for all variables that can be+ -- captured by the router. The fact that it is a list is counter-intuitive,+ -- because the 'Capture' combinator only allows to capture a single varible,+ -- with a single name and a single type. However, the 'choice' smart+ -- constructor may merge two 'Capture' combinators with different hints, thus+ -- forcing the type to be '[CaptureHint]'.+ -- Because 'CaptureRouter' is built from a 'Capture' combinator, the list of+ -- hints should always be non-empty. | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a) -- ^ all path components are passed to the child router in its -- environment and are removed afterwards+ -- The first argument is a hint for the list of variables that can be+ -- captured by the router. Note that the 'captureType' field of the hint+ -- should always be '[a]' for some 'a'. | RawRouter (env -> a) -- ^ to be used for routes we do not know anything about | Choice (Router' env a) (Router' env a)@@ -101,6 +115,10 @@ data RouterStructure = StaticRouterStructure (Map Text RouterStructure) Int | CaptureRouterStructure [CaptureHint] RouterStructure+ -- ^ The first argument holds information about variables+ -- that are captured by the router. There may be several hints+ -- if several routers have been aggregated by the 'choice'+ -- smart constructor. | RawRouterStructure | ChoiceStructure RouterStructure RouterStructure deriving (Eq, Show)
test/Servant/ServerSpec.hs view
@@ -17,10 +17,14 @@ import Control.Monad (forM_, unless, when)+import Control.Monad.Reader (runReaderT, ask) import Control.Monad.Error.Class (MonadError (..))+import Control.Monad.IO.Class (MonadIO(..)) import Data.Aeson (FromJSON, ToJSON, decode', encode)+import Data.Acquire+ (Acquire, mkAcquire) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as Base64 import Data.Char@@ -52,19 +56,19 @@ Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header, Headers, HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,- PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,+ PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM, RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict, UVerb, Union, Verb, WithStatus (..), addHeader) import Servant.Server- (Context ((:.), EmptyContext), Handler, Server, Tagged (..),- emptyServer, err401, err403, err404, respond, serve,+ (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..),+ emptyServer, err401, err403, err404, hoistServer, respond, serve, serveWithContext) import Servant.Test.ComprehensiveAPI import qualified Servant.Types.SourceT as S import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import Test.Hspec.Wai- (get, liftIO, matchHeaders, matchStatus, shouldRespondWith,+ (get, matchHeaders, matchStatus, shouldRespondWith, with, (<:>)) import qualified Test.Hspec.Wai as THW @@ -81,8 +85,11 @@ -- This declaration simply checks that all instances are in place. _ = serveWithContext comprehensiveAPI comprehensiveApiContext -comprehensiveApiContext :: Context '[NamedContext "foo" '[]]-comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext+comprehensiveApiContext :: Context '[NamedContext "foo" '[], Acquire Int]+comprehensiveApiContext =+ NamedContext EmptyContext :.+ mkAcquire (pure 10) (\_ -> pure ()) :.+ EmptyContext -- * Specs @@ -97,6 +104,7 @@ reqBodySpec headerSpec rawSpec+ rawMSpec alternativeSpec responseHeadersSpec uverbResponseHeadersSpec@@ -603,6 +611,46 @@ liftIO $ do simpleBody response `shouldBe` cs (show ["bar" :: String]) +-- }}}+------------------------------------------------------------------------------+-- * rawMSpec {{{+------------------------------------------------------------------------------++type RawMApi = "foo" :> RawM++rawMApi :: Proxy RawMApi+rawMApi = Proxy++rawMServer :: (Monad m, MonadIO m, Show a) => (Request -> m a) -> ServerT RawMApi m+rawMServer f req resp = liftIO . resp . responseLBS ok200 [] . cs . show =<< f req++rawMSpec :: Spec+rawMSpec = do+ describe "Servant.API.RawM" $ do+ it "gives access to monadic context" $ do+ flip runSession (serve rawMApi+ (hoistServer rawMApi (flip runReaderT (42 :: Integer)) (rawMServer (const ask)))) $ do+ response <- Network.Wai.Test.request defaultRequest{+ pathInfo = ["foo"]+ }+ liftIO $ do+ simpleBody response `shouldBe` "42"++ it "lets users throw servant errors" $ do+ flip runSession (serve rawMApi (rawMServer (const $ throwError err404 >> pure (42 :: Integer)))) $ do+ response <- Network.Wai.Test.request defaultRequest{+ pathInfo = ["foo"]+ }+ liftIO $ do+ statusCode (simpleStatus response) `shouldBe` 404++ it "gets the pathInfo modified" $ do+ flip runSession (serve rawMApi (rawMServer (pure . pathInfo))) $ do+ response <- Network.Wai.Test.request defaultRequest{+ pathInfo = ["foo", "bar"]+ }+ liftIO $ do+ simpleBody response `shouldBe` cs (show ["bar" :: String]) -- }}} ------------------------------------------------------------------------------ -- * alternativeSpec {{{