diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ---- diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -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 diff --git a/src/Servant/Server/Experimental/Auth.hs b/src/Servant/Server/Experimental/Auth.hs --- a/src/Servant/Server/Experimental/Auth.hs +++ b/src/Servant/Server/Experimental/Auth.hs @@ -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 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 @@ -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) diff --git a/src/Servant/Server/Internal/Context.hs b/src/Servant/Server/Internal/Context.hs --- a/src/Servant/Server/Internal/Context.hs +++ b/src/Servant/Server/Internal/Context.hs @@ -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 diff --git a/src/Servant/Server/Internal/Router.hs b/src/Servant/Server/Internal/Router.hs --- a/src/Servant/Server/Internal/Router.hs +++ b/src/Servant/Server/Internal/Router.hs @@ -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) diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -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 {{{