751350b · servant · git.iko.soy

cabal.project+1

compare with master

unifiedsplit

@@ -47,6 +47,7 @@ packages:

47 doc/cookbook/using-custom-monad

48 doc/cookbook/using-free-client

49 -- doc/cookbook/open-id-connect

50+ doc/cookbook/managed-resource

50

51

51tests: True

52tests: True

52optimization: False

53optimization: False

doc/cookbook/index.rst+1

@@ -37,3 +37,4 @@ you name it!

37 sentry/Sentry.lhs

38 testing/Testing.lhs

39 open-id-connect/OpenIdConnect.lhs

40+ managed-resource/ManagedResource.lhs

doc/cookbook/managed-resource/ManagedResource.lhsnew file+114

@@ -0,0 +1,114 @@

1+# Request-lifetime Managed Resources

2+

3+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.

4+

5+As usual, we start with a little bit of throat clearing.

6+

7+

8+``` haskell

9+{-# LANGUAGE DataKinds #-}

10+{-# LANGUAGE TypeOperators #-}

11+import Control.Concurrent

12+import Control.Exception (bracket, throwIO)

13+import Control.Monad.IO.Class

14+import Control.Monad.Trans.Resource

15+import Data.Acquire

16+import Network.HTTP.Client (newManager, defaultManagerSettings)

17+import Network.Wai.Handler.Warp

18+import Servant

19+import Servant.Client

20+import System.IO

21+```

22+

23+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.

24+

25+``` haskell

26+type API = WithResource Handle :> ReqBody '[PlainText] String :> Post '[JSON] NoContent

27+

28+api :: Proxy API

29+api = Proxy

30+```

31+

32+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.

33+

34+``` haskell

35+appContext :: Context '[Acquire Handle]

36+appContext = acquireHandle :. EmptyContext

37+

38+acquireHandle :: Acquire Handle

39+acquireHandle = mkAcquire newHandle closeHandle

40+

41+newHandle :: IO Handle

42+newHandle = do

43+ putStrLn "opening file"

44+ h <- openFile "test.txt" AppendMode

45+ putStrLn "opened file"

46+ return h

47+

48+closeHandle :: Handle -> IO ()

49+closeHandle h = do

50+ putStrLn "closing file"

51+ hClose h

52+ putStrLn "closed file"

53+```

54+

55+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.

56+

57+``` haskell

58+server :: Server API

59+server = writeToFile

60+

61+ where writeToFile :: (ReleaseKey, Handle) -> String -> Handler NoContent

62+ writeToFile (_, h) msg = case msg of

63+ "illegal" -> error "wait, that's illegal!"

64+ legalMsg -> liftIO $ do

65+ putStrLn "writing file"

66+ hPutStrLn h legalMsg

67+ putStrLn "wrote file"

68+ return NoContent

69+```

70+

71+Finally we run the server in the background while we post messages to it.

72+

73+``` haskell

74+runApp :: IO ()

75+runApp = run 8080 (serveWithContext api appContext $ server)

76+

77+postMsg :: String -> ClientM NoContent

78+postMsg = client api

79+

80+main :: IO ()

81+main = do

82+ mgr <- newManager defaultManagerSettings

83+ bracket (forkIO $ runApp) killThread $ \_ -> do

84+ ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do

85+ liftIO $ putStrLn "sending hello message"

86+ _ <- postMsg "hello"

87+ liftIO $ putStrLn "sending illegal message"

88+ _ <- postMsg "illegal"

89+ liftIO $ putStrLn "done"

90+ print ms

91+```

92+

93+This program prints

94+

95+```

96+sending hello message

97+opening file

98+opened file

99+writing file

100+wrote file

101+closing file

102+closed file

103+sending illegal message

104+opening file

105+opened file

106+closing file

107+closed file

108+wait, that's illegal!

109+CallStack (from HasCallStack):

110+ error, called at ManagedResource.lhs:63:24 in main:Main

111+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"}))

112+```

113+

114+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.

doc/cookbook/managed-resource/managed-resource.cabalnew file+30

@@ -0,0 +1,30 @@

1+cabal-version: 2.2

2+name: cookbook-managed-resource

3+version: 0.1

4+synopsis: Simple managed resource cookbook example

5+homepage: http://docs.servant.dev/

6+license: BSD-3-Clause

7+license-file: ../../../servant/LICENSE

8+author: Servant Contributors

9+maintainer: haskell-servant-maintainers@googlegroups.com

10+build-type: Simple

11+tested-with: GHC==9.4.2

12+

13+executable cookbook-managed-resource

14+ main-is: ManagedResource.lhs

15+ build-depends: base == 4.*

16+ , text >= 1.2

17+ , aeson >= 1.2

18+ , servant

19+ , servant-client

20+ , servant-server

21+ , warp >= 3.2

22+ , wai >= 3.2

23+ , http-types >= 0.12

24+ , markdown-unlit >= 0.4

25+ , http-client >= 0.5

26+ , transformers

27+ , resourcet

28+ default-language: Haskell2010

29+ ghc-options: -Wall -pgmL markdown-unlit

30+ build-tool-depends: markdown-unlit:markdown-unlit

doc/requirements.txt+1

@@ -1,3 +1,4 @@

1recommonmark==0.5.0

2Sphinx==1.8.4

3sphinx_rtd_theme>=0.4.2

4+jinja2<3.1.0

servant-client-core/src/Servant/Client/Core/HasClient.hs+9−1

@@ -77,7 +77,7 @@ import Servant.API

77 NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,

78 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,

79 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,

80− Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,

80+ Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,

81 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)

82import Servant.API.Generic

83 (GenericMode(..), ToServant, ToServantApi

@@ -776,6 +776,14 @@ instance HasClient m subapi =>

776

777 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl

778

779+instance HasClient m subapi =>

780+ HasClient m (WithResource res :> subapi) where

781+

782+ type Client m (WithResource res :> subapi) = Client m subapi

783+ clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)

784+

785+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl

786+

779instance ( HasClient m api

787instance ( HasClient m api

780 ) => HasClient m (AuthProtect tag :> api) where

788 ) => HasClient m (AuthProtect tag :> api) where

781 type Client m (AuthProtect tag :> api)

789 type Client m (AuthProtect tag :> api)

servant-docs/golden/comprehensive.md+18

@@ -530,6 +530,24 @@

530

531```

532

533+## GET /resource

534+

535+### Response:

536+

537+- Status code 200

538+- Headers: []

539+

540+- Supported content types are:

541+

542+ - `application/json;charset=utf-8`

543+ - `application/json`

544+

545+- Example (`application/json;charset=utf-8`, `application/json`):

546+

547+```javascript

548+

549+```

550+

533## GET /streaming

551## GET /streaming

534

552

535### Request:

553### Request:

servant-docs/src/Servant/Docs/Internal.hs+3

@@ -1144,6 +1144,9 @@ instance HasDocs api => HasDocs (Vault :> api) where

1144instance HasDocs api => HasDocs (WithNamedContext name context api) where

1145 docsFor Proxy = docsFor (Proxy :: Proxy api)

1146

1147+instance HasDocs api => HasDocs (WithResource res :> api) where

1148+ docsFor Proxy = docsFor (Proxy :: Proxy api)

1149+

1147instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where

1150instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where

1148 docsFor Proxy (endpoint, action) =

1151 docsFor Proxy (endpoint, action) =

1149 docsFor (Proxy :: Proxy api) (endpoint, action')

1152 docsFor (Proxy :: Proxy api) (endpoint, action')

servant-foreign/src/Servant/Foreign/Internal.hs+7

@@ -487,6 +487,13 @@ instance HasForeign lang ftype api =>

487

488 foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)

489

490+instance HasForeign lang ftype api =>

491+ HasForeign lang ftype (WithResource res :> api) where

492+

493+ type Foreign ftype (WithResource res :> api) = Foreign ftype api

494+

495+ foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)

496+

490instance HasForeign lang ftype api

497instance HasForeign lang ftype api

491 => HasForeign lang ftype (HttpVersion :> api) where

498 => HasForeign lang ftype (HttpVersion :> api) where

492 type Foreign ftype (HttpVersion :> api) = Foreign ftype api

499 type Foreign ftype (HttpVersion :> api) = Foreign ftype api

servant-server/src/Servant/Server/Internal.hs+40−3

@@ -35,9 +35,10 @@ module Servant.Server.Internal

35import Control.Monad

36 (join, when)

37import Control.Monad.Trans

38− (liftIO)

38+ (liftIO, lift)

39import Control.Monad.Trans.Resource

40− (runResourceT)

40+ (runResourceT, ReleaseKey)

41+import Data.Acquire

41import qualified Data.ByteString as B

42import qualified Data.ByteString as B

42import qualified Data.ByteString.Builder as BB

43import qualified Data.ByteString.Builder as BB

43import qualified Data.ByteString.Char8 as BC8

44import qualified Data.ByteString.Char8 as BC8

@@ -77,7 +78,7 @@ import Servant.API

77 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),

78 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),

78 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,

79 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,

79 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,

80 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,

80− WithNamedContext, NamedRoutes)

81+ WithNamedContext, WithResource, NamedRoutes)

81import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)

82import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)

82import Servant.API.ContentTypes

83import Servant.API.ContentTypes

83 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

84 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

@@ -244,6 +245,42 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a

244 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

245 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

245 hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))

246 hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))

246

247

248+-- | If you use 'WithResource' in one of the endpoints for your API Servant

249+-- will provide the handler for this endpoint an argument of the specified type.

250+-- The lifespan of this resource will be automatically managed by Servant. This

251+-- resource will be created before the handler starts and it will be destoyed

252+-- after it ends. A new resource is created for each request to the endpoint.

253+

254+-- The creation and destruction are done using a 'Data.Acquire.Acquire'

255+-- provided via server 'Context'.

256+--

257+-- Example

258+--

259+-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent

260+-- >

261+-- > server :: Server MyApi

262+-- > server = writeToFile

263+-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent

264+-- > writeToFile (_, h) = hPutStrLn h "message"

265+--

266+-- In addition to the resource, the handler will also receive a 'ReleaseKey'

267+-- which can be used to deallocate the resource before the end of the request

268+-- if desired.

269+

270+instance (HasServer api ctx, HasContextEntry ctx (Acquire a))

271+ => HasServer (WithResource a :> api) ctx where

272+

273+ type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m

274+

275+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s

276+

277+ route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)

278+ where

279+ allocateResource :: DelayedIO (ReleaseKey, a)

280+ allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)

281+

282+

283+

247allowedMethodHead :: Method -> Request -> Bool

284allowedMethodHead :: Method -> Request -> Bool

248allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

285allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

249

286

servant-server/test/Servant/ServerSpec.hs+7−2

@@ -21,6 +21,8 @@ import Control.Monad.Error.Class

21 (MonadError (..))

22import Data.Aeson

23 (FromJSON, ToJSON, decode', encode)

24+import Data.Acquire

25+ (Acquire, mkAcquire)

24import qualified Data.ByteString as BS

26import qualified Data.ByteString as BS

25import qualified Data.ByteString.Base64 as Base64

27import qualified Data.ByteString.Base64 as Base64

26import Data.Char

28import Data.Char

@@ -81,8 +83,11 @@ import Servant.Server.Internal.Context

81-- This declaration simply checks that all instances are in place.

83-- This declaration simply checks that all instances are in place.

82_ = serveWithContext comprehensiveAPI comprehensiveApiContext

84_ = serveWithContext comprehensiveAPI comprehensiveApiContext

83

85

84−comprehensiveApiContext :: Context '[NamedContext "foo" '[]]

86+comprehensiveApiContext :: Context '[NamedContext "foo" '[], Acquire Int]

87+comprehensiveApiContext =

85−comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext

88+ NamedContext EmptyContext :.

89+ mkAcquire (pure 10) (\_ -> pure ()) :.

90+ EmptyContext

86

91

87-- * Specs

92-- * Specs

88

93

servant-swagger/src/Servant/Swagger/Internal.hs+4

@@ -304,6 +304,10 @@ instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where

304instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where

305 toSwagger _ = toSwagger (Proxy :: Proxy sub)

306

307+-- | @'WithResource'@ combinator does not change our specification at all.

308+instance (HasSwagger sub) => HasSwagger (WithResource res :> sub) where

309+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

310+

307instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where

311instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where

308 toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))

312 toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))

309 where

313 where

servant/servant.cabal+1

@@ -62,6 +62,7 @@ library

62 Servant.API.Vault

63 Servant.API.Verbs

64 Servant.API.WithNamedContext

65+ Servant.API.WithResource

65

66

66 -- Types

67 -- Types

67 exposed-modules:

68 exposed-modules:

servant/src/Servant/API.hs+9−5

@@ -31,6 +31,8 @@ module Servant.API (

31 -- | Access the location for arbitrary data to be shared by applications and middleware

32 module Servant.API.WithNamedContext,

33 -- | Access context entries in combinators in servant-server

34+ module Servant.API.WithResource,

35+ -- | Access a managed resource scoped to a single request

34

36

35 -- * Actual endpoints, distinguished by HTTP method

37 -- * Actual endpoints, distinguished by HTTP method

36 module Servant.API.Verbs,

38 module Servant.API.Verbs,

@@ -101,17 +103,19 @@ import Servant.API.Experimental.Auth

101 (AuthProtect)

103 (AuthProtect)

102import Servant.API.Fragment

104import Servant.API.Fragment

103 (Fragment)

105 (Fragment)

106+import Servant.API.Generic

107+ (AsApi, GServantProduct, GenericMode ((:-)), GenericServant,

108+ ToServant, ToServantApi, fromServant, genericApi, toServant)

104import Servant.API.Header

109import Servant.API.Header

105 (Header, Header')

110 (Header, Header')

106−import Servant.API.Generic

107− (GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct,

108− GenericServant, fromServant, toServant, genericApi)

109import Servant.API.HttpVersion

111import Servant.API.HttpVersion

110 (HttpVersion (..))

112 (HttpVersion (..))

111import Servant.API.IsSecure

113import Servant.API.IsSecure

112 (IsSecure (..))

114 (IsSecure (..))

113import Servant.API.Modifiers

115import Servant.API.Modifiers

114 (Lenient, Optional, Required, Strict)

116 (Lenient, Optional, Required, Strict)

117+import Servant.API.NamedRoutes

118+ (NamedRoutes)

115import Servant.API.QueryParam

119import Servant.API.QueryParam

116 (QueryFlag, QueryParam, QueryParam', QueryParams)

120 (QueryFlag, QueryParam, QueryParam', QueryParams)

117import Servant.API.Raw

121import Servant.API.Raw

@@ -137,8 +141,6 @@ import Servant.API.UVerb

137 Unique, WithStatus (..), inject, statusOf)

141 Unique, WithStatus (..), inject, statusOf)

138import Servant.API.Vault

142import Servant.API.Vault

139 (Vault)

143 (Vault)

140−import Servant.API.NamedRoutes

141− (NamedRoutes)

142import Servant.API.Verbs

144import Servant.API.Verbs

143 (Delete, DeleteAccepted, DeleteNoContent,

145 (Delete, DeleteAccepted, DeleteNoContent,

144 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

146 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

@@ -150,6 +152,8 @@ import Servant.API.Verbs

150 ReflectMethod (reflectMethod), StdMethod (..), Verb)

152 ReflectMethod (reflectMethod), StdMethod (..), Verb)

151import Servant.API.WithNamedContext

153import Servant.API.WithNamedContext

152 (WithNamedContext)

154 (WithNamedContext)

155+import Servant.API.WithResource

156+ (WithResource)

153import Servant.Links

157import Servant.Links

154 (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)

158 (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)

155import Web.HttpApiData

159import Web.HttpApiData

servant/src/Servant/API/WithResource.hsnew file+3

@@ -0,0 +1,3 @@

1+module Servant.API.WithResource (WithResource) where

2+

3+data WithResource res

servant/src/Servant/Links.hs+6

@@ -193,6 +193,8 @@ import Servant.API.Verbs

193 (Verb, NoContentVerb)

194import Servant.API.WithNamedContext

195 (WithNamedContext)

196+import Servant.API.WithResource

197+ (WithResource)

196import Web.HttpApiData

198import Web.HttpApiData

197import Data.Kind

199import Data.Kind

198 (Type)

200 (Type)

@@ -558,6 +560,10 @@ instance HasLink sub => HasLink (WithNamedContext name context sub) where

558 type MkLink (WithNamedContext name context sub) a = MkLink sub a

560 type MkLink (WithNamedContext name context sub) a = MkLink sub a

559 toLink toA _ = toLink toA (Proxy :: Proxy sub)

561 toLink toA _ = toLink toA (Proxy :: Proxy sub)

560

562

563+instance HasLink sub => HasLink (WithResource res :> sub) where

564+ type MkLink (WithResource res :> sub) a = MkLink sub a

565+ toLink toA _ = toLink toA (Proxy :: Proxy sub)

566+

561instance HasLink sub => HasLink (RemoteHost :> sub) where

567instance HasLink sub => HasLink (RemoteHost :> sub) where

562 type MkLink (RemoteHost :> sub) a = MkLink sub a

568 type MkLink (RemoteHost :> sub) a = MkLink sub a

563 toLink = simpleToLink (Proxy :: Proxy sub)

569 toLink = simpleToLink (Proxy :: Proxy sub)

servant/src/Servant/Test/ComprehensiveAPI.hs+1

@@ -72,6 +72,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =

72 :<|> "description" :> Description "foo" :> GET

73 :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)

74 :<|> "fragment" :> Fragment Int :> GET

75+ :<|> "resource" :> WithResource Int :> GET

75 :<|> endpoint

76 :<|> endpoint

76

77

77type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint

78type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint