diff --git a/cabal.project b/cabal.project index 42e8057b..aaeb1b38 100644 --- a/cabal.project +++ b/cabal.project @@ -47,6 +47,7 @@ packages: doc/cookbook/using-custom-monad doc/cookbook/using-free-client -- doc/cookbook/open-id-connect + doc/cookbook/managed-resource tests: True optimization: False diff --git a/doc/cookbook/index.rst b/doc/cookbook/index.rst index a4e20685..cb24c216 100644 --- a/doc/cookbook/index.rst +++ b/doc/cookbook/index.rst @@ -37,3 +37,4 @@ you name it! sentry/Sentry.lhs testing/Testing.lhs open-id-connect/OpenIdConnect.lhs + managed-resource/ManagedResource.lhs diff --git a/doc/cookbook/managed-resource/ManagedResource.lhs b/doc/cookbook/managed-resource/ManagedResource.lhs new file mode 100644 index 00000000..b3d10601 --- /dev/null +++ b/doc/cookbook/managed-resource/ManagedResource.lhs @@ -0,0 +1,114 @@ +# Request-lifetime Managed Resources + +Let's see how we can write a handle that uses a resource managed by Servant. The resource is created automatically by Servant when the server recieves a request, and the resource is automatically destroyed when the server is finished handling a request. + +As usual, we start with a little bit of throat clearing. + + +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +import Control.Concurrent +import Control.Exception (bracket, throwIO) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Acquire +import Network.HTTP.Client (newManager, defaultManagerSettings) +import Network.Wai.Handler.Warp +import Servant +import Servant.Client +import System.IO +``` + +Here we define an API type that uses the `WithResource` combinator. The server handler for an endpoint with a `WithResource res` component will receive a value of that type as an argument. + +``` haskell +type API = WithResource Handle :> ReqBody '[PlainText] String :> Post '[JSON] NoContent + +api :: Proxy API +api = Proxy +``` + +But this resource value has to come from somewhere. Servant obtains the value using an Acquire provided in the context. The Acquire knows how to both create and destroy resources of a particular type. + +``` haskell +appContext :: Context '[Acquire Handle] +appContext = acquireHandle :. EmptyContext + +acquireHandle :: Acquire Handle +acquireHandle = mkAcquire newHandle closeHandle + +newHandle :: IO Handle +newHandle = do + putStrLn "opening file" + h <- openFile "test.txt" AppendMode + putStrLn "opened file" + return h + +closeHandle :: Handle -> IO () +closeHandle h = do + putStrLn "closing file" + hClose h + putStrLn "closed file" +``` + +Now we create the handler which will use this resource. This handler will write the request message to the System.IO.Handle which was provided to us. In some situations the handler will succeed, but in some in will fail. In either case, Servant will clean up the resource for us. + +``` haskell +server :: Server API +server = writeToFile + + where writeToFile :: (ReleaseKey, Handle) -> String -> Handler NoContent + writeToFile (_, h) msg = case msg of + "illegal" -> error "wait, that's illegal!" + legalMsg -> liftIO $ do + putStrLn "writing file" + hPutStrLn h legalMsg + putStrLn "wrote file" + return NoContent +``` + +Finally we run the server in the background while we post messages to it. + +``` haskell +runApp :: IO () +runApp = run 8080 (serveWithContext api appContext $ server) + +postMsg :: String -> ClientM NoContent +postMsg = client api + +main :: IO () +main = do + mgr <- newManager defaultManagerSettings + bracket (forkIO $ runApp) killThread $ \_ -> do + ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do + liftIO $ putStrLn "sending hello message" + _ <- postMsg "hello" + liftIO $ putStrLn "sending illegal message" + _ <- postMsg "illegal" + liftIO $ putStrLn "done" + print ms +``` + +This program prints + +``` +sending hello message +opening file +opened file +writing file +wrote file +closing file +closed file +sending illegal message +opening file +opened file +closing file +closed file +wait, that's illegal! +CallStack (from HasCallStack): + error, called at ManagedResource.lhs:63:24 in main:Main +Left (FailureResponse (Request {requestPath = (BaseUrl {baseUrlScheme = Http, baseUrlHost = "localhost", baseUrlPort = 8080, baseUrlPath = ""},""), requestQueryString = fromList [], requestBody = Just ((),text/plain;charset=utf-8), requestAccept = fromList [], requestHeaders = fromList [], requestHttpVersion = HTTP/1.1, requestMethod = "POST"}) (Response {responseStatusCode = Status {statusCode = 500, statusMessage = "Internal Server Error"}, responseHeaders = fromList [("Transfer-Encoding","chunked"),("Date","Thu, 24 Nov 2022 21:04:47 GMT"),("Server","Warp/3.3.23"),("Content-Type","text/plain; charset=utf-8")], responseHttpVersion = HTTP/1.1, responseBody = "Something went wrong"})) +``` + +and appends to a file called `test.txt`. We can see from the output that when a legal message is sent, the file is opened, written to, and closed. We can also see that when an illegal message is sent, the file is opened but not written to. Crucially, it is still closed even though the handler threw an exception. diff --git a/doc/cookbook/managed-resource/managed-resource.cabal b/doc/cookbook/managed-resource/managed-resource.cabal new file mode 100644 index 00000000..ee22294e --- /dev/null +++ b/doc/cookbook/managed-resource/managed-resource.cabal @@ -0,0 +1,30 @@ +cabal-version: 2.2 +name: cookbook-managed-resource +version: 0.1 +synopsis: Simple managed resource cookbook example +homepage: http://docs.servant.dev/ +license: BSD-3-Clause +license-file: ../../../servant/LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +build-type: Simple +tested-with: GHC==9.4.2 + +executable cookbook-managed-resource + main-is: ManagedResource.lhs + build-depends: base == 4.* + , text >= 1.2 + , aeson >= 1.2 + , servant + , servant-client + , servant-server + , warp >= 3.2 + , wai >= 3.2 + , http-types >= 0.12 + , markdown-unlit >= 0.4 + , http-client >= 0.5 + , transformers + , resourcet + default-language: Haskell2010 + ghc-options: -Wall -pgmL markdown-unlit + build-tool-depends: markdown-unlit:markdown-unlit diff --git a/doc/requirements.txt b/doc/requirements.txt index 54edda34..c507e438 100644 --- a/doc/requirements.txt +++ b/doc/requirements.txt @@ -1,3 +1,4 @@ recommonmark==0.5.0 Sphinx==1.8.4 sphinx_rtd_theme>=0.4.2 +jinja2<3.1.0 diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index fe2a15f8..18e6ef6c 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -77,7 +77,7 @@ import Servant.API NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault, - Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList, + Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList, getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes) import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi @@ -776,6 +776,14 @@ instance HasClient m subapi => hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl +instance HasClient m subapi => + HasClient m (WithResource res :> subapi) where + + type Client m (WithResource res :> subapi) = Client m subapi + clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi) + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl + instance ( HasClient m api ) => HasClient m (AuthProtect tag :> api) where type Client m (AuthProtect tag :> api) diff --git a/servant-docs/golden/comprehensive.md b/servant-docs/golden/comprehensive.md index 9584d499..a9cc1260 100644 --- a/servant-docs/golden/comprehensive.md +++ b/servant-docs/golden/comprehensive.md @@ -530,6 +530,24 @@ ``` +## GET /resource + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + ## GET /streaming ### Request: diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index b5c4bf1f..7e7706b5 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -1144,6 +1144,9 @@ instance HasDocs api => HasDocs (Vault :> api) where instance HasDocs api => HasDocs (WithNamedContext name context api) where docsFor Proxy = docsFor (Proxy :: Proxy api) +instance HasDocs api => HasDocs (WithResource res :> api) where + docsFor Proxy = docsFor (Proxy :: Proxy api) + instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where docsFor Proxy (endpoint, action) = docsFor (Proxy :: Proxy api) (endpoint, action') diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index d77cdb84..a184347c 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -487,6 +487,13 @@ instance HasForeign lang ftype api => foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api) +instance HasForeign lang ftype api => + HasForeign lang ftype (WithResource res :> api) where + + type Foreign ftype (WithResource res :> api) = Foreign ftype api + + foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api) + instance HasForeign lang ftype api => HasForeign lang ftype (HttpVersion :> api) where type Foreign ftype (HttpVersion :> api) = Foreign ftype api diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index a4d74564..8623f1f9 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -35,9 +35,10 @@ module Servant.Server.Internal 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 @@ -77,7 +78,7 @@ import Servant.API QueryParam', QueryParams, Raw, 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 (..), @@ -244,6 +245,42 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a 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 diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 39e75cd4..67c2bc1a 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -21,6 +21,8 @@ import Control.Monad.Error.Class (MonadError (..)) 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 @@ -81,8 +83,11 @@ import Servant.Server.Internal.Context -- 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 diff --git a/servant-swagger/src/Servant/Swagger/Internal.hs b/servant-swagger/src/Servant/Swagger/Internal.hs index 66cb0595..5f7a1ff3 100644 --- a/servant-swagger/src/Servant/Swagger/Internal.hs +++ b/servant-swagger/src/Servant/Swagger/Internal.hs @@ -304,6 +304,10 @@ instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where toSwagger _ = toSwagger (Proxy :: Proxy sub) +-- | @'WithResource'@ combinator does not change our specification at all. +instance (HasSwagger sub) => HasSwagger (WithResource res :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub)) where diff --git a/servant/servant.cabal b/servant/servant.cabal index a3dc401d..6fc8a326 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -62,6 +62,7 @@ library Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext + Servant.API.WithResource -- Types exposed-modules: diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 22309dce..88ce976a 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -31,6 +31,8 @@ module Servant.API ( -- | Access the location for arbitrary data to be shared by applications and middleware module Servant.API.WithNamedContext, -- | Access context entries in combinators in servant-server + module Servant.API.WithResource, + -- | Access a managed resource scoped to a single request -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs, @@ -101,17 +103,19 @@ import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Fragment (Fragment) +import Servant.API.Generic + (AsApi, GServantProduct, GenericMode ((:-)), GenericServant, + ToServant, ToServantApi, fromServant, genericApi, toServant) import Servant.API.Header (Header, Header') -import Servant.API.Generic - (GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct, - GenericServant, fromServant, toServant, genericApi) import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.IsSecure (IsSecure (..)) import Servant.API.Modifiers (Lenient, Optional, Required, Strict) +import Servant.API.NamedRoutes + (NamedRoutes) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) import Servant.API.Raw @@ -137,8 +141,6 @@ import Servant.API.UVerb Unique, WithStatus (..), inject, statusOf) import Servant.API.Vault (Vault) -import Servant.API.NamedRoutes - (NamedRoutes) import Servant.API.Verbs (Delete, DeleteAccepted, DeleteNoContent, DeleteNonAuthoritative, Get, GetAccepted, GetNoContent, @@ -150,6 +152,8 @@ import Servant.API.Verbs ReflectMethod (reflectMethod), StdMethod (..), Verb) import Servant.API.WithNamedContext (WithNamedContext) +import Servant.API.WithResource + (WithResource) import Servant.Links (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink) import Web.HttpApiData diff --git a/servant/src/Servant/API/WithResource.hs b/servant/src/Servant/API/WithResource.hs new file mode 100644 index 00000000..df2852e5 --- /dev/null +++ b/servant/src/Servant/API/WithResource.hs @@ -0,0 +1,3 @@ +module Servant.API.WithResource (WithResource) where + +data WithResource res diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index 74314e0a..52ff4ae4 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -193,6 +193,8 @@ import Servant.API.Verbs (Verb, NoContentVerb) import Servant.API.WithNamedContext (WithNamedContext) +import Servant.API.WithResource + (WithResource) import Web.HttpApiData import Data.Kind (Type) @@ -558,6 +560,10 @@ instance HasLink sub => HasLink (WithNamedContext name context sub) where type MkLink (WithNamedContext name context sub) a = MkLink sub a toLink toA _ = toLink toA (Proxy :: Proxy sub) +instance HasLink sub => HasLink (WithResource res :> sub) where + type MkLink (WithResource res :> sub) a = MkLink sub a + toLink toA _ = toLink toA (Proxy :: Proxy sub) + instance HasLink sub => HasLink (RemoteHost :> sub) where type MkLink (RemoteHost :> sub) a = MkLink sub a toLink = simpleToLink (Proxy :: Proxy sub) diff --git a/servant/src/Servant/Test/ComprehensiveAPI.hs b/servant/src/Servant/Test/ComprehensiveAPI.hs index 67417869..adfb5d25 100644 --- a/servant/src/Servant/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/Test/ComprehensiveAPI.hs @@ -72,6 +72,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint = :<|> "description" :> Description "foo" :> GET :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET) :<|> "fragment" :> Fragment Int :> GET + :<|> "resource" :> WithResource Int :> GET :<|> endpoint type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint