eeva
/
servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

WithResource combinator for Servant-managed resources (#1630)

This commit is contained in:
andremarianiello 2022-12-29 13:00:47 -05:00 committed by GitHub
parent a4194dc490
commit 751350ba9e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
17 changed files with 255 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
cabal.project
View File

@ -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

1
doc/cookbook/index.rst
View File

@ -37,3 +37,4 @@ you name it!
sentry/Sentry.lhs
testing/Testing.lhs
open-id-connect/OpenIdConnect.lhs
managed-resource/ManagedResource.lhs

114
doc/cookbook/managed-resource/ManagedResource.lhs Normal file
View File

@ -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.

30
doc/cookbook/managed-resource/managed-resource.cabal Normal file
View File

@ -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

1
doc/requirements.txt
View File

@ -1,3 +1,4 @@
recommonmark==0.5.0
Sphinx==1.8.4
sphinx_rtd_theme>=0.4.2
jinja2<3.1.0

10
servant-client-core/src/Servant/Client/Core/HasClient.hs
View File

@ -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)

18
servant-docs/golden/comprehensive.md
View File

@ -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:

3
servant-docs/src/Servant/Docs/Internal.hs
View File

@ -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')

7
servant-foreign/src/Servant/Foreign/Internal.hs
View File

@ -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

43
servant-server/src/Servant/Server/Internal.hs
View File

@ -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

9
servant-server/test/Servant/ServerSpec.hs
View File

@ -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

4
servant-swagger/src/Servant/Swagger/Internal.hs
View File

@ -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

1
servant/servant.cabal
View File

@ -62,6 +62,7 @@ library
Servant.API.Vault
Servant.API.Verbs
Servant.API.WithNamedContext
Servant.API.WithResource
-- Types
exposed-modules:

14
servant/src/Servant/API.hs
View File

@ -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

3
servant/src/Servant/API/WithResource.hs Normal file
View File

@ -0,0 +1,3 @@
module Servant.API.WithResource (WithResource) where
data WithResource res

6
servant/src/Servant/Links.hs
View File

@ -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)

1
servant/src/Servant/Test/ComprehensiveAPI.hs
View File

@ -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