c19ed0f..master · servant

.github/workflows/master.yml+35−34

since splitsnapshots

unifiedsplit

@@ -20,6 +20,7 @@ jobs:

20 - "8.10.7"

21 - "9.0.2"

22 - "9.2.2"

23+ - "9.4.2"

23

24

24 steps:

25 steps:

25 - uses: actions/checkout@v2

26 - uses: actions/checkout@v2

@@ -75,40 +76,40 @@ jobs:

75 (cd servant-conduit && eval $DOCTEST)

76 (cd servant-conduit && eval $DOCTEST)

76 (cd servant-pipes && eval $DOCTEST)

77 (cd servant-pipes && eval $DOCTEST)

77

78

78− stack:

79+ # stack:

79− name: stack / ghc ${{ matrix.ghc }}

80+ # name: stack / ghc ${{ matrix.ghc }}

80− runs-on: ubuntu-latest

81+ # runs-on: ubuntu-latest

81− strategy:

82+ # strategy:

82− matrix:

83+ # matrix:

83− stack: ["2.7.5"]

84+ # stack: ["2.7.5"]

84− ghc: ["8.10.7"]

85+ # ghc: ["8.10.7"]

85−

86+

86− steps:

87+ # steps:

87− - uses: actions/checkout@v2

88+ # - uses: actions/checkout@v2

88−

89+

89− - uses: haskell/actions/setup@v1

90+ # - uses: haskell/actions/setup@v1

90− name: Setup Haskell Stack

91+ # name: Setup Haskell Stack

91− with:

92+ # with:

92− ghc-version: ${{ matrix.ghc }}

93+ # ghc-version: ${{ matrix.ghc }}

93− stack-version: ${{ matrix.stack }}

94+ # stack-version: ${{ matrix.stack }}

94−

95+

95− - uses: actions/cache@v2.1.3

96+ # - uses: actions/cache@v2.1.3

96− name: Cache ~/.stack

97+ # name: Cache ~/.stack

97− with:

98+ # with:

98− path: ~/.stack

99+ # path: ~/.stack

99− key: ${{ runner.os }}-${{ matrix.ghc }}-stack

100+ # key: ${{ runner.os }}-${{ matrix.ghc }}-stack

100−

101+

101− - name: Install dependencies

102+ # - name: Install dependencies

102− run: |

103+ # run: |

103− stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies

104+ # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies

104−

105+

105− - name: Build

106+ # - name: Build

106− run: |

107+ # run: |

107− stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks

108+ # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks

108−

109+

109− - name: Test

110+ # - name: Test

110− run: |

111+ # run: |

111− stack test --system-ghc

112+ # stack test --system-ghc

112

113

113 ghcjs:

114 ghcjs:

114 name: ubuntu-latest / ghcjs 8.6

115 name: ubuntu-latest / ghcjs 8.6

cabal.project+1

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

changelog.d/1571new file+10

@@ -0,0 +1,10 @@

1+synopsis: Support UVerb in servant-auth-server

2+prs: #1571

3+issues: #1570

4+description: {

5+UVerb endpoints are now supported by servant-auth-server and can be used under the

6+Auth combinator when writing servers. It is still unsupported by

7+servant-auth-client.

8+

9+This PR also brings Headers support in UVerb responses

10+}

changelog.d/1573new file+2

@@ -0,0 +1,2 @@

1+synopsis: Add API docs for ServerT

2+prs: #1573

changelog.d/1580new file+12

@@ -0,0 +1,12 @@

1+synopsis: Allow IO in validationKeys

2+prs: #1580

3+issues: #1579

4+

5+description: {

6+

7+Currently validationKeys are a fixed JWKSet. This does not work with OIDC

8+providers such as AWS Cognito or Okta, which regularly fetching jwks_uri to

9+discover new and expired keys.

10+

11+This change alters the type of validationKeys from JWKSet to IO JWKSet.

12+}

changelog.d/1589new file+2

@@ -0,0 +1,2 @@

1+synopsis: Only include question mark for nonempty query strings

2+prs: 1589

changelog.d/1595new file+2

@@ -0,0 +1,2 @@

1+synopsis: Run ClientEnv's makeClientRequest in IO.

2+prs: #1595

changelog.d/1606new file+10

@@ -0,0 +1,10 @@

1+synopsis: Handle Cookies correctly for RunStreamingClient

2+prs: #1606

3+issues: #1605

4+

5+description: {

6+

7+Makes performWithStreamingRequest take into consideration the

8+CookieJar, which it previously didn't.

9+

10+}

changelog.d/1638new file+2

@@ -0,0 +1,2 @@

1+synopsis: Add Functor instance to AuthHandler.

2+prs: #1638

changelog.d/1649new file+8

@@ -0,0 +1,8 @@

1+synopsis: Add HasStatus instance for Headers (that defers StatusOf to underlying value)

2+prs: #1649

3+

4+description: {

5+

6+Adds a new HasStatus (Headers hs a) instance (StatusOf (Headers hs a) = StatusOf a)

7+

8+}

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/cookbook/open-id-connect/OpenIdConnect.lhs+1−1

@@ -330,7 +330,7 @@ data Customer = Customer {

330```

331

332Here is the code that displays the homepage.

333−It should contain a link to the the `/login` URL.

333+It should contain a link to the `/login` URL.

334When the user clicks on this link it will be redirected to Google login page

335with some generated information.

336

doc/cookbook/using-free-client/UsingFreeClient.lhs+1−1

@@ -119,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`

119to http-client's `Request`, and we can inspect it:

120

121```haskell

122− let req' = I.defaultMakeClientRequest burl req

122+ req' <- I.defaultMakeClientRequest burl req

123 putStrLn $ "Making request: " ++ show req'

124```

125

doc/cookbook/uverb/UVerb.lhs+1−1

@@ -199,7 +199,7 @@ parsers in the hope that the ones that should will always error out so

199you can try until the right one returns a value.)

200

201[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is

202−another shot at at the problem. It is inspired by

202+another shot at the problem. It is inspired by

203servant-checked-exceptions, so it may be worth taking a closer look.

204The README claims that

205[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has

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-auth/servant-auth-client/servant-auth-client.cabal+2−2

@@ -31,7 +31,7 @@ library

31 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

32 ghc-options: -Wall

33 build-depends:

34− base >= 4.10 && < 4.17

34+ base >= 4.10 && < 4.18

35 , bytestring >= 0.10.6.0 && < 0.12

36 , containers >= 0.5.6.2 && < 0.7

37 , servant-auth == 0.4.*

@@ -74,7 +74,7 @@ test-suite spec

74 , transformers >= 0.4.2.0 && < 0.6

75 , wai >= 3.2.1.2 && < 3.3

76 , warp >= 3.2.25 && < 3.4

77− , jose >= 0.7.0.0 && < 0.10

77+ , jose >= 0.10 && < 0.11

78 other-modules:

79 Servant.Auth.ClientSpec

80 default-language: Haskell2010

servant-auth/servant-auth-docs/servant-auth-docs.cabal+3−3

@@ -35,11 +35,11 @@ library

35 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

36 ghc-options: -Wall

37 build-depends:

38− base >= 4.10 && < 4.17

38+ base >= 4.10 && < 4.18

39 , servant-docs >= 0.11.2 && < 0.13

40 , servant >= 0.13 && < 0.20

41 , servant-auth == 0.4.*

42− , lens >= 4.16.1 && <5.2

42+ , lens >= 4.16.1 && <5.3

43 exposed-modules:

44 Servant.Auth.Docs

45 default-language: Haskell2010

@@ -50,7 +50,7 @@ test-suite doctests

50 build-depends:

51 base,

52 servant-auth-docs,

53− doctest >= 0.16 && < 0.19,

53+ doctest >= 0.16 && < 0.21,

54 QuickCheck >= 2.11.3 && < 2.15,

55 template-haskell

56 ghc-options: -Wall -threaded

servant-auth/servant-auth-server/servant-auth-server.cabal+7−6

@@ -31,7 +31,7 @@ library

31 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

32 ghc-options: -Wall

33 build-depends:

34− base >= 4.10 && < 4.17

34+ base >= 4.10 && < 4.18

35 , aeson >= 1.0.0.1 && < 3

36 , base64-bytestring >= 1.0.0.1 && < 2

37 , blaze-builder >= 0.4.1.0 && < 0.5

@@ -41,17 +41,17 @@ library

41 , data-default-class >= 0.1.2.0 && < 0.2

42 , entropy >= 0.4.1.3 && < 0.5

43 , http-types >= 0.12.2 && < 0.13

44− , jose >= 0.7.0.0 && < 0.10

44+ , jose >= 0.10 && < 0.11

45− , lens >= 4.16.1 && < 5.2

45+ , lens >= 4.16.1 && < 5.3

46− , memory >= 0.14.16 && < 0.18

46+ , memory >= 0.14.16 && < 0.19

47 , monad-time >= 0.3.1.0 && < 0.4

48− , mtl >= 2.2.2 && < 2.3

48+ , mtl ^>= 2.2.2 || ^>= 2.3.1

49 , servant >= 0.13 && < 0.20

50 , servant-auth == 0.4.*

51 , servant-server >= 0.13 && < 0.20

52 , tagged >= 0.8.4 && < 0.9

53 , text >= 1.2.3.0 && < 2.1

54− , time >= 1.5.0.1 && < 1.12

54+ , time >= 1.5.0.1 && < 1.13

55 , unordered-containers >= 0.2.9.0 && < 0.3

56 , wai >= 3.2.1.2 && < 3.3

57

@@ -129,6 +129,7 @@ test-suite spec

129 , lens-aeson >= 1.0.2 && < 1.3

130 , warp >= 3.2.25 && < 3.4

131 , wreq >= 0.5.2.1 && < 0.6

132+ , text >= 1.2.3.0 && < 2.1

132 other-modules:

133 other-modules:

133 Servant.Auth.ServerSpec

134 Servant.Auth.ServerSpec

134 default-language: Haskell2010

135 default-language: Haskell2010

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs+6−9

@@ -54,15 +54,12 @@ instance ( n ~ 'S ('S 'Z)

54

55 makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))

56 makeCookies authResult = do

57− xsrf <- makeXsrfCookie cookieSettings

58− fmap (Just xsrf `SetCookieCons`) $

59− case authResult of

57+ case authResult of

60− (Authenticated v) -> do

58+ (Authenticated v) -> do

61− ejwt <- makeSessionCookie cookieSettings jwtSettings v

59+ ejwt <- makeSessionCookie cookieSettings jwtSettings v

62− case ejwt of

60+ xsrf <- makeXsrfCookie cookieSettings

63− Nothing -> return $ Nothing `SetCookieCons` SetCookieNil

64− Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil

61+ return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)

65− _ -> return $ Nothing `SetCookieCons` SetCookieNil

62+ _ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)

66

63

67 go :: (AuthResult v -> ServerT api Handler)

64 go :: (AuthResult v -> ServerT api Handler)

68 -> (AuthResult v, SetCookieList n)

65 -> (AuthResult v, SetCookieList n)

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs+14−1

@@ -11,6 +11,7 @@ import Data.Tagged (Tagged (..))

11import qualified Network.HTTP.Types as HTTP

12import Network.Wai (mapResponseHeaders)

13import Servant

14+import Servant.API.UVerb.Union

14import Servant.API.Generic

15import Servant.API.Generic

15import Servant.Server.Generic

16import Servant.Server.Generic

16import Web.Cookie

17import Web.Cookie

@@ -33,12 +34,24 @@ type family AddSetCookieApiVerb a where

33 AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a

34 AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a

34 AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a

35 AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a

35

36

37+#if MIN_VERSION_servant_server(0,18,1)

38+type family MapAddSetCookieApiVerb (as :: [*]) where

39+ MapAddSetCookieApiVerb '[] = '[]

40+ MapAddSetCookieApiVerb (a ': as) = (AddSetCookieApiVerb a ': MapAddSetCookieApiVerb as)

41+#endif

42+

36type family AddSetCookieApi a :: *

43type family AddSetCookieApi a :: *

37type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b

44type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b

38type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b

45type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b

46+#if MIN_VERSION_servant_server(0,19,0)

39type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)

47type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)

48+#endif

40type instance AddSetCookieApi (Verb method stat ctyps a)

49type instance AddSetCookieApi (Verb method stat ctyps a)

41 = Verb method stat ctyps (AddSetCookieApiVerb a)

50 = Verb method stat ctyps (AddSetCookieApiVerb a)

51+#if MIN_VERSION_servant_server(0,18,1)

52+type instance AddSetCookieApi (UVerb method ctyps as)

53+ = UVerb method ctyps (MapAddSetCookieApiVerb as)

54+#endif

42type instance AddSetCookieApi Raw = Raw

55type instance AddSetCookieApi Raw = Raw

43#if MIN_VERSION_servant_server(0,15,0)

56#if MIN_VERSION_servant_server(0,15,0)

44type instance AddSetCookieApi (Stream method stat framing ctyps a)

57type instance AddSetCookieApi (Stream method stat framing ctyps a)

@@ -57,7 +70,7 @@ instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb

57 => AddSetCookies ('S n) (a -> oldb) (a -> newb) where

70 => AddSetCookies ('S n) (a -> oldb) (a -> newb) where

58 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

71 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

59

72

60−instance AddSetCookies 'Z orig orig where

73+instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where

61 addSetCookies _ = id

74 addSetCookies _ = id

62

75

63instance {-# OVERLAPPABLE #-}

76instance {-# OVERLAPPABLE #-}

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs+2−2

@@ -33,7 +33,7 @@ data JWTSettings = JWTSettings

33 -- | Algorithm used to sign JWT.

34 , jwtAlg :: Maybe Jose.Alg

35 -- | Keys used to validate JWT.

36− , validationKeys :: Jose.JWKSet

36+ , validationKeys :: IO Jose.JWKSet

37 -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the

38 -- intended recipient of the JWT.

39 , audienceMatches :: Jose.StringOrURI -> IsMatch

@@ -44,7 +44,7 @@ defaultJWTSettings :: Jose.JWK -> JWTSettings

44defaultJWTSettings k = JWTSettings

45 { signingKey = k

46 , jwtAlg = Nothing

47− , validationKeys = Jose.JWKSet [k]

47+ , validationKeys = pure $ Jose.JWKSet [k]

48 , audienceMatches = const Matches }

49

50-- | The policies to use when generating cookies.

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs+1

@@ -2,6 +2,7 @@

2module Servant.Auth.Server.Internal.Cookie where

3

4import Blaze.ByteString.Builder (toByteString)

5+import Control.Monad (MonadPlus(..), guard)

5import Control.Monad.Except

6import Control.Monad.Except

6import Control.Monad.Reader

7import Control.Monad.Reader

7import qualified Crypto.JOSE as Jose

8import qualified Crypto.JOSE as Jose

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs+6−9

@@ -1,18 +1,14 @@

1module Servant.Auth.Server.Internal.JWT where

2

3import Control.Lens

4−import Control.Monad.Except

4+import Control.Monad (MonadPlus(..), guard)

5import Control.Monad.Reader

6import qualified Crypto.JOSE as Jose

7import qualified Crypto.JWT as Jose

8−import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,

9− toJSON)

10import Data.ByteArray (constEq)

8import Data.ByteArray (constEq)

11import qualified Data.ByteString as BS

9import qualified Data.ByteString as BS

12import qualified Data.ByteString.Lazy as BSL

10import qualified Data.ByteString.Lazy as BSL

13−import qualified Data.HashMap.Strict as HM

14import Data.Maybe (fromMaybe)

11import Data.Maybe (fromMaybe)

15−import qualified Data.Text as T

16import Data.Time (UTCTime)

12import Data.Time (UTCTime)

17import Network.Wai (requestHeaders)

13import Network.Wai (requestHeaders)

18

14

@@ -42,7 +38,7 @@ jwtAuthCheck jwtSettings = do

42-- token expires.

38-- token expires.

43makeJWT :: ToJWT a

39makeJWT :: ToJWT a

44 => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)

40 => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)

45−makeJWT v cfg expiry = runExceptT $ do

41+makeJWT v cfg expiry = Jose.runJOSE $ do

46 bestAlg <- Jose.bestJWSAlg $ signingKey cfg

42 bestAlg <- Jose.bestJWSAlg $ signingKey cfg

47 let alg = fromMaybe bestAlg $ jwtAlg cfg

43 let alg = fromMaybe bestAlg $ jwtAlg cfg

48 ejwt <- Jose.signClaims (signingKey cfg)

44 ejwt <- Jose.signClaims (signingKey cfg)

@@ -58,14 +54,15 @@ makeJWT v cfg expiry = runExceptT $ do

58

54

59verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)

55verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)

60verifyJWT jwtCfg input = do

56verifyJWT jwtCfg input = do

57+ keys <- validationKeys jwtCfg

61− verifiedJWT <- liftIO $ runExceptT $ do

58+ verifiedJWT <- Jose.runJOSE $ do

62 unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)

59 unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)

63 Jose.verifyClaims

60 Jose.verifyClaims

64 (jwtSettingsToJwtValidationSettings jwtCfg)

61 (jwtSettingsToJwtValidationSettings jwtCfg)

65− (validationKeys jwtCfg)

62+ keys

66 unverifiedJWT

63 unverifiedJWT

67 return $ case verifiedJWT of

64 return $ case verifiedJWT of

68 Left (_ :: Jose.JWTError) -> Nothing

65 Left (_ :: Jose.JWTError) -> Nothing

69 Right v -> case decodeJWT v of

66 Right v -> case decodeJWT v of

70 Left _ -> Nothing

67 Left _ -> Nothing

71− Right v' -> Just v'

68+ Right v' -> Just v'

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs+1

@@ -2,6 +2,7 @@

2module Servant.Auth.Server.Internal.Types where

3

4import Control.Applicative

5+import Control.Monad (MonadPlus(..), ap)

5import Control.Monad.Reader

6import Control.Monad.Reader

6import Control.Monad.Time

7import Control.Monad.Time

7import Data.Monoid (Monoid (..))

8import Data.Monoid (Monoid (..))

servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs+33−6

@@ -1,4 +1,5 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE TypeApplications #-}

2module Servant.Auth.ServerSpec (spec) where

3module Servant.Auth.ServerSpec (spec) where

3

4

4#if !MIN_VERSION_servant_server(0,16,0)

5#if !MIN_VERSION_servant_server(0,16,0)

@@ -6,13 +7,12 @@ module Servant.Auth.ServerSpec (spec) where

6#endif

7#endif

7

8

8import Control.Lens

9import Control.Lens

9−import Control.Monad.Except (runExceptT)

10import Control.Monad.IO.Class (liftIO)

11import Crypto.JOSE (Alg (HS256, None), Error,

12 JWK, JWSHeader,

13 KeyMaterialGenParam (OctGenParam),

14 ToCompact, encodeCompact,

15− genJWK, newJWSHeader)

15+ genJWK, newJWSHeader, runJOSE)

16import Crypto.JWT (Audience (..), ClaimsSet,

17 NumericDate (NumericDate),

18 SignedJWT,

@@ -25,6 +25,7 @@ import Data.Aeson (FromJSON, ToJSON, Value,

25import Data.Aeson.Lens (_JSON)

26import qualified Data.ByteString as BS

27import qualified Data.ByteString.Lazy as BSL

28+import Data.Text (Text, pack)

28import Data.CaseInsensitive (mk)

29import Data.CaseInsensitive (mk)

29import Data.Foldable (find)

30import Data.Foldable (find)

30import Data.Monoid

31import Data.Monoid

@@ -40,6 +41,7 @@ import Network.HTTP.Types (Status, status200,

40import Network.Wai (responseLBS)

41import Network.Wai (responseLBS)

41import Network.Wai.Handler.Warp (testWithApplication)

42import Network.Wai.Handler.Warp (testWithApplication)

42import Network.Wreq (Options, auth, basicAuth,

43import Network.Wreq (Options, auth, basicAuth,

44+ checkResponse,

43 cookieExpiryTime, cookies,

45 cookieExpiryTime, cookies,

44 defaults, get, getWith, postWith,

46 defaults, get, getWith, postWith,

45 header, oauth2Bearer,

47 header, oauth2Bearer,

@@ -183,8 +185,21 @@ cookieAuthSpec

183 it "fails with no XSRF header or cookie" $ \port -> property

185 it "fails with no XSRF header or cookie" $ \port -> property

184 $ \(user :: User) -> do

186 $ \(user :: User) -> do

185 jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

187 jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

186− opts <- addJwtToCookie cookieCfg jwt

188+ opts' <- addJwtToCookie cookieCfg jwt

189+ let opts = opts' & checkResponse .~ Just mempty

187− getWith opts (url port) `shouldHTTPErrorWith` status401

190+ resp <- getWith opts (url port)

191+ resp ^. responseStatus `shouldBe` status401

192+ (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]

193+

194+ -- Validating that the XSRF cookie isn't added for UVerb routes either.

195+ -- These routes can return a 401 response directly without using throwError / throwAll,

196+ -- which revealed a bug:

197+ --

198+ -- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449

199+ resp <- getWith opts (url port ++ "/uverb")

200+ resp ^. responseStatus `shouldBe` status401

201+ (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]

202+

188

203

189 it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property

204 it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property

190 $ \(user :: User) -> do

205 $ \(user :: User) -> do

@@ -406,13 +421,14 @@ type API auths

406 = Auth auths User :>

421 = Auth auths User :>

407 ( Get '[JSON] Int

422 ( Get '[JSON] Int

408 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

423 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

409− :<|> NamedRoutes DummyRoutes

424+ :<|> "named" :> NamedRoutes DummyRoutes

410 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)

425 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)

411#if MIN_VERSION_servant_server(0,15,0)

426#if MIN_VERSION_servant_server(0,15,0)

412 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

427 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

413#endif

428#endif

414 :<|> "raw" :> Raw

429 :<|> "raw" :> Raw

415 )

430 )

431+ :<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]

416 :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

432 :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

417 , Header "Set-Cookie" SetCookie ] NoContent)

433 , Header "Set-Cookie" SetCookie ] NoContent)

418 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

434 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

@@ -490,6 +506,11 @@ server ccfg =

490 :<|> raw

506 :<|> raw

491 Indefinite -> throwAll err401

507 Indefinite -> throwAll err401

492 _ -> throwAll err403

508 _ -> throwAll err403

509+ ) :<|>

510+ (\authResult -> case authResult of

511+ Authenticated usr -> respond (WithStatus @200 (42 :: Int))

512+ Indefinite -> respond (WithStatus @401 $ pack "Authentication required")

513+ _ -> respond (WithStatus @403 $ pack "Forbidden")

493 )

514 )

494 :<|> getLogin

515 :<|> getLogin

495 :<|> getLogout

516 :<|> getLogout

@@ -540,7 +561,7 @@ addJwtToHeader jwt = case jwt of

540 $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]

561 $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]

541

562

542createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)

563createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)

543−createJWT k a b = runExceptT $ signClaims k a b

564+createJWT k a b = runJOSE $ signClaims k a b

544

565

545addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options

566addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options

546addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of

567addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of

@@ -570,6 +591,12 @@ shouldMatchCookieNames cj patterns

570 = fmap cookie_name (destroyCookieJar cj)

591 = fmap cookie_name (destroyCookieJar cj)

571 `shouldMatchList` patterns

592 `shouldMatchList` patterns

572

593

594+shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation

595+shouldNotHaveCookies cj patterns =

596+ sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns

597+ where cookieNames :: [BS.ByteString]

598+ cookieNames = cookie_name <$> destroyCookieJar cj

599+

573shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation

600shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation

574shouldMatchCookieNameValues cj patterns

601shouldMatchCookieNameValues cj patterns

575 = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)

602 = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)

servant-auth/servant-auth-swagger/servant-auth-swagger.cabal+2−6

@@ -31,15 +31,13 @@ library

31 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

32 ghc-options: -Wall

33 build-depends:

34− base >= 4.10 && < 4.16

34+ base >= 4.10 && < 4.18

35 , text >= 1.2.3.0 && < 2.1

36 , servant-swagger >= 1.1.5 && < 2

37 , swagger2 >= 2.2.2 && < 3

38 , servant >= 0.13 && < 0.20

39 , servant-auth == 0.4.*

40− , lens >= 4.16.1 && < 5.2

40+ , lens >= 4.16.1 && < 5.3

41− if impl(ghc >= 9)

42− buildable: False

43 exposed-modules:

41 exposed-modules:

44 Servant.Auth.Swagger

42 Servant.Auth.Swagger

45 default-language: Haskell2010

43 default-language: Haskell2010

@@ -61,8 +59,6 @@ test-suite spec

61 , servant

59 , servant

62 , servant-auth

60 , servant-auth

63 , lens

61 , lens

64− if impl(ghc >= 9)

65− buildable: False

66

62

67 -- test dependencies

63 -- test dependencies

68 build-depends:

64 build-depends:

servant-auth/servant-auth/servant-auth.cabal+3−3

@@ -33,11 +33,11 @@ library

33 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

34 ghc-options: -Wall

35 build-depends:

36− base >= 4.10 && < 4.17

36+ base >= 4.10 && < 4.18

37 , containers >= 0.6 && < 0.7

38 , aeson >= 1.3.1.1 && < 3

39− , jose >= 0.7.0.0 && < 0.10

39+ , jose >= 0.10 && < 0.11

40− , lens >= 4.16.1 && < 5.2

40+ , lens >= 4.16.1 && < 5.3

41 , servant >= 0.15 && < 0.20

42 , text >= 1.2.3.0 && < 2.1

43 , unordered-containers >= 0.2.9.0 && < 0.3

servant-auth/servant-auth/src/Servant/Auth.hs+1−1

@@ -27,7 +27,7 @@ instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where

27

28-- ** Combinators

29

30−-- | A JSON Web Token (JWT) in the the Authorization header:

30+-- | A JSON Web Token (JWT) in the Authorization header:

31--

32-- @Authorization: Bearer \<token\>@

33--

servant-client-core/servant-client-core.cabal+3−3

@@ -50,14 +50,14 @@ library

50 --

51 -- note: mtl lower bound is so low because of GHC-7.8

52 build-depends:

53− base >= 4.9 && < 4.17

53+ base >= 4.9 && < 4.18

54 , bytestring >= 0.10.8.1 && < 0.12

55 , constraints >= 0.2 && < 0.14

56 , containers >= 0.5.7.1 && < 0.7

57 , deepseq >= 1.4.2.0 && < 1.5

58 , text >= 1.2.3.0 && < 2.1

59− , transformers >= 0.5.2.0 && < 0.6

59+ , transformers >= 0.5.2.0 && < 0.7

60− , template-haskell >= 2.11.1.0 && < 2.19

60+ , template-haskell >= 2.11.1.0 && < 2.20

61

62 if !impl(ghc >= 8.2)

63 build-depends:

servant-client-core/src/Servant/Client/Core/HasClient.hs+23−5

@@ -74,10 +74,10 @@ import Servant.API

74 FromSourceIO (..), Header', Headers (..), HttpVersion,

75 IsSecure, MimeRender (mimeRender),

76 MimeUnrender (mimeUnrender), NoContent (NoContent),

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

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

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

@@ -674,6 +674,16 @@ instance RunClient m => HasClient m Raw where

674

675 hoistClientMonad _ _ f cl = \meth -> f (cl meth)

676

677+instance RunClient m => HasClient m RawM where

678+ type Client m RawM

679+ = H.Method -> m Response

680+

681+ clientWithRoute :: Proxy m -> Proxy RawM -> Request -> Client m RawM

682+ clientWithRoute _pm Proxy req httpMethod = do

683+ runRequest req { requestMethod = httpMethod }

684+

685+ hoistClientMonad _ _ f cl = \meth -> f (cl meth)

686+

677-- | If you use a 'ReqBody' in one of your endpoints in your API,

687-- | If you use a 'ReqBody' in one of your endpoints in your API,

678-- the corresponding querying function will automatically take

688-- the corresponding querying function will automatically take

679-- an additional argument of the type specified by your 'ReqBody'.

689-- an additional argument of the type specified by your 'ReqBody'.

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

776

786

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

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

778

788

789+instance HasClient m subapi =>

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

791+

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

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

794+

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

796+

779instance ( HasClient m api

797instance ( HasClient m api

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

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

781 type Client m (AuthProtect tag :> api)

799 type Client m (AuthProtect tag :> api)

@@ -894,7 +912,7 @@ infixl 2 /:

894-- rootClient = client api

912-- rootClient = client api

895--

913--

896-- endpointClient :: ClientM Person

914-- endpointClient :: ClientM Person

897−-- endpointClient = client // subApi // endpoint

915+-- endpointClient = client \/\/ subApi \/\/ endpoint

898-- @

916-- @

899(//) :: a -> (a -> b) -> b

917(//) :: a -> (a -> b) -> b

900x // f = f x

918x // f = f x

@@ -927,10 +945,10 @@ x // f = f x

927-- rootClient = client api

945-- rootClient = client api

928--

946--

929-- hello :: String -> ClientM String

947-- hello :: String -> ClientM String

930−-- hello name = rootClient // hello /: name

948+-- hello name = rootClient \/\/ hello \/: name

931--

949--

932-- endpointClient :: ClientM Person

950-- endpointClient :: ClientM Person

933−-- endpointClient = client // subApi /: "foobar123" // endpoint

951+-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint

934-- @

952-- @

935(/:) :: (a -> b -> c) -> b -> a -> c

953(/:) :: (a -> b -> c) -> b -> a -> c

936(/:) = flip

954(/:) = flip

servant-client-ghcjs/servant-client-ghcjs.cabal+1−1

@@ -48,7 +48,7 @@ library

48 , http-media >=0.6.2 && <0.9

49 , http-types >=0.12 && <0.13

50 , monad-control >=1.0.0.4 && <1.1

51− , mtl >=2.2.2 && <2.3

51+ , mtl ^>=2.2.2 || ^>=2.3.1

52 , semigroupoids >=5.3 && <5.4

53 , string-conversions >=0.3 && <0.5

54 , transformers >=0.3 && <0.6

servant-client/servant-client.cabal+4−4

@@ -41,15 +41,15 @@ library

41 -- Bundled with GHC: Lower bound to not force re-installs

42 -- text and mtl are bundled starting with GHC-8.4

43 build-depends:

44− base >= 4.9 && < 4.17

44+ base >= 4.9 && < 4.18

45 , bytestring >= 0.10.8.1 && < 0.12

46 , containers >= 0.5.7.1 && < 0.7

47 , deepseq >= 1.4.2.0 && < 1.5

48− , mtl >= 2.2.2 && < 2.3

48+ , mtl ^>= 2.2.2 || ^>= 2.3.1

49 , stm >= 2.4.5.1 && < 2.6

50 , text >= 1.2.3.0 && < 2.1

51− , time >= 1.6.0.1 && < 1.12

51+ , time >= 1.6.0.1 && < 1.13

52− , transformers >= 0.5.2.0 && < 0.6

52+ , transformers >= 0.5.2.0 && < 0.7

53

54 if !impl(ghc >= 8.2)

55 build-depends:

servant-client/src/Servant/Client/Internal/HttpClient.hs+6−5

@@ -80,7 +80,7 @@ data ClientEnv

80 { manager :: Client.Manager

81 , baseUrl :: BaseUrl

82 , cookieJar :: Maybe (TVar Client.CookieJar)

83− , makeClientRequest :: BaseUrl -> Request -> Client.Request

83+ , makeClientRequest :: BaseUrl -> Request -> IO Client.Request

84 -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'

85 -- Note that:

86 -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,

@@ -162,7 +162,7 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm

162performRequest :: Maybe [Status] -> Request -> ClientM Response

163performRequest acceptStatus req = do

164 ClientEnv m burl cookieJar' createClientRequest <- ask

165− let clientRequest = createClientRequest burl req

165+ clientRequest <- liftIO $ createClientRequest burl req

166 request <- case cookieJar' of

167 Nothing -> pure clientRequest

168 Just cj -> liftIO $ do

@@ -229,8 +229,8 @@ clientResponseToResponse f r = Response

229-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'

230-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'

231-- otherwise the body, headers and query string are derived from the @servant@ 'Request'

232−defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request

232+defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request

233−defaultMakeClientRequest burl r = Client.defaultRequest

233+defaultMakeClientRequest burl r = return Client.defaultRequest

234 { Client.method = requestMethod r

235 , Client.host = fromString $ baseUrlHost burl

236 , Client.port = baseUrlPort burl

@@ -289,7 +289,8 @@ defaultMakeClientRequest burl r = Client.defaultRequest

289 Https -> True

290

291 -- Query string builder which does not do any encoding

292+ buildQueryString [] = mempty

292− buildQueryString = ("?" <>) . foldl' addQueryParam mempty

293+ buildQueryString qps = "?" <> foldl' addQueryParam mempty qps

293

294

294 addQueryParam qs (k, v) =

295 addQueryParam qs (k, v) =

295 qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v

296 qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+18−6

@@ -24,7 +24,8 @@ import Control.DeepSeq

24 (NFData, force)

25import Control.Exception

26 (evaluate, throwIO)

27−import Control.Monad ()

27+import Control.Monad

28+ (unless)

28import Control.Monad.Base

29import Control.Monad.Base

29 (MonadBase (..))

30 (MonadBase (..))

30import Control.Monad.Codensity

31import Control.Monad.Codensity

@@ -140,7 +141,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response

140performRequest acceptStatus req = do

141performRequest acceptStatus req = do

141 -- TODO: should use Client.withResponse here too

142 -- TODO: should use Client.withResponse here too

142 ClientEnv m burl cookieJar' createClientRequest <- ask

143 ClientEnv m burl cookieJar' createClientRequest <- ask

143− let clientRequest = createClientRequest burl req

144+ clientRequest <- liftIO $ createClientRequest burl req

144 request <- case cookieJar' of

145 request <- case cookieJar' of

145 Nothing -> pure clientRequest

146 Nothing -> pure clientRequest

146 Just cj -> liftIO $ do

147 Just cj -> liftIO $ do

@@ -174,10 +175,21 @@ performRequest acceptStatus req = do

174-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).

175-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).

175performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a

176performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a

176performWithStreamingRequest req k = do

177performWithStreamingRequest req k = do

177− m <- asks manager

178+ ClientEnv m burl cookieJar' createClientRequest <- ask

178− burl <- asks baseUrl

179+ clientRequest <- liftIO $ createClientRequest burl req

179− createClientRequest <- asks makeClientRequest

180+ request <- case cookieJar' of

180− let request = createClientRequest burl req

181+ Nothing -> pure clientRequest

182+ Just cj -> liftIO $ do

183+ now <- getCurrentTime

184+ atomically $ do

185+ oldCookieJar <- readTVar cj

186+ let (newRequest, newCookieJar) =

187+ Client.insertCookiesIntoRequest

188+ clientRequest

189+ oldCookieJar

190+ now

191+ writeTVar cj newCookieJar

192+ pure newRequest

181 ClientM $ lift $ lift $ Codensity $ \k1 ->

193 ClientM $ lift $ lift $ Codensity $ \k1 ->

182 Client.withResponse request m $ \res -> do

194 Client.withResponse request m $ \res -> do

183 let status = Client.responseStatus res

195 let status = Client.responseStatus res

servant-client/test/Servant/SuccessSpec.hs+2−1

@@ -162,7 +162,8 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

162 mgr <- C.newManager C.defaultManagerSettings

163 -- In proper situation, extra headers should probably be visible in API type.

164 -- However, testing for response timeout is difficult, so we test with something which is easy to observe

165− let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }

165+ let createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })

166+ (defaultMakeClientRequest url r)

166 clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }

167 clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }

167 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv

168 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv

168 case res of

169 case res of

servant-conduit/servant-conduit.cabal+2−2

@@ -31,8 +31,8 @@ library

31 base >=4.9 && <5

32 , bytestring >=0.10.8.1 && <0.12

33 , conduit >=1.3.1 && <1.4

34− , mtl >=2.2.2 && <2.3

34+ , mtl ^>=2.2.2 || ^>=2.3.1

35− , resourcet >=1.2.2 && <1.3

35+ , resourcet >=1.2.2 && <1.4

36 , servant >=0.15 && <0.20

37 , unliftio-core >=0.1.2.0 && <0.3

38 hs-source-dirs: src

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/servant-docs.cabal+2−2

@@ -41,7 +41,7 @@ library

41 --

42 -- note: mtl lower bound is so low because of GHC-7.8

43 build-depends:

44− base >= 4.9 && < 4.17

44+ base >= 4.9 && < 4.18

45 , bytestring >= 0.10.8.1 && < 0.12

46 , text >= 1.2.3.0 && < 2.1

47

@@ -59,7 +59,7 @@ library

59 , hashable >= 1.2.7.0 && < 1.5

60 , http-media >= 0.7.1.3 && < 0.9

61 , http-types >= 0.12.2 && < 0.13

62− , lens >= 4.17 && < 5.2

62+ , lens >= 4.17 && < 5.3

63 , string-conversions >= 0.4.0.1 && < 0.5

64 , universe-base >= 1.1.1 && < 1.2

65 , unordered-containers >= 0.2.9.0 && < 0.3

servant-docs/src/Servant/Docs/Internal.hs+8−1

@@ -62,6 +62,7 @@ import GHC.TypeLits

62import Servant.API

63import Servant.API.ContentTypes

64import Servant.API.TypeLevel

65+import Servant.API.Generic

65

66

66import qualified Data.Universe.Helpers as U

67import qualified Data.Universe.Helpers as U

67

68

@@ -446,7 +447,7 @@ docsWith opts intros (ExtraInfo endpoints) p =

446 & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints

447 & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints

447

448

449

449−-- | Generate the docs for a given API that implements 'HasDocs' with with any

450+-- | Generate the docs for a given API that implements 'HasDocs' with any

450-- number of introduction(s)

451-- number of introduction(s)

451docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API

452docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API

452docsWithIntros intros = docsWith defaultDocOptions intros mempty

453docsWithIntros intros = docsWith defaultDocOptions intros mempty

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

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

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

1144 docsFor Proxy = docsFor (Proxy :: Proxy api)

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

1145

1146

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

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

1149+

1146instance (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

1147 docsFor Proxy (endpoint, action) =

1151 docsFor Proxy (endpoint, action) =

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

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

@@ -1150,6 +1154,9 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r

1150 authProxy = Proxy :: Proxy (BasicAuth realm usr)

1154 authProxy = Proxy :: Proxy (BasicAuth realm usr)

1151 action' = over authInfo (|> toAuthInfo authProxy) action

1155 action' = over authInfo (|> toAuthInfo authProxy) action

1152

1156

1157+instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where

1158+ docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))

1159+

1153-- ToSample instances for simple types

1160-- ToSample instances for simple types

1154instance ToSample NoContent

1161instance ToSample NoContent

1155instance ToSample Bool

1162instance ToSample Bool

servant-foreign/servant-foreign.cabal+2−2

@@ -41,7 +41,7 @@ library

41 --

42 -- note: mtl lower bound is so low because of GHC-7.8

43 build-depends:

44− base >= 4.9 && < 4.17

44+ base >= 4.9 && < 4.18

45 , text >= 1.2.3.0 && < 2.1

46

47 -- Servant dependencies

@@ -52,7 +52,7 @@ library

52 -- Here can be exceptions if we really need features from the newer versions.

53 build-depends:

54 base-compat >= 0.10.5 && < 0.13

55− , lens >= 4.17 && < 5.2

55+ , lens >= 4.17 && < 5.3

56 , http-types >= 0.12.2 && < 0.13

57

58 hs-source-dirs: src

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-http-streams/servant-http-streams.cabal+4−4

@@ -38,14 +38,14 @@ library

38 -- Bundled with GHC: Lower bound to not force re-installs

39 -- text and mtl are bundled starting with GHC-8.4

40 build-depends:

41− base >= 4.9 && < 4.17

41+ base >= 4.9 && < 4.18

42 , bytestring >= 0.10.8.1 && < 0.12

43 , containers >= 0.5.7.1 && < 0.7

44 , deepseq >= 1.4.2.0 && < 1.5

45− , mtl >= 2.2.2 && < 2.3

45+ , mtl ^>= 2.2.2 || ^>= 2.3.1

46 , text >= 1.2.3.0 && < 2.1

47− , time >= 1.6.0.1 && < 1.12

47+ , time >= 1.6.0.1 && < 1.13

48− , transformers >= 0.5.2.0 && < 0.6

48+ , transformers >= 0.5.2.0 && < 0.7

49

50 if !impl(ghc >= 8.2)

51 build-depends:

servant-machines/servant-machines.cabal+1−1

@@ -31,7 +31,7 @@ library

31 base >=4.9 && <5

32 , bytestring >=0.10.8.1 && <0.12

33 , machines >=0.6.4 && <0.8

34− , mtl >=2.2.2 && <2.3

34+ , mtl ^>=2.2.2 || ^>=2.3.1

35 , servant >=0.15 && <0.20

36 hs-source-dirs: src

37 default-language: Haskell2010

servant-pipes/servant-pipes.cabal+1−1

@@ -32,7 +32,7 @@ library

32 , bytestring >=0.10.8.1 && <0.12

33 , pipes >=4.3.9 && <4.4

34 , pipes-safe >=2.3.1 && <2.4

35− , mtl >=2.2.2 && <2.3

35+ , mtl ^>=2.2.2 || ^>=2.3.1

36 , monad-control >=1.0.2.3 && <1.1

37 , servant >=0.15 && <0.20

38 hs-source-dirs: src

servant-server/CHANGELOG.md+6

@@ -3,11 +3,17 @@

3

4Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.

5

6+0.19.2

7+------

8+

9+Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).

10+

60.19.1

110.19.1

7------

12------

8

13

9- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)

14- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)

10- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)

15- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)

16+- Add capture hints in `Router` type for debug and display purposes [PR #1556] (https://github.com/haskell-servant/servant/pull/1556)

11

17

120.19

180.19

13----

19----

servant-server/servant-server.cabal+8−8

@@ -1,6 +1,6 @@

1cabal-version: 2.2

2name: servant-server

3−version: 0.19.1

3+version: 0.19.2

4

5synopsis: A family of combinators for defining webservices APIs and serving them

6category: Servant, Web

@@ -23,7 +23,7 @@ author: Servant Contributors

23maintainer: haskell-servant-maintainers@googlegroups.com

24copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors

25build-type: Simple

26−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1

26+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.3

27

28extra-source-files:

29 CHANGELOG.md

@@ -60,20 +60,20 @@ library

60 -- Bundled with GHC: Lower bound to not force re-installs

61 -- text and mtl are bundled starting with GHC-8.4

62 build-depends:

63− base >= 4.9 && < 4.17

63+ base >= 4.9 && < 4.18

64 , bytestring >= 0.10.8.1 && < 0.12

65 , constraints >= 0.2 && < 0.14

66 , containers >= 0.5.7.1 && < 0.7

67− , mtl >= 2.2.2 && < 2.3

67+ , mtl ^>= 2.2.2 || ^>= 2.3.1

68 , text >= 1.2.3.0 && < 2.1

69− , transformers >= 0.5.2.0 && < 0.6

69+ , transformers >= 0.5.2.0 && < 0.7

70 , filepath >= 1.4.1.1 && < 1.5

71

72 -- Servant dependencies

73 -- strict dependency as we re-export 'servant' things.

74 build-depends:

75 servant >= 0.19 && < 0.20

76− , http-api-data >= 0.4.1 && < 0.4.4

76+ , http-api-data >= 0.4.1 && < 0.5.1

77

78 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

79 -- Here can be exceptions if we really need features from the newer versions.

@@ -88,10 +88,10 @@ library

88 , network >= 2.8 && < 3.2

89 , sop-core >= 0.4.0.0 && < 0.6

90 , string-conversions >= 0.4.0.1 && < 0.5

91− , resourcet >= 1.2.2 && < 1.3

91+ , resourcet >= 1.2.2 && < 1.4

92 , tagged >= 0.8.6 && < 0.9

93 , transformers-base >= 0.4.5.2 && < 0.5

94− , wai >= 3.2.1.2 && < 3.3

94+ , wai >= 3.2.2.1 && < 3.3

95 , wai-app-static >= 3.1.6.2 && < 3.2

96 , word8 >= 0.1.3 && < 0.2

97

servant-server/src/Servant/Server/Experimental/Auth.hs+2−1

@@ -1,5 +1,6 @@

1{-# OPTIONS_GHC -fno-warn-orphans #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

@@ -44,7 +45,7 @@ type family AuthServerData a :: *

44-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

45-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

45newtype AuthHandler r usr = AuthHandler

46newtype AuthHandler r usr = AuthHandler

46 { unAuthHandler :: r -> Handler usr }

47 { unAuthHandler :: r -> Handler usr }

47− deriving (Generic, Typeable)

48+ deriving (Functor, Generic, Typeable)

48

49

49-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

50-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

50mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr

51mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr

servant-server/src/Servant/Server/Internal.hs+89−7

@@ -1,10 +1,12 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DeriveDataTypeable #-}

5{-# LANGUAGE DeriveDataTypeable #-}

5{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE InstanceSigs #-}

8{-# LANGUAGE InstanceSigs #-}

9+{-# LANGUAGE LambdaCase #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE OverloadedStrings #-}

11{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE PolyKinds #-}

12{-# LANGUAGE PolyKinds #-}

@@ -34,9 +36,10 @@ module Servant.Server.Internal

34import Control.Monad

36import Control.Monad

35 (join, when)

37 (join, when)

36import Control.Monad.Trans

38import Control.Monad.Trans

37− (liftIO)

39+ (liftIO, lift)

38import Control.Monad.Trans.Resource

40import Control.Monad.Trans.Resource

39− (runResourceT)

41+ (runResourceT, ReleaseKey)

42+import Data.Acquire

40import qualified Data.ByteString as B

43import qualified Data.ByteString as B

41import qualified Data.ByteString.Builder as BB

44import qualified Data.ByteString.Builder as BB

42import qualified Data.ByteString.Char8 as BC8

45import qualified Data.ByteString.Char8 as BC8

@@ -63,7 +66,7 @@ import Network.HTTP.Types hiding

63import Network.Socket

66import Network.Socket

64 (SockAddr)

67 (SockAddr)

65import Network.Wai

68import Network.Wai

66− (Application, Request, httpVersion, isSecure, lazyRequestBody,

69+ (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,

67 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

70 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

68 requestMethod, responseLBS, responseStream, vault)

71 requestMethod, responseLBS, responseStream, vault)

69import Prelude ()

72import Prelude ()

@@ -73,10 +76,10 @@ import Servant.API

73 CaptureAll, Description, EmptyAPI, Fragment,

76 CaptureAll, Description, EmptyAPI, Fragment,

74 FramingRender (..), FramingUnrender (..), FromSourceIO (..),

77 FramingRender (..), FramingUnrender (..), FromSourceIO (..),

75 Header', If, IsSecure (..), NoContentVerb, QueryFlag,

78 Header', If, IsSecure (..), NoContentVerb, QueryFlag,

76− QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),

79+ QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),

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

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

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

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

79− WithNamedContext, NamedRoutes)

82+ WithNamedContext, WithResource, NamedRoutes)

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

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

81import Servant.API.ContentTypes

84import Servant.API.ContentTypes

82 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

85 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

@@ -94,6 +97,8 @@ import Servant.API.TypeErrors

94import Web.HttpApiData

97import Web.HttpApiData

95 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,

98 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,

96 parseUrlPieces)

99 parseUrlPieces)

100+import Data.Kind

101+ (Type)

97

102

98import Servant.Server.Internal.BasicAuth

103import Servant.Server.Internal.BasicAuth

99import Servant.Server.Internal.Context

104import Servant.Server.Internal.Context

@@ -112,6 +117,10 @@ import Servant.API.TypeLevel

112 (AtLeastOneFragment, FragmentUnique)

117 (AtLeastOneFragment, FragmentUnique)

113

118

114class HasServer api context where

119class HasServer api context where

120+ -- | The type of a server for this API, given a monad to run effects in.

121+ --

122+ -- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike

123+ -- what the @T@ in the name might suggest.

115 type ServerT api (m :: * -> *) :: *

124 type ServerT api (m :: * -> *) :: *

116

125

117 route ::

126 route ::

@@ -241,6 +250,42 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a

241 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

250 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

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

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

243

252

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

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

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

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

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

258+

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

260+-- provided via server 'Context'.

261+--

262+-- Example

263+--

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

265+-- >

266+-- > server :: Server MyApi

267+-- > server = writeToFile

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

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

270+--

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

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

273+-- if desired.

274+

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

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

277+

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

279+

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

281+

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

283+ where

284+ allocateResource :: DelayedIO (ReleaseKey, a)

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

286+

287+

288+

244allowedMethodHead :: Method -> Request -> Bool

289allowedMethodHead :: Method -> Request -> Bool

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

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

246

291

@@ -608,6 +653,35 @@ instance HasServer Raw context where

608 Fail a -> respond $ Fail a

653 Fail a -> respond $ Fail a

609 FailFatal e -> respond $ FailFatal e

654 FailFatal e -> respond $ FailFatal e

610

655

656+-- | Just pass the request to the underlying application and serve its response.

657+--

658+-- Example:

659+--

660+-- > type MyApi = "images" :> Raw

661+-- >

662+-- > server :: Server MyApi

663+-- > server = serveDirectory "/var/www/images"

664+instance HasServer RawM context where

665+ type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived

666+

667+ route

668+ :: Proxy RawM

669+ -> Context context

670+ -> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env

671+ route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do

672+ routeResult <- runDelayed handleDelayed env request

673+ let respond' = liftIO . respond

674+ liftIO $ case routeResult of

675+ Route handler -> runHandler (handler request (respond . Route)) >>=

676+ \case

677+ Left e -> respond' $ FailFatal e

678+ Right a -> pure a

679+ Fail e -> respond' $ Fail e

680+ FailFatal e -> respond' $ FailFatal e

681+

682+ hoistServerWithContext _ _ f srvM = \req respond -> f (srvM req respond)

683+

684+

611-- | If you use 'ReqBody' in one of the endpoints for your API,

685-- | If you use 'ReqBody' in one of the endpoints for your API,

612-- this automatically requires your server-side handler to be a function

686-- this automatically requires your server-side handler to be a function

613-- that takes an argument of the type specified by 'ReqBody'.

687-- that takes an argument of the type specified by 'ReqBody'.

@@ -821,7 +895,11 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA

821-------------------------------------------------------------------------------

895-------------------------------------------------------------------------------

822

896

823-- Erroring instance for 'HasServer' when a combinator is not fully applied

897-- Erroring instance for 'HasServer' when a combinator is not fully applied

898+instance TypeError (PartialApplication

899+#if __GLASGOW_HASKELL__ >= 904

900+ @(Type -> [Type] -> Constraint)

901+#endif

824−instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context

902+ HasServer arr) => HasServer ((arr :: a -> b) :> sub) context

825 where

903 where

826 type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)

904 type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)

827 route = error "unreachable"

905 route = error "unreachable"

@@ -865,7 +943,11 @@ type HasServerArrowTypeError a b =

865-- XXX: This omits the @context@ parameter, e.g.:

943-- XXX: This omits the @context@ parameter, e.g.:

866--

944--

867-- "There is no instance for HasServer (Bool :> …)". Do we care ?

945-- "There is no instance for HasServer (Bool :> …)". Do we care ?

868−instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasServer ty) => HasServer (ty :> sub) context

946+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub

947+#if __GLASGOW_HASKELL__ >= 904

948+ @(Type -> [Type] -> Constraint)

949+#endif

950+ HasServer ty) => HasServer (ty :> sub) context

869

951

870instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context

952instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context

871

953

servant-server/src/Servant/Server/Internal/Router.hs+19−1

@@ -28,9 +28,12 @@ import Servant.Server.Internal.ServerError

28

29type Router env = Router' env RoutingApplication

30

31+-- | Holds information about pieces of url that are captured as variables.

31data CaptureHint = CaptureHint

32data CaptureHint = CaptureHint

32 { captureName :: Text

33 { captureName :: Text

34+ -- ^ Holds the name of the captured variable

33 , captureType :: TypeRep

35 , captureType :: TypeRep

36+ -- ^ Holds the type of the captured variable

34 }

37 }

35 deriving (Show, Eq)

38 deriving (Show, Eq)

36

39

@@ -54,10 +57,21 @@ data Router' env a =

54 -- for the empty path, to be tried in order

57 -- for the empty path, to be tried in order

55 | CaptureRouter [CaptureHint] (Router' (Text, env) a)

58 | CaptureRouter [CaptureHint] (Router' (Text, env) a)

56 -- ^ first path component is passed to the child router in its

59 -- ^ first path component is passed to the child router in its

57− -- environment and removed afterwards

60+ -- environment and removed afterwards.

61+ -- The first argument is a list of hints for all variables that can be

62+ -- captured by the router. The fact that it is a list is counter-intuitive,

63+ -- because the 'Capture' combinator only allows to capture a single varible,

64+ -- with a single name and a single type. However, the 'choice' smart

65+ -- constructor may merge two 'Capture' combinators with different hints, thus

66+ -- forcing the type to be '[CaptureHint]'.

67+ -- Because 'CaptureRouter' is built from a 'Capture' combinator, the list of

68+ -- hints should always be non-empty.

58 | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)

69 | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)

59 -- ^ all path components are passed to the child router in its

70 -- ^ all path components are passed to the child router in its

60 -- environment and are removed afterwards

71 -- environment and are removed afterwards

72+ -- The first argument is a hint for the list of variables that can be

73+ -- captured by the router. Note that the 'captureType' field of the hint

74+ -- should always be '[a]' for some 'a'.

61 | RawRouter (env -> a)

75 | RawRouter (env -> a)

62 -- ^ to be used for routes we do not know anything about

76 -- ^ to be used for routes we do not know anything about

63 | Choice (Router' env a) (Router' env a)

77 | Choice (Router' env a) (Router' env a)

@@ -101,6 +115,10 @@ choice router1 router2 = Choice router1 router2

101data RouterStructure =

115data RouterStructure =

102 StaticRouterStructure (Map Text RouterStructure) Int

116 StaticRouterStructure (Map Text RouterStructure) Int

103 | CaptureRouterStructure [CaptureHint] RouterStructure

117 | CaptureRouterStructure [CaptureHint] RouterStructure

118+ -- ^ The first argument holds information about variables

119+ -- that are captured by the router. There may be several hints

120+ -- if several routers have been aggregated by the 'choice'

121+ -- smart constructor.

104 | RawRouterStructure

122 | RawRouterStructure

105 | ChoiceStructure RouterStructure RouterStructure

123 | ChoiceStructure RouterStructure RouterStructure

106 deriving (Eq, Show)

124 deriving (Eq, Show)

servant-server/test/Servant/ServerSpec.hs+54−6

@@ -17,10 +17,14 @@ import Prelude.Compat

17

18import Control.Monad

19 (forM_, unless, when)

20+import Control.Monad.Reader (runReaderT, ask)

20import Control.Monad.Error.Class

21import Control.Monad.Error.Class

21 (MonadError (..))

22 (MonadError (..))

23+import Control.Monad.IO.Class (MonadIO(..))

22import Data.Aeson

24import Data.Aeson

23 (FromJSON, ToJSON, decode', encode)

25 (FromJSON, ToJSON, decode', encode)

26+import Data.Acquire

27+ (Acquire, mkAcquire)

24import qualified Data.ByteString as BS

28import qualified Data.ByteString as BS

25import qualified Data.ByteString.Base64 as Base64

29import qualified Data.ByteString.Base64 as Base64

26import Data.Char

30import Data.Char

@@ -52,19 +56,19 @@ import Servant.API

52 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,

56 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,

53 Headers, HttpVersion, IsSecure (..), JSON, Lenient,

57 Headers, HttpVersion, IsSecure (..), JSON, Lenient,

54 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,

58 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,

55− PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,

59+ PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM,

56 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,

60 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,

57 UVerb, Union, Verb, WithStatus (..), addHeader)

61 UVerb, Union, Verb, WithStatus (..), addHeader)

58import Servant.Server

62import Servant.Server

59− (Context ((:.), EmptyContext), Handler, Server, Tagged (..),

63+ (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..),

60− emptyServer, err401, err403, err404, respond, serve,

64+ emptyServer, err401, err403, err404, hoistServer, respond, serve,

61 serveWithContext)

65 serveWithContext)

62import Servant.Test.ComprehensiveAPI

66import Servant.Test.ComprehensiveAPI

63import qualified Servant.Types.SourceT as S

67import qualified Servant.Types.SourceT as S

64import Test.Hspec

68import Test.Hspec

65 (Spec, context, describe, it, shouldBe, shouldContain)

69 (Spec, context, describe, it, shouldBe, shouldContain)

66import Test.Hspec.Wai

70import Test.Hspec.Wai

67− (get, liftIO, matchHeaders, matchStatus, shouldRespondWith,

71+ (get, matchHeaders, matchStatus, shouldRespondWith,

68 with, (<:>))

72 with, (<:>))

69import qualified Test.Hspec.Wai as THW

73import qualified Test.Hspec.Wai as THW

70

74

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

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

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

82_ = serveWithContext comprehensiveAPI comprehensiveApiContext

86_ = serveWithContext comprehensiveAPI comprehensiveApiContext

83

87

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

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

89+comprehensiveApiContext =

85−comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext

90+ NamedContext EmptyContext :.

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

92+ EmptyContext

86

93

87-- * Specs

94-- * Specs

88

95

@@ -97,6 +104,7 @@ spec = do

97 reqBodySpec

104 reqBodySpec

98 headerSpec

105 headerSpec

99 rawSpec

106 rawSpec

107+ rawMSpec

100 alternativeSpec

108 alternativeSpec

101 responseHeadersSpec

109 responseHeadersSpec

102 uverbResponseHeadersSpec

110 uverbResponseHeadersSpec

@@ -605,6 +613,46 @@ rawSpec = do

605

613

606-- }}}

614-- }}}

607------------------------------------------------------------------------------

615------------------------------------------------------------------------------

616+-- * rawMSpec {{{

617+------------------------------------------------------------------------------

618+

619+type RawMApi = "foo" :> RawM

620+

621+rawMApi :: Proxy RawMApi

622+rawMApi = Proxy

623+

624+rawMServer :: (Monad m, MonadIO m, Show a) => (Request -> m a) -> ServerT RawMApi m

625+rawMServer f req resp = liftIO . resp . responseLBS ok200 [] . cs . show =<< f req

626+

627+rawMSpec :: Spec

628+rawMSpec = do

629+ describe "Servant.API.RawM" $ do

630+ it "gives access to monadic context" $ do

631+ flip runSession (serve rawMApi

632+ (hoistServer rawMApi (flip runReaderT (42 :: Integer)) (rawMServer (const ask)))) $ do

633+ response <- Network.Wai.Test.request defaultRequest{

634+ pathInfo = ["foo"]

635+ }

636+ liftIO $ do

637+ simpleBody response `shouldBe` "42"

638+

639+ it "lets users throw servant errors" $ do

640+ flip runSession (serve rawMApi (rawMServer (const $ throwError err404 >> pure (42 :: Integer)))) $ do

641+ response <- Network.Wai.Test.request defaultRequest{

642+ pathInfo = ["foo"]

643+ }

644+ liftIO $ do

645+ statusCode (simpleStatus response) `shouldBe` 404

646+

647+ it "gets the pathInfo modified" $ do

648+ flip runSession (serve rawMApi (rawMServer (pure . pathInfo))) $ do

649+ response <- Network.Wai.Test.request defaultRequest{

650+ pathInfo = ["foo", "bar"]

651+ }

652+ liftIO $ do

653+ simpleBody response `shouldBe` cs (show ["bar" :: String])

654+-- }}}

655+------------------------------------------------------------------------------

608-- * alternativeSpec {{{

656-- * alternativeSpec {{{

609------------------------------------------------------------------------------

657------------------------------------------------------------------------------

610type AlternativeApi =

658type AlternativeApi =

servant-swagger/servant-swagger.cabal+2−2

@@ -106,11 +106,11 @@ test-suite spec

106 type: exitcode-stdio-1.0

107 hs-source-dirs: test

108 main-is: Spec.hs

109− build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.10

109+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.11

110 build-depends: base

111 , base-compat

112 , aeson >=1.4.2.0 && <3

113− , hspec >=2.6.0 && <2.10

113+ , hspec >=2.6.0 && <2.11

114 , QuickCheck

115 , lens

116 , lens-aeson >=1.0.2 && <1.3

servant-swagger/src/Servant/Swagger.hs+2

@@ -55,6 +55,7 @@ import Servant.Swagger.Internal.Orphans ()

55-- >>> import Data.Typeable

56-- >>> import GHC.Generics

57-- >>> import Servant.API

58+-- >>> import System.Environment

58-- >>> import Test.Hspec

59-- >>> import Test.Hspec

59-- >>> import Test.QuickCheck

60-- >>> import Test.QuickCheck

60-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8

61-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8

@@ -64,6 +65,7 @@ import Servant.Swagger.Internal.Orphans ()

64-- >>> :set -XGeneralizedNewtypeDeriving

65-- >>> :set -XGeneralizedNewtypeDeriving

65-- >>> :set -XOverloadedStrings

66-- >>> :set -XOverloadedStrings

66-- >>> :set -XTypeOperators

67-- >>> :set -XTypeOperators

68+-- >>> setEnv "HSPEC_COLOR" "no"

67-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)

69-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)

68-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)

70-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)

69-- >>> instance ToJSON User

71-- >>> instance ToJSON User

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

@@ -3,11 +3,13 @@

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE OverloadedLists #-}

6{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeOperators #-}

11{-# LANGUAGE TypeOperators #-}

12+{-# LANGUAGE TypeFamilies #-}

11#if __GLASGOW_HASKELL__ >= 806

13#if __GLASGOW_HASKELL__ >= 806

12{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

13#endif

15#endif

@@ -30,11 +32,13 @@ import qualified Data.Swagger as Swagger

30import Data.Swagger.Declare

32import Data.Swagger.Declare

31import Data.Text (Text)

33import Data.Text (Text)

32import qualified Data.Text as Text

34import qualified Data.Text as Text

35+import GHC.Generics (D1, Meta(..), Rep)

33import GHC.TypeLits

36import GHC.TypeLits

34import Network.HTTP.Media (MediaType)

37import Network.HTTP.Media (MediaType)

35import Servant.API

38import Servant.API

36import Servant.API.Description (FoldDescription,

39import Servant.API.Description (FoldDescription,

37 reflectDescription)

40 reflectDescription)

41+import Servant.API.Generic (ToServantApi, AsApi)

38import Servant.API.Modifiers (FoldRequired)

42import Servant.API.Modifiers (FoldRequired)

39

43

40import Servant.Swagger.Internal.TypeLevel.API

44import Servant.Swagger.Internal.TypeLevel.API

@@ -149,6 +153,10 @@ mkEndpointNoContentVerb path _ = mempty

149addParam :: Param -> Swagger -> Swagger

153addParam :: Param -> Swagger -> Swagger

150addParam param = allOperations.parameters %~ (Inline param :)

154addParam param = allOperations.parameters %~ (Inline param :)

151

155

156+-- | Add a tag to every operation in the spec.

157+addTag :: Text -> Swagger -> Swagger

158+addTag tag = allOperations.tags %~ ([tag] <>)

159+

152-- | Add accepted content types to every operation in the spec.

160-- | Add accepted content types to every operation in the spec.

153addConsumes :: [MediaType] -> Swagger -> Swagger

161addConsumes :: [MediaType] -> Swagger -> Swagger

154addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))

162addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))

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

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

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

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

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

298

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+

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

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

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

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

301 where

313 where

@@ -439,6 +451,9 @@ instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mo

439 & required ?~ True

451 & required ?~ True

440 & schema .~ ParamBody ref

452 & schema .~ ParamBody ref

441

453

454+instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where

455+ toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes)))

456+

442-- =======================================================================

457-- =======================================================================

443-- Below are the definitions that should be in Servant.API.ContentTypes

458-- Below are the definitions that should be in Servant.API.ContentTypes

444-- =======================================================================

459-- =======================================================================

servant-swagger/src/Servant/Swagger/Internal/Test.hs+2

@@ -29,10 +29,12 @@ import Servant.Swagger.Internal.TypeLevel

29-- >>> import Control.Applicative

30-- >>> import GHC.Generics

31-- >>> import Test.QuickCheck

32+-- >>> import System.Environment (setEnv)

32-- >>> :set -XDeriveGeneric

33-- >>> :set -XDeriveGeneric

33-- >>> :set -XGeneralizedNewtypeDeriving

34-- >>> :set -XGeneralizedNewtypeDeriving

34-- >>> :set -XDataKinds

35-- >>> :set -XDataKinds

35-- >>> :set -XTypeOperators

36-- >>> :set -XTypeOperators

37+-- >>> setEnv "HSPEC_COLOR" "no"

36

38

37-- | Verify that every type used with @'JSON'@ content type in a servant API

39-- | Verify that every type used with @'JSON'@ content type in a servant API

38-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.

40-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.

servant/CHANGELOG.md+5

@@ -2,6 +2,11 @@

2

3Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.

4

5+0.19.1

6+------

7+

8+Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).

9+

50.19

100.19

6----

11----

7

12

servant/servant.cabal+6−5

@@ -1,6 +1,6 @@

1cabal-version: 2.2

2name: servant

3−version: 0.19

3+version: 0.19.1

4

5synopsis: A family of combinators for defining webservices APIs

6category: Servant, Web

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

@@ -80,19 +81,19 @@ library

80 --

81 --

81 -- note: mtl lower bound is so low because of GHC-7.8

82 -- note: mtl lower bound is so low because of GHC-7.8

82 build-depends:

83 build-depends:

83− base >= 4.9 && < 4.17

84+ base >= 4.9 && < 4.18

84 , bytestring >= 0.10.8.1 && < 0.12

85 , bytestring >= 0.10.8.1 && < 0.12

85 , constraints >= 0.2

86 , constraints >= 0.2

86− , mtl >= 2.2.2 && < 2.3

87+ , mtl ^>= 2.2.2 || ^>= 2.3.1

87 , sop-core >= 0.4.0.0 && < 0.6

88 , sop-core >= 0.4.0.0 && < 0.6

88− , transformers >= 0.5.2.0 && < 0.6

89+ , transformers >= 0.5.2.0 && < 0.7

89 , text >= 1.2.3.0 && < 2.1

90 , text >= 1.2.3.0 && < 2.1

90

91

92

92 -- We depend (heavily) on the API of these packages:

93 -- We depend (heavily) on the API of these packages:

93 -- i.e. re-export, or allow using without direct dependency

94 -- i.e. re-export, or allow using without direct dependency

94 build-depends:

95 build-depends:

95− http-api-data >= 0.4.1 && < 0.4.4

96+ http-api-data >= 0.4.1 && < 0.5.1

96 , singleton-bool >= 0.1.4 && < 0.1.7

97 , singleton-bool >= 0.1.4 && < 0.1.7

97

98

98 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

99 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

servant/src/Servant/API.hs+10−6

@@ -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,21 +103,23 @@ 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

118− (Raw)

122+ (Raw, RawM)

119import Servant.API.RemoteHost

123import Servant.API.RemoteHost

120 (RemoteHost)

124 (RemoteHost)

121import Servant.API.ReqBody

125import Servant.API.ReqBody

@@ -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/ContentTypes.hs+1−1

@@ -295,7 +295,7 @@ instance {-# OVERLAPPABLE #-}

295-- then this would be taken care of. However there is no more specific instance

296-- between that and 'MimeRender JSON a', so we do this instead

297instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where

298− allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp

298+ allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp

299 where

300 pctyp = Proxy :: Proxy ctyp

301

servant/src/Servant/API/Raw.hs+3

@@ -15,3 +15,6 @@ import Data.Typeable

15-- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles>

16-- to serve static files stored in a particular directory on your filesystem

17data Raw deriving Typeable

18+

19+-- | Variant of 'Raw' that lets you access the underlying monadic context to process the request.

20+data RawM deriving Typeable

servant/src/Servant/API/ResponseHeaders.hs+23

@@ -8,6 +8,7 @@

8{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeFamilyDependencies #-}

11{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

13{-# LANGUAGE UndecidableInstances #-}

13{-# OPTIONS_HADDOCK not-home #-}

14{-# OPTIONS_HADDOCK not-home #-}

@@ -51,6 +52,9 @@ import Prelude ()

51import Prelude.Compat

52import Prelude.Compat

52import Servant.API.Header

53import Servant.API.Header

53 (Header)

54 (Header)

55+import Servant.API.UVerb.Union

56+import qualified Data.SOP.BasicFunctors as SOP

57+import qualified Data.SOP.NS as SOP

54

58

55-- | Response Header objects. You should never need to construct one directly.

59-- | Response Header objects. You should never need to construct one directly.

56-- Instead, use 'addOptionalHeader'.

60-- Instead, use 'addOptionalHeader'.

@@ -170,6 +174,25 @@ instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '

170 => AddHeader h v a new where

174 => AddHeader h v a new where

171 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)

175 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)

172

176

177+-- Instances to decorate all responses in a 'Union' with headers. The functional

178+-- dependencies force us to consider singleton lists as the base case in the

179+-- recursion (it is impossible to determine h and v otherwise from old / new

180+-- responses if the list is empty).

181+instance (AddHeader h v old new) => AddHeader h v (Union '[old]) (Union '[new]) where

182+ addOptionalHeader hdr resp =

183+ SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ $ resp

184+

185+instance

186+ ( AddHeader h v old new, AddHeader h v (Union oldrest) (Union newrest)

187+ -- This ensures that the remainder of the response list is _not_ empty

188+ -- It is necessary to prevent the two instances for union types from

189+ -- overlapping.

190+ , oldrest ~ (a ': as), newrest ~ (b ': bs))

191+ => AddHeader h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where

192+ addOptionalHeader hdr resp = case resp of

193+ SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead

194+ SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers

195+

173-- | @addHeader@ adds a header to a response. Note that it changes the type of

196-- | @addHeader@ adds a header to a response. Note that it changes the type of

174-- the value in the following ways:

197-- the value in the following ways:

175--

198--

servant/src/Servant/API/TypeLevel.hs+3−3

@@ -110,7 +110,7 @@ type family IsElem' a s :: Constraint

110--

111-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))

112-- ...

113−-- ... Could not deduce...

113+-- ... Could not ...

114-- ...

115--

116-- An endpoint is considered within an api even if it is missing combinators

@@ -151,7 +151,7 @@ type family IsElem endpoint api :: Constraint where

151--

152-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI))

153-- ...

154−-- ... Could not deduce...

154+-- ... Could not ...

155-- ...

156--

157-- This uses @IsElem@ for checking; thus the note there applies here.

@@ -174,7 +174,7 @@ type family AllIsElem xs api :: Constraint where

174--

175-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))

176-- ...

177−-- ... Could not deduce...

177+-- ... Could not ...

178-- ...

179type family IsIn (endpoint :: *) (api :: *) :: Constraint where

180 IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)

servant/src/Servant/API/UVerb.hs+3

@@ -38,6 +38,7 @@ import GHC.TypeLits (Nat)

38import Network.HTTP.Types (Status, StdMethod)

39import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))

40import Servant.API.Status (KnownStatus, statusVal)

41+import Servant.API.ResponseHeaders (Headers)

41import Servant.API.UVerb.Union

42import Servant.API.UVerb.Union

42

43

43class KnownStatus (StatusOf a) => HasStatus (a :: *) where

44class KnownStatus (StatusOf a) => HasStatus (a :: *) where

@@ -86,6 +87,8 @@ newtype WithStatus (k :: Nat) a = WithStatus a

86instance KnownStatus n => HasStatus (WithStatus n a) where

87instance KnownStatus n => HasStatus (WithStatus n a) where

87 type StatusOf (WithStatus n a) = n

88 type StatusOf (WithStatus n a) = n

88

89

90+instance HasStatus a => HasStatus (Headers ls a) where

91+ type StatusOf (Headers ls a) = StatusOf a

89

92

90-- | A variant of 'Verb' that can have any of a number of response values and status codes.

93-- | A variant of 'Verb' that can have any of a number of response values and status codes.

91--

94--

servant/src/Servant/API/UVerb/Union.hs+2−2

@@ -128,9 +128,9 @@ type DuplicateElementError (rs :: [k]) =

128 ':$$: 'Text " " ':<>: 'ShowType rs

129

130type family Elem (x :: k) (xs :: [k]) :: Bool where

131+ Elem x (x ': _) = 'True

132+ Elem x (_ ': xs) = Elem x xs

131 Elem _ '[] = 'False

133 Elem _ '[] = 'False

132− Elem x (x' ': xs) =

133− If (x == x') 'True (Elem x xs)

134

135type family Unique xs :: Constraint where

136 Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))

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+25−4

@@ -1,5 +1,6 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

@@ -91,7 +92,7 @@

91-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)

92-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)

92-- >>> safeLink api bad_link

93-- >>> safeLink api bad_link

93-- ...

94-- ...

94−-- ...Could not deduce...

95+-- ...Could not ...

95-- ...

96-- ...

96--

97--

97-- This error is essentially saying that the type family couldn't find

98-- This error is essentially saying that the type family couldn't find

@@ -174,7 +175,7 @@ import Servant.API.NamedRoutes

174import Servant.API.QueryParam

175import Servant.API.QueryParam

175 (QueryFlag, QueryParam', QueryParams)

176 (QueryFlag, QueryParam', QueryParams)

176import Servant.API.Raw

177import Servant.API.Raw

177− (Raw)

178+ (Raw, RawM)

178import Servant.API.RemoteHost

179import Servant.API.RemoteHost

179 (RemoteHost)

180 (RemoteHost)

180import Servant.API.ReqBody

181import Servant.API.ReqBody

@@ -192,7 +193,11 @@ import Servant.API.Verbs

192 (Verb, NoContentVerb)

193 (Verb, NoContentVerb)

193import Servant.API.WithNamedContext

194import Servant.API.WithNamedContext

194 (WithNamedContext)

195 (WithNamedContext)

196+import Servant.API.WithResource

197+ (WithResource)

195import Web.HttpApiData

198import Web.HttpApiData

199+import Data.Kind

200+ (Type)

196

201

197-- | A safe link datatype.

202-- | A safe link datatype.

198-- The only way of constructing a 'Link' is using 'safeLink', which means any

203-- The only way of constructing a 'Link' is using 'safeLink', which means any

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

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

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

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

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

557

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+

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

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

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

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

560 toLink = simpleToLink (Proxy :: Proxy sub)

569 toLink = simpleToLink (Proxy :: Proxy sub)

@@ -580,6 +589,10 @@ instance HasLink Raw where

580 type MkLink Raw a = a

589 type MkLink Raw a = a

581 toLink toA _ = toA

590 toLink toA _ = toA

582

591

592+instance HasLink RawM where

593+ type MkLink RawM a = a

594+ toLink toA _ = toA

595+

583instance HasLink (Stream m status fr ct a) where

596instance HasLink (Stream m status fr ct a) where

584 type MkLink (Stream m status fr ct a) r = r

597 type MkLink (Stream m status fr ct a) r = r

585 toLink toA _ = toA

598 toLink toA _ = toA

@@ -647,12 +660,20 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)

647-- >>> import Data.Text (Text)

660-- >>> import Data.Text (Text)

648

661

649-- Erroring instance for 'HasLink' when a combinator is not fully applied

662-- Erroring instance for 'HasLink' when a combinator is not fully applied

650−instance TypeError (PartialApplication HasLink arr) => HasLink ((arr :: a -> b) :> sub)

663+instance TypeError (PartialApplication

664+#if __GLASGOW_HASKELL__ >= 904

665+ @(Type -> Constraint)

666+#endif

667+ HasLink arr) => HasLink ((arr :: a -> b) :> sub)

651 where

668 where

652 type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)

669 type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)

653 toLink = error "unreachable"

670 toLink = error "unreachable"

654

671

655-- Erroring instances for 'HasLink' for unknown API combinators

672-- Erroring instances for 'HasLink' for unknown API combinators

656−instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasLink ty) => HasLink (ty :> sub)

673+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub

674+#if __GLASGOW_HASKELL__ >= 904

675+ @(Type -> Constraint)

676+#endif

677+ HasLink ty) => HasLink (ty :> sub)

657

678

658instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api

679instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api

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

servant/src/Servant/Types/SourceT.hs+3

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE RankNTypes #-}

@@ -154,8 +155,10 @@ instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where

154-- | >>> lift [1,2,3] :: StepT [] Int

155-- | >>> lift [1,2,3] :: StepT [] Int

155-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]

156-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]

156--

157--

158+#if !MIN_VERSION_transformers(0,6,0)

157instance MonadTrans StepT where

159instance MonadTrans StepT where

158 lift = Effect . fmap (`Yield` Stop)

160 lift = Effect . fmap (`Yield` Stop)

161+#endif

159

162

160instance MFunctor StepT where

163instance MFunctor StepT where

161 hoist f = go where

164 hoist f = go where

servant/test/Servant/API/ContentTypesSpec.hs+11

@@ -33,6 +33,8 @@ import Data.String.Conversions

33import qualified Data.Text as TextS

34import qualified Data.Text.Encoding as TextSE

35import qualified Data.Text.Lazy as TextL

36+import Control.Exception

37+ (evaluate)

36import GHC.Generics

38import GHC.Generics

37import Test.Hspec

39import Test.Hspec

38import Test.QuickCheck

40import Test.QuickCheck

@@ -78,6 +80,15 @@ spec = describe "Servant.API.ContentTypes" $ do

78 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

80 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

79 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

81 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

80

82

83+ describe "The NoContent Content-Type type" $ do

84+ let p = Proxy :: Proxy '[JSON]

85+

86+ it "does not render any content" $

87+ allMimeRender p NoContent `shouldSatisfy` (all (BSL8.null . snd))

88+

89+ it "evaluates the NoContent value" $

90+ evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall

91+

81 describe "The PlainText Content-Type type" $ do

92 describe "The PlainText Content-Type type" $ do

82 let p = Proxy :: Proxy PlainText

93 let p = Proxy :: Proxy PlainText

83

94

servant/test/Servant/API/ResponseHeadersSpec.hs+11

@@ -2,10 +2,14 @@

2{-# LANGUAGE OverloadedStrings #-}

3module Servant.API.ResponseHeadersSpec where

4

5+import Data.Proxy

6+import GHC.TypeLits

5import Test.Hspec

7import Test.Hspec

6

8

9+import Servant.API.ContentTypes

7import Servant.API.Header

10import Servant.API.Header

8import Servant.API.ResponseHeaders

11import Servant.API.ResponseHeaders

12+import Servant.API.UVerb

9

13

10spec :: Spec

14spec :: Spec

11spec = describe "Servant.API.ResponseHeaders" $ do

15spec = describe "Servant.API.ResponseHeaders" $ do

@@ -28,3 +32,10 @@ spec = describe "Servant.API.ResponseHeaders" $ do

28 it "does not add a header" $ do

32 it "does not add a header" $ do

29 let val = noHeader 5 :: Headers '[Header "test" Int] Int

33 let val = noHeader 5 :: Headers '[Header "test" Int] Int

30 getHeaders val `shouldBe` []

34 getHeaders val `shouldBe` []

35+

36+ describe "HasStatus Headers" $ do

37+

38+ it "gets the status from the underlying value" $ do

39+ natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] NoContent))) `shouldBe` 204

40+ natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] (WithStatus 503 ())))) `shouldBe` 503

41+