master..658585a · servant

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

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

2020 - "8.10.7"

2121 - "9.0.2"

2222 - "9.2.2"

23− - "9.4.2"

2423

2524 steps:

2625 - uses: actions/checkout@v2

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

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

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

7877

79− # stack:

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

81− # runs-on: ubuntu-latest

82− # strategy:

83− # matrix:

84− # stack: ["2.7.5"]

85− # ghc: ["8.10.7"]

86−

87− # steps:

88− # - uses: actions/checkout@v2

89−

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

91− # name: Setup Haskell Stack

92− # with:

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

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

95−

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

97− # name: Cache ~/.stack

98− # with:

99− # path: ~/.stack

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

101−

102− # - name: Install dependencies

103− # run: |

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

105−

106− # - name: Build

107− # run: |

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

109−

110− # - name: Test

111− # run: |

112− # stack test --system-ghc

78+ stack:

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

80+ runs-on: ubuntu-latest

81+ strategy:

82+ matrix:

83+ stack: ["2.7.5"]

84+ ghc: ["8.10.7"]

85+

86+ steps:

87+ - uses: actions/checkout@v2

88+

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

90+ name: Setup Haskell Stack

91+ with:

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

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

94+

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

96+ name: Cache ~/.stack

97+ with:

98+ path: ~/.stack

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

100+

101+ - name: Install dependencies

102+ run: |

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

104+

105+ - name: Build

106+ run: |

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

108+

109+ - name: Test

110+ run: |

111+ stack test --system-ghc

113112

114113 ghcjs:

115114 name: ubuntu-latest / ghcjs 8.6

cabal.project−1

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

4747 doc/cookbook/using-custom-monad

4848 doc/cookbook/using-free-client

4949 -- doc/cookbook/open-id-connect

50− doc/cookbook/managed-resource

5150

5251tests: True

5352optimization: False

changelog.d/1571deleted−10

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

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/1573deleted−2

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

1−synopsis: Add API docs for ServerT

2−prs: #1573

changelog.d/1580deleted−12

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

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/1589deleted−2

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

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

2−prs: 1589

changelog.d/1595deleted−2

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

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

2−prs: #1595

changelog.d/1606deleted−10

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

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/1638deleted−2

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

1−synopsis: Add Functor instance to AuthHandler.

2−prs: #1638

changelog.d/1649deleted−8

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

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,4 +37,3 @@ you name it!

3737 sentry/Sentry.lhs

3838 testing/Testing.lhs

3939 open-id-connect/OpenIdConnect.lhs

40− managed-resource/ManagedResource.lhs

doc/cookbook/managed-resource/ManagedResource.lhsdeleted−114

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

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.cabaldeleted−30

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

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 {

330330```

331331

332332Here is the code that displays the homepage.

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

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

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

335335with some generated information.

336336

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`

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

120120

121121```haskell

122− req' <- I.defaultMakeClientRequest burl req

122+ let req' = I.defaultMakeClientRequest burl req

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

124124```

125125

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

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

200200

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

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

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

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

204204The README claims that

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

doc/requirements.txt−1

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

11recommonmark==0.5.0

22Sphinx==1.8.4

33sphinx_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

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

3232 ghc-options: -Wall

3333 build-depends:

34− base >= 4.10 && < 4.18

34+ base >= 4.10 && < 4.17

3535 , bytestring >= 0.10.6.0 && < 0.12

3636 , containers >= 0.5.6.2 && < 0.7

3737 , servant-auth == 0.4.*

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

7474 , transformers >= 0.4.2.0 && < 0.6

7575 , wai >= 3.2.1.2 && < 3.3

7676 , warp >= 3.2.25 && < 3.4

77− , jose >= 0.10 && < 0.11

77+ , jose >= 0.7.0.0 && < 0.10

7878 other-modules:

7979 Servant.Auth.ClientSpec

8080 default-language: Haskell2010

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

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

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

3636 ghc-options: -Wall

3737 build-depends:

38− base >= 4.10 && < 4.18

38+ base >= 4.10 && < 4.17

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

4040 , servant >= 0.13 && < 0.20

4141 , servant-auth == 0.4.*

42− , lens >= 4.16.1 && <5.3

42+ , lens >= 4.16.1 && <5.2

4343 exposed-modules:

4444 Servant.Auth.Docs

4545 default-language: Haskell2010

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

5050 build-depends:

5151 base,

5252 servant-auth-docs,

53− doctest >= 0.16 && < 0.21,

53+ doctest >= 0.16 && < 0.19,

5454 QuickCheck >= 2.11.3 && < 2.15,

5555 template-haskell

5656 ghc-options: -Wall -threaded

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

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

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

3232 ghc-options: -Wall

3333 build-depends:

34− base >= 4.10 && < 4.18

34+ base >= 4.10 && < 4.17

3535 , aeson >= 1.0.0.1 && < 3

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

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

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

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

4242 , entropy >= 0.4.1.3 && < 0.5

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

44− , jose >= 0.10 && < 0.11

45− , lens >= 4.16.1 && < 5.3

46− , memory >= 0.14.16 && < 0.19

44+ , jose >= 0.7.0.0 && < 0.10

45+ , lens >= 4.16.1 && < 5.2

46+ , memory >= 0.14.16 && < 0.18

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

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

48+ , mtl >= 2.2.2 && < 2.3

4949 , servant >= 0.13 && < 0.20

5050 , servant-auth == 0.4.*

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

5252 , tagged >= 0.8.4 && < 0.9

5353 , text >= 1.2.3.0 && < 2.1

54− , time >= 1.5.0.1 && < 1.13

54+ , time >= 1.5.0.1 && < 1.12

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

5656 , wai >= 3.2.1.2 && < 3.3

5757

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

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

130130 , warp >= 3.2.25 && < 3.4

131131 , wreq >= 0.5.2.1 && < 0.6

132− , text >= 1.2.3.0 && < 2.1

133132 other-modules:

134133 Servant.Auth.ServerSpec

135134 default-language: Haskell2010

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

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

5454

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

5656 makeCookies authResult = do

57− case authResult of

58− (Authenticated v) -> do

59− ejwt <- makeSessionCookie cookieSettings jwtSettings v

60− xsrf <- makeXsrfCookie cookieSettings

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

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

57+ xsrf <- makeXsrfCookie cookieSettings

58+ fmap (Just xsrf `SetCookieCons`) $

59+ case authResult of

60+ (Authenticated v) -> do

61+ ejwt <- makeSessionCookie cookieSettings jwtSettings v

62+ case ejwt of

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

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

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

6366

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

6568 -> (AuthResult v, SetCookieList n)

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

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

1111import qualified Network.HTTP.Types as HTTP

1212import Network.Wai (mapResponseHeaders)

1313import Servant

14−import Servant.API.UVerb.Union

1514import Servant.API.Generic

1615import Servant.Server.Generic

1716import Web.Cookie

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

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

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

3635

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−

4336type family AddSetCookieApi a :: *

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

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

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

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

48−#endif

4940type instance AddSetCookieApi (Verb method stat ctyps a)

5041 = 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

5542type instance AddSetCookieApi Raw = Raw

5643#if MIN_VERSION_servant_server(0,15,0)

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

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

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

7158 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

7259

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

60+instance AddSetCookies 'Z orig orig where

7461 addSetCookies _ = id

7562

7663instance {-# OVERLAPPABLE #-}

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

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

3333 -- | Algorithm used to sign JWT.

3434 , jwtAlg :: Maybe Jose.Alg

3535 -- | Keys used to validate JWT.

36− , validationKeys :: IO Jose.JWKSet

36+ , validationKeys :: Jose.JWKSet

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

3838 -- intended recipient of the JWT.

3939 , audienceMatches :: Jose.StringOrURI -> IsMatch

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

4444defaultJWTSettings k = JWTSettings

4545 { signingKey = k

4646 , jwtAlg = Nothing

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

47+ , validationKeys = Jose.JWKSet [k]

4848 , audienceMatches = const Matches }

4949

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

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

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

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

33

44import Blaze.ByteString.Builder (toByteString)

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

65import Control.Monad.Except

76import Control.Monad.Reader

87import qualified Crypto.JOSE as Jose

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

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

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

22

33import Control.Lens

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

4+import Control.Monad.Except

55import Control.Monad.Reader

66import qualified Crypto.JOSE as Jose

77import qualified Crypto.JWT as Jose

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

9+ toJSON)

810import Data.ByteArray (constEq)

911import qualified Data.ByteString as BS

1012import qualified Data.ByteString.Lazy as BSL

13+import qualified Data.HashMap.Strict as HM

1114import Data.Maybe (fromMaybe)

15+import qualified Data.Text as T

1216import Data.Time (UTCTime)

1317import Network.Wai (requestHeaders)

1418

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

3842-- token expires.

3943makeJWT :: ToJWT a

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

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

45+makeJWT v cfg expiry = runExceptT $ do

4246 bestAlg <- Jose.bestJWSAlg $ signingKey cfg

4347 let alg = fromMaybe bestAlg $ jwtAlg cfg

4448 ejwt <- Jose.signClaims (signingKey cfg)

@@ -54,15 +58,14 @@ makeJWT v cfg expiry = Jose.runJOSE $ do

5458

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

5660verifyJWT jwtCfg input = do

57− keys <- validationKeys jwtCfg

58− verifiedJWT <- Jose.runJOSE $ do

61+ verifiedJWT <- liftIO $ runExceptT $ do

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

6063 Jose.verifyClaims

6164 (jwtSettingsToJwtValidationSettings jwtCfg)

62− keys

65+ (validationKeys jwtCfg)

6366 unverifiedJWT

6467 return $ case verifiedJWT of

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

6669 Right v -> case decodeJWT v of

6770 Left _ -> Nothing

68− Right v' -> Just v'

71+ Right v' -> Just v'

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

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

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

33

44import Control.Applicative

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

65import Control.Monad.Reader

76import Control.Monad.Time

87import Data.Monoid (Monoid (..))

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

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

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE TypeApplications #-}

32module Servant.Auth.ServerSpec (spec) where

43

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

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

76#endif

87

98import Control.Lens

9+import Control.Monad.Except (runExceptT)

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

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

1212 JWK, JWSHeader,

1313 KeyMaterialGenParam (OctGenParam),

1414 ToCompact, encodeCompact,

15− genJWK, newJWSHeader, runJOSE)

15+ genJWK, newJWSHeader)

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

1717 NumericDate (NumericDate),

1818 SignedJWT,

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

2525import Data.Aeson.Lens (_JSON)

2626import qualified Data.ByteString as BS

2727import qualified Data.ByteString.Lazy as BSL

28−import Data.Text (Text, pack)

2928import Data.CaseInsensitive (mk)

3029import Data.Foldable (find)

3130import Data.Monoid

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

4140import Network.Wai (responseLBS)

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

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

44− checkResponse,

4543 cookieExpiryTime, cookies,

4644 defaults, get, getWith, postWith,

4745 header, oauth2Bearer,

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

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

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

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

188− opts' <- addJwtToCookie cookieCfg jwt

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

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−

186+ opts <- addJwtToCookie cookieCfg jwt

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

203188

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

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

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

421406 = Auth auths User :>

422407 ( Get '[JSON] Int

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

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

409+ :<|> NamedRoutes DummyRoutes

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

426411#if MIN_VERSION_servant_server(0,15,0)

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

428413#endif

429414 :<|> "raw" :> Raw

430415 )

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

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

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

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

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

506490 :<|> raw

507491 Indefinite -> throwAll err401

508492 _ -> 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")

514493 )

515494 :<|> getLogin

516495 :<|> getLogout

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

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

562541

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

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

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

565544

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

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

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

591570 = fmap cookie_name (destroyCookieJar cj)

592571 `shouldMatchList` patterns

593572

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−

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

601574shouldMatchCookieNameValues cj patterns

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

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

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

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

3232 ghc-options: -Wall

3333 build-depends:

34− base >= 4.10 && < 4.18

34+ base >= 4.10 && < 4.16

3535 , text >= 1.2.3.0 && < 2.1

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

3737 , swagger2 >= 2.2.2 && < 3

3838 , servant >= 0.13 && < 0.20

3939 , servant-auth == 0.4.*

40− , lens >= 4.16.1 && < 5.3

40+ , lens >= 4.16.1 && < 5.2

41+ if impl(ghc >= 9)

42+ buildable: False

4143 exposed-modules:

4244 Servant.Auth.Swagger

4345 default-language: Haskell2010

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

5961 , servant

6062 , servant-auth

6163 , lens

64+ if impl(ghc >= 9)

65+ buildable: False

6266

6367 -- test dependencies

6468 build-depends:

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

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

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

3434 ghc-options: -Wall

3535 build-depends:

36− base >= 4.10 && < 4.18

36+ base >= 4.10 && < 4.17

3737 , containers >= 0.6 && < 0.7

3838 , aeson >= 1.3.1.1 && < 3

39− , jose >= 0.10 && < 0.11

40− , lens >= 4.16.1 && < 5.3

39+ , jose >= 0.7.0.0 && < 0.10

40+ , lens >= 4.16.1 && < 5.2

4141 , servant >= 0.15 && < 0.20

4242 , text >= 1.2.3.0 && < 2.1

4343 , 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

2727

2828-- ** Combinators

2929

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

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

3131--

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

3333--

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

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

5050 --

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

5252 build-depends:

53− base >= 4.9 && < 4.18

53+ base >= 4.9 && < 4.17

5454 , bytestring >= 0.10.8.1 && < 0.12

5555 , constraints >= 0.2 && < 0.14

5656 , containers >= 0.5.7.1 && < 0.7

5757 , deepseq >= 1.4.2.0 && < 1.5

5858 , text >= 1.2.3.0 && < 2.1

59− , transformers >= 0.5.2.0 && < 0.7

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

59+ , transformers >= 0.5.2.0 && < 0.6

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

6161

6262 if !impl(ghc >= 8.2)

6363 build-depends:

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

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

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

7575 IsSecure, MimeRender (mimeRender),

7676 MimeUnrender (mimeUnrender), NoContent (NoContent),

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

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

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

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

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

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

8181 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)

8282import Servant.API.Generic

8383 (GenericMode(..), ToServant, ToServantApi

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

674674

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

676676

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−

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

688678-- the corresponding querying function will automatically take

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

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

786776

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

788778

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−

797779instance ( HasClient m api

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

799781 type Client m (AuthProtect tag :> api)

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

912894-- rootClient = client api

913895--

914896-- endpointClient :: ClientM Person

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

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

916898-- @

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

918900x // f = f x

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

945927-- rootClient = client api

946928--

947929-- hello :: String -> ClientM String

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

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

949931--

950932-- endpointClient :: ClientM Person

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

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

952934-- @

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

954936(/:) = flip

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

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

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

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

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

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

51+ , mtl >=2.2.2 && <2.3

5252 , semigroupoids >=5.3 && <5.4

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

5454 , transformers >=0.3 && <0.6

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

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

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

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

4343 build-depends:

44− base >= 4.9 && < 4.18

44+ base >= 4.9 && < 4.17

4545 , bytestring >= 0.10.8.1 && < 0.12

4646 , containers >= 0.5.7.1 && < 0.7

4747 , deepseq >= 1.4.2.0 && < 1.5

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

48+ , mtl >= 2.2.2 && < 2.3

4949 , stm >= 2.4.5.1 && < 2.6

5050 , text >= 1.2.3.0 && < 2.1

51− , time >= 1.6.0.1 && < 1.13

52− , transformers >= 0.5.2.0 && < 0.7

51+ , time >= 1.6.0.1 && < 1.12

52+ , transformers >= 0.5.2.0 && < 0.6

5353

5454 if !impl(ghc >= 8.2)

5555 build-depends:

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

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

8080 { manager :: Client.Manager

8181 , baseUrl :: BaseUrl

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

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

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

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

8585 -- Note that:

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

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

163163performRequest acceptStatus req = do

164164 ClientEnv m burl cookieJar' createClientRequest <- ask

165− clientRequest <- liftIO $ createClientRequest burl req

165+ let clientRequest = createClientRequest burl req

166166 request <- case cookieJar' of

167167 Nothing -> pure clientRequest

168168 Just cj -> liftIO $ do

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

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

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

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

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

233−defaultMakeClientRequest burl r = return Client.defaultRequest

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

233+defaultMakeClientRequest burl r = Client.defaultRequest

234234 { Client.method = requestMethod r

235235 , Client.host = fromString $ baseUrlHost burl

236236 , Client.port = baseUrlPort burl

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

289289 Https -> True

290290

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

292− buildQueryString [] = mempty

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

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

294293

295294 addQueryParam qs (k, v) =

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

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

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

2424 (NFData, force)

2525import Control.Exception

2626 (evaluate, throwIO)

27−import Control.Monad

28− (unless)

27+import Control.Monad ()

2928import Control.Monad.Base

3029 (MonadBase (..))

3130import Control.Monad.Codensity

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

141140performRequest acceptStatus req = do

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

143142 ClientEnv m burl cookieJar' createClientRequest <- ask

144− clientRequest <- liftIO $ createClientRequest burl req

143+ let clientRequest = createClientRequest burl req

145144 request <- case cookieJar' of

146145 Nothing -> pure clientRequest

147146 Just cj -> liftIO $ do

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

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

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

177176performWithStreamingRequest req k = do

178− ClientEnv m burl cookieJar' createClientRequest <- ask

179− clientRequest <- liftIO $ createClientRequest burl req

180− request <- case cookieJar' of

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

177+ m <- asks manager

178+ burl <- asks baseUrl

179+ createClientRequest <- asks makeClientRequest

180+ let request = createClientRequest burl req

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

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

195183 let status = Client.responseStatus res

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

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

162162 mgr <- C.newManager C.defaultManagerSettings

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

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

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

166− (defaultMakeClientRequest url r)

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

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

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

169168 case res of

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

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

3131 base >=4.9 && <5

3232 , bytestring >=0.10.8.1 && <0.12

3333 , conduit >=1.3.1 && <1.4

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

35− , resourcet >=1.2.2 && <1.4

34+ , mtl >=2.2.2 && <2.3

35+ , resourcet >=1.2.2 && <1.3

3636 , servant >=0.15 && <0.20

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

3838 hs-source-dirs: src

servant-docs/golden/comprehensive.md−18

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

530530

531531```

532532

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−

551533## GET /streaming

552534

553535### Request:

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

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

4141 --

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

4343 build-depends:

44− base >= 4.9 && < 4.18

44+ base >= 4.9 && < 4.17

4545 , bytestring >= 0.10.8.1 && < 0.12

4646 , text >= 1.2.3.0 && < 2.1

4747

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

5959 , hashable >= 1.2.7.0 && < 1.5

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

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

62− , lens >= 4.17 && < 5.3

62+ , lens >= 4.17 && < 5.2

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

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

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

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

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

6262import Servant.API

6363import Servant.API.ContentTypes

6464import Servant.API.TypeLevel

65−import Servant.API.Generic

6665

6766import qualified Data.Universe.Helpers as U

6867

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

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

448447

449448

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

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

451450-- number of introduction(s)

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

453452docsWithIntros intros = docsWith defaultDocOptions intros mempty

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

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

11451144 docsFor Proxy = docsFor (Proxy :: Proxy api)

11461145

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

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

1149−

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

11511147 docsFor Proxy (endpoint, action) =

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

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

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

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

11561152

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

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

1159−

11601153-- ToSample instances for simple types

11611154instance ToSample NoContent

11621155instance ToSample Bool

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

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

4141 --

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

4343 build-depends:

44− base >= 4.9 && < 4.18

44+ base >= 4.9 && < 4.17

4545 , text >= 1.2.3.0 && < 2.1

4646

4747 -- Servant dependencies

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

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

5353 build-depends:

5454 base-compat >= 0.10.5 && < 0.13

55− , lens >= 4.17 && < 5.3

55+ , lens >= 4.17 && < 5.2

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

5757

5858 hs-source-dirs: src

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

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

487487

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

489489

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−

497490instance HasForeign lang ftype api

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

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

servant-http-streams/servant-http-streams.cabal+4−4

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

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

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

4040 build-depends:

41− base >= 4.9 && < 4.18

41+ base >= 4.9 && < 4.17

4242 , bytestring >= 0.10.8.1 && < 0.12

4343 , containers >= 0.5.7.1 && < 0.7

4444 , deepseq >= 1.4.2.0 && < 1.5

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

45+ , mtl >= 2.2.2 && < 2.3

4646 , text >= 1.2.3.0 && < 2.1

47− , time >= 1.6.0.1 && < 1.13

48− , transformers >= 0.5.2.0 && < 0.7

47+ , time >= 1.6.0.1 && < 1.12

48+ , transformers >= 0.5.2.0 && < 0.6

4949

5050 if !impl(ghc >= 8.2)

5151 build-depends:

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

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

3131 base >=4.9 && <5

3232 , bytestring >=0.10.8.1 && <0.12

3333 , machines >=0.6.4 && <0.8

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

34+ , mtl >=2.2.2 && <2.3

3535 , servant >=0.15 && <0.20

3636 hs-source-dirs: src

3737 default-language: Haskell2010

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

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

3232 , bytestring >=0.10.8.1 && <0.12

3333 , pipes >=4.3.9 && <4.4

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

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

35+ , mtl >=2.2.2 && <2.3

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

3737 , servant >=0.15 && <0.20

3838 hs-source-dirs: src

servant-server/CHANGELOG.md−6

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

33

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

55

6−0.19.2

7−------

8−

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

10−

1160.19.1

127------

138

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

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

1711

18120.19

1913----

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

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

11cabal-version: 2.2

22name: servant-server

3−version: 0.19.2

3+version: 0.19.1

44

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

66category: Servant, Web

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

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

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

2525build-type: Simple

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

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

2727

2828extra-source-files:

2929 CHANGELOG.md

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

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

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

6262 build-depends:

63− base >= 4.9 && < 4.18

63+ base >= 4.9 && < 4.17

6464 , bytestring >= 0.10.8.1 && < 0.12

6565 , constraints >= 0.2 && < 0.14

6666 , containers >= 0.5.7.1 && < 0.7

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

67+ , mtl >= 2.2.2 && < 2.3

6868 , text >= 1.2.3.0 && < 2.1

69− , transformers >= 0.5.2.0 && < 0.7

69+ , transformers >= 0.5.2.0 && < 0.6

7070 , filepath >= 1.4.1.1 && < 1.5

7171

7272 -- Servant dependencies

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

7474 build-depends:

75− servant >= 0.19 && < 0.20

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

75+ servant >= 0.19

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

7777

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

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

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

8888 , network >= 2.8 && < 3.2

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

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

91− , resourcet >= 1.2.2 && < 1.4

91+ , resourcet >= 1.2.2 && < 1.3

9292 , tagged >= 0.8.6 && < 0.9

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

94− , wai >= 3.2.2.1 && < 3.3

94+ , wai >= 3.2.1.2 && < 3.3

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

9696 , word8 >= 0.1.3 && < 0.2

9797

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

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

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

22{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveFunctor #-}

43{-# LANGUAGE DeriveGeneric #-}

54{-# LANGUAGE FlexibleContexts #-}

65{-# LANGUAGE FlexibleInstances #-}

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

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

4645newtype AuthHandler r usr = AuthHandler

4746 { unAuthHandler :: r -> Handler usr }

48− deriving (Functor, Generic, Typeable)

47+ deriving (Generic, Typeable)

4948

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

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

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

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

11{-# LANGUAGE AllowAmbiguousTypes #-}

22{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE CPP #-}

43{-# LANGUAGE DataKinds #-}

54{-# LANGUAGE DeriveDataTypeable #-}

65{-# LANGUAGE FlexibleContexts #-}

76{-# LANGUAGE FlexibleInstances #-}

87{-# LANGUAGE InstanceSigs #-}

9−{-# LANGUAGE LambdaCase #-}

108{-# LANGUAGE MultiParamTypeClasses #-}

119{-# LANGUAGE OverloadedStrings #-}

1210{-# LANGUAGE PolyKinds #-}

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

3634import Control.Monad

3735 (join, when)

3836import Control.Monad.Trans

39− (liftIO, lift)

37+ (liftIO)

4038import Control.Monad.Trans.Resource

41− (runResourceT, ReleaseKey)

42−import Data.Acquire

39+ (runResourceT)

4340import qualified Data.ByteString as B

4441import qualified Data.ByteString.Builder as BB

4542import qualified Data.ByteString.Char8 as BC8

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

6663import Network.Socket

6764 (SockAddr)

6865import Network.Wai

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

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

7067 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

7168 requestMethod, responseLBS, responseStream, vault)

7269import Prelude ()

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

7673 CaptureAll, Description, EmptyAPI, Fragment,

7774 FramingRender (..), FramingUnrender (..), FromSourceIO (..),

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

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

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

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

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

82− WithNamedContext, WithResource, NamedRoutes)

79+ WithNamedContext, NamedRoutes)

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

8481import Servant.API.ContentTypes

8582 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

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

9794import Web.HttpApiData

9895 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,

9996 parseUrlPieces)

100−import Data.Kind

101− (Type)

10297

10398import Servant.Server.Internal.BasicAuth

10499import Servant.Server.Internal.Context

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

117112 (AtLeastOneFragment, FragmentUnique)

118113

119114class 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.

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

125116

126117 route ::

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

250241 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

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

252243

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−

289244allowedMethodHead :: Method -> Request -> Bool

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

291246

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

653608 Fail a -> respond $ Fail a

654609 FailFatal e -> respond $ FailFatal e

655610

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−

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

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

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

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

895821-------------------------------------------------------------------------------

896822

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

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

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

903825 where

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

905827 route = error "unreachable"

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

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

944866--

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

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

947−#if __GLASGOW_HASKELL__ >= 904

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

949−#endif

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

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

951869

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

953871

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

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

2828

2929type Router env = Router' env RoutingApplication

3030

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

3231data CaptureHint = CaptureHint

3332 { captureName :: Text

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

3533 , captureType :: TypeRep

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

3734 }

3835 deriving (Show, Eq)

3936

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

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

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

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

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.

57+ -- environment and removed afterwards

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

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

7160 -- 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'.

7561 | RawRouter (env -> a)

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

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

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

115101data RouterStructure =

116102 StaticRouterStructure (Map Text RouterStructure) Int

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

122104 | RawRouterStructure

123105 | ChoiceStructure RouterStructure RouterStructure

124106 deriving (Eq, Show)

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

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

1717

1818import Control.Monad

1919 (forM_, unless, when)

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

2120import Control.Monad.Error.Class

2221 (MonadError (..))

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

2422import Data.Aeson

2523 (FromJSON, ToJSON, decode', encode)

26−import Data.Acquire

27− (Acquire, mkAcquire)

2824import qualified Data.ByteString as BS

2925import qualified Data.ByteString.Base64 as Base64

3026import Data.Char

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

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

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

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

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

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

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

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

6258import Servant.Server

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

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

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

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

6561 serveWithContext)

6662import Servant.Test.ComprehensiveAPI

6763import qualified Servant.Types.SourceT as S

6864import Test.Hspec

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

7066import Test.Hspec.Wai

71− (get, matchHeaders, matchStatus, shouldRespondWith,

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

7268 with, (<:>))

7369import qualified Test.Hspec.Wai as THW

7470

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

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

8682_ = serveWithContext comprehensiveAPI comprehensiveApiContext

8783

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

89−comprehensiveApiContext =

90− NamedContext EmptyContext :.

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

92− EmptyContext

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

85+comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext

9386

9487-- * Specs

9588

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

10497 reqBodySpec

10598 headerSpec

10699 rawSpec

107− rawMSpec

108100 alternativeSpec

109101 responseHeadersSpec

110102 uverbResponseHeadersSpec

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

613605

614606-- }}}

615607------------------------------------------------------------------------------

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

656608-- * alternativeSpec {{{

657609------------------------------------------------------------------------------

658610type AlternativeApi =

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

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

106106 type: exitcode-stdio-1.0

107107 hs-source-dirs: test

108108 main-is: Spec.hs

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

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

110110 build-depends: base

111111 , base-compat

112112 , aeson >=1.4.2.0 && <3

113− , hspec >=2.6.0 && <2.11

113+ , hspec >=2.6.0 && <2.10

114114 , QuickCheck

115115 , lens

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

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

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

5555-- >>> import Data.Typeable

5656-- >>> import GHC.Generics

5757-- >>> import Servant.API

58−-- >>> import System.Environment

5958-- >>> import Test.Hspec

6059-- >>> import Test.QuickCheck

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

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

6564-- >>> :set -XGeneralizedNewtypeDeriving

6665-- >>> :set -XOverloadedStrings

6766-- >>> :set -XTypeOperators

68−-- >>> setEnv "HSPEC_COLOR" "no"

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

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

7169-- >>> instance ToJSON User

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

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

33{-# LANGUAGE DataKinds #-}

44{-# LANGUAGE FlexibleContexts #-}

55{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE OverloadedLists #-}

76{-# LANGUAGE OverloadedStrings #-}

87{-# LANGUAGE PolyKinds #-}

98{-# LANGUAGE RankNTypes #-}

109{-# LANGUAGE ScopedTypeVariables #-}

1110{-# LANGUAGE TypeOperators #-}

12−{-# LANGUAGE TypeFamilies #-}

1311#if __GLASGOW_HASKELL__ >= 806

1412{-# LANGUAGE UndecidableInstances #-}

1513#endif

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

3230import Data.Swagger.Declare

3331import Data.Text (Text)

3432import qualified Data.Text as Text

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

3633import GHC.TypeLits

3734import Network.HTTP.Media (MediaType)

3835import Servant.API

3936import Servant.API.Description (FoldDescription,

4037 reflectDescription)

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

4238import Servant.API.Modifiers (FoldRequired)

4339

4440import Servant.Swagger.Internal.TypeLevel.API

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

153149addParam :: Param -> Swagger -> Swagger

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

155151

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

157−addTag :: Text -> Swagger -> Swagger

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

159−

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

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

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

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

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

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

306298

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−

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

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

313301 where

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

451439 & required ?~ True

452440 & schema .~ ParamBody ref

453441

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−

457442-- =======================================================================

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

459444-- =======================================================================

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

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

2929-- >>> import Control.Applicative

3030-- >>> import GHC.Generics

3131-- >>> import Test.QuickCheck

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

3332-- >>> :set -XDeriveGeneric

3433-- >>> :set -XGeneralizedNewtypeDeriving

3534-- >>> :set -XDataKinds

3635-- >>> :set -XTypeOperators

37−-- >>> setEnv "HSPEC_COLOR" "no"

3836

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

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

servant/CHANGELOG.md−5

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

22

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

44

5−0.19.1

6−------

7−

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

9−

1050.19

116----

127

servant/servant.cabal+5−6

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

11cabal-version: 2.2

22name: servant

3−version: 0.19.1

3+version: 0.19

44

55synopsis: A family of combinators for defining webservices APIs

66category: Servant, Web

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

6262 Servant.API.Vault

6363 Servant.API.Verbs

6464 Servant.API.WithNamedContext

65− Servant.API.WithResource

6665

6766 -- Types

6867 exposed-modules:

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

8180 --

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

8382 build-depends:

84− base >= 4.9 && < 4.18

83+ base >= 4.9 && < 4.17

8584 , bytestring >= 0.10.8.1 && < 0.12

8685 , constraints >= 0.2

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

86+ , mtl >= 2.2.2 && < 2.3

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

89− , transformers >= 0.5.2.0 && < 0.7

88+ , transformers >= 0.5.2.0 && < 0.6

9089 , text >= 1.2.3.0 && < 2.1

9190

9291

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

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

9594 build-depends:

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

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

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

9897

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

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

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

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

3232 module Servant.API.WithNamedContext,

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

34− module Servant.API.WithResource,

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

3634

3735 -- * Actual endpoints, distinguished by HTTP method

3836 module Servant.API.Verbs,

@@ -103,23 +101,21 @@ import Servant.API.Experimental.Auth

103101 (AuthProtect)

104102import Servant.API.Fragment

105103 (Fragment)

106−import Servant.API.Generic

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

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

109104import Servant.API.Header

110105 (Header, Header')

106+import Servant.API.Generic

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

108+ GenericServant, fromServant, toServant, genericApi)

111109import Servant.API.HttpVersion

112110 (HttpVersion (..))

113111import Servant.API.IsSecure

114112 (IsSecure (..))

115113import Servant.API.Modifiers

116114 (Lenient, Optional, Required, Strict)

117−import Servant.API.NamedRoutes

118− (NamedRoutes)

119115import Servant.API.QueryParam

120116 (QueryFlag, QueryParam, QueryParam', QueryParams)

121117import Servant.API.Raw

122− (Raw, RawM)

118+ (Raw)

123119import Servant.API.RemoteHost

124120 (RemoteHost)

125121import Servant.API.ReqBody

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

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

142138import Servant.API.Vault

143139 (Vault)

140+import Servant.API.NamedRoutes

141+ (NamedRoutes)

144142import Servant.API.Verbs

145143 (Delete, DeleteAccepted, DeleteNoContent,

146144 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

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

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

153151import Servant.API.WithNamedContext

154152 (WithNamedContext)

155−import Servant.API.WithResource

156− (WithResource)

157153import Servant.Links

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

159155import Web.HttpApiData

servant/src/Servant/API/ContentTypes.hs+1−1

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

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

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

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

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

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

299299 where

300300 pctyp = Proxy :: Proxy ctyp

301301

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

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

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

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

1717data 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,7 +8,6 @@

88{-# LANGUAGE PolyKinds #-}

99{-# LANGUAGE ScopedTypeVariables #-}

1010{-# LANGUAGE TypeFamilies #-}

11−{-# LANGUAGE TypeFamilyDependencies #-}

1211{-# LANGUAGE TypeOperators #-}

1312{-# LANGUAGE UndecidableInstances #-}

1413{-# OPTIONS_HADDOCK not-home #-}

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

5251import Prelude.Compat

5352import Servant.API.Header

5453 (Header)

55−import Servant.API.UVerb.Union

56−import qualified Data.SOP.BasicFunctors as SOP

57−import qualified Data.SOP.NS as SOP

5854

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

6056-- Instead, use 'addOptionalHeader'.

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

174170 => AddHeader h v a new where

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

176172

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−

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

197174-- the value in the following ways:

198175--

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

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

110110--

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

112112-- ...

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

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

114114-- ...

115115--

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

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

151151--

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

153153-- ...

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

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

155155-- ...

156156--

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

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

174174--

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

176176-- ...

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

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

178178-- ...

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

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

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

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

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

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

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

41−import Servant.API.ResponseHeaders (Headers)

4241import Servant.API.UVerb.Union

4342

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

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

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

8887 type StatusOf (WithStatus n a) = n

8988

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

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

9289

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

9491--

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

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

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

129129

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

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

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

133131 Elem _ '[] = 'False

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

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

134134

135135type family Unique xs :: Constraint where

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

servant/src/Servant/API/WithResource.hsdeleted−3

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

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

2−

3−data WithResource res

servant/src/Servant/Links.hs+4−25

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

11{-# LANGUAGE AllowAmbiguousTypes #-}

22{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE CPP #-}

43{-# LANGUAGE DataKinds #-}

54{-# LANGUAGE FlexibleContexts #-}

65{-# LANGUAGE FlexibleInstances #-}

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

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

9392-- >>> safeLink api bad_link

9493-- ...

95−-- ...Could not ...

94+-- ...Could not deduce...

9695-- ...

9796--

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

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

175174import Servant.API.QueryParam

176175 (QueryFlag, QueryParam', QueryParams)

177176import Servant.API.Raw

178− (Raw, RawM)

177+ (Raw)

179178import Servant.API.RemoteHost

180179 (RemoteHost)

181180import Servant.API.ReqBody

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

193192 (Verb, NoContentVerb)

194193import Servant.API.WithNamedContext

195194 (WithNamedContext)

196−import Servant.API.WithResource

197− (WithResource)

198195import Web.HttpApiData

199−import Data.Kind

200− (Type)

201196

202197-- | A safe link datatype.

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

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

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

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

562557

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−

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

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

569560 toLink = simpleToLink (Proxy :: Proxy sub)

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

589580 type MkLink Raw a = a

590581 toLink toA _ = toA

591582

592−instance HasLink RawM where

593− type MkLink RawM a = a

594− toLink toA _ = toA

595−

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

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

598585 toLink toA _ = toA

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

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

661648

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

663−instance TypeError (PartialApplication

664−#if __GLASGOW_HASKELL__ >= 904

665− @(Type -> Constraint)

666−#endif

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

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

668651 where

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

670653 toLink = error "unreachable"

671654

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

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

674−#if __GLASGOW_HASKELL__ >= 904

675− @(Type -> Constraint)

676−#endif

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

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

678657

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

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

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

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

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

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

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

7675 :<|> endpoint

7776

7877type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DeriveFunctor #-}

32{-# LANGUAGE GADTs #-}

43{-# LANGUAGE RankNTypes #-}

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

155154-- | >>> lift [1,2,3] :: StepT [] Int

156155-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]

157156--

158−#if !MIN_VERSION_transformers(0,6,0)

159157instance MonadTrans StepT where

160158 lift = Effect . fmap (`Yield` Stop)

161−#endif

162159

163160instance MFunctor StepT where

164161 hoist f = go where

servant/test/Servant/API/ContentTypesSpec.hs−11

@@ -33,8 +33,6 @@ import Data.String.Conversions

3333import qualified Data.Text as TextS

3434import qualified Data.Text.Encoding as TextSE

3535import qualified Data.Text.Lazy as TextL

36−import Control.Exception

37− (evaluate)

3836import GHC.Generics

3937import Test.Hspec

4038import Test.QuickCheck

@@ -80,15 +78,6 @@ spec = describe "Servant.API.ContentTypes" $ do

8078 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

8179 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

8280

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−

9281 describe "The PlainText Content-Type type" $ do

9382 let p = Proxy :: Proxy PlainText

9483

servant/test/Servant/API/ResponseHeadersSpec.hs−11

@@ -2,14 +2,10 @@

22{-# LANGUAGE OverloadedStrings #-}

33module Servant.API.ResponseHeadersSpec where

44

5−import Data.Proxy

6−import GHC.TypeLits

75import Test.Hspec

86

9−import Servant.API.ContentTypes

107import Servant.API.Header

118import Servant.API.ResponseHeaders

12−import Servant.API.UVerb

139

1410spec :: Spec

1511spec = describe "Servant.API.ResponseHeaders" $ do

@@ -32,10 +28,3 @@ spec = describe "Servant.API.ResponseHeaders" $ do

3228 it "does not add a header" $ do

3329 let val = noHeader 5 :: Headers '[Header "test" Int] Int

3430 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−