3989867...master · servant

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

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

2020 - "8.10.7"

2121 - "9.0.2"

2222 - "9.2.2"

23+ - "9.4.2"

2324

2425 steps:

2526 - uses: actions/checkout@v2

@@ -59,9 +60,6 @@ jobs:

5960 cabal test all

6061

6162 - name: Run doctests

62− # doctests are broken on GHC 9 due to compiler bug:

63− # https://gitlab.haskell.org/ghc/ghc/-/issues/19460

64− continue-on-error: ${{ matrix.ghc == '9.0.1' }}

6563 run: |

6664 # Necessary for doctest to be found in $PATH

6765 export PATH="$HOME/.cabal/bin:$PATH"

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

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

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

8078

81− stack:

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

83− runs-on: ubuntu-latest

84− strategy:

85− matrix:

86− stack: ["2.7.3"]

87− ghc: ["8.10.7"]

88−

89− steps:

90− - uses: actions/checkout@v2

91−

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

93− name: Setup Haskell Stack

94− with:

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

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

97−

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

99− name: Cache ~/.stack

100− with:

101− path: ~/.stack

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

103−

104− - name: Install dependencies

105− run: |

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

107−

108− - name: Build

109− run: |

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

111−

112− - name: Test

113− run: |

114− stack test --system-ghc

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

115113

116114 ghcjs:

117115 name: ubuntu-latest / ghcjs 8.6

cabal.project+1−7

@@ -47,14 +47,8 @@ packages:

4747 doc/cookbook/using-custom-monad

4848 doc/cookbook/using-free-client

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

50+ doc/cookbook/managed-resource

5051

5152tests: True

5253optimization: False

5354-- reorder-goals: True

54−

55−-- https://github.com/chordify/haskell-servant-pagination/pull/12

56−allow-newer: servant-pagination-2.2.2:servant

57−allow-newer: servant-pagination-2.2.2:servant-server

58−

59−allow-newer: servant-multipart:bytestring

60−allow-newer: servant-multipart-api:bytestring

changelog.d/1556new file+81

@@ -0,0 +1,81 @@

1+synopsis: Display capture hints in router layout

2+prs: #1556

3+

4+description: {

5+

6+This PR enhances the `Servant.Server.layout` function, which produces a textual description of the routing layout of an API. More precisely, it changes `<capture>` blocks, so that they display the name and type of the variable being captured instead.

7+

8+Example:

9+

10+For the following API

11+```haskell

12+type API =

13+ "a" :> "d" :> Get '[JSON] NoContent

14+ :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool

15+ :<|> "a" :> "e" :> Get '[JSON] Int

16+```

17+

18+we previously got the following output:

19+

20+```

21+/

22+├─ a/

23+│ ├─ d/

24+│ │ └─•

25+│ └─ e/

26+│ └─•

27+└─ b/

28+ └─ <capture>/

29+ ├─•

30+ ┆

31+ └─•

32+```

33+

34+now we get:

35+

36+```

37+/

38+├─ a/

39+│ ├─ d/

40+│ │ └─•

41+│ └─ e/

42+│ └─•

43+└─ b/

44+ └─ <x::Int>/

45+ ├─•

46+ ┆

47+ └─•

48+```

49+

50+This change is achieved by the introduction of a CaptureHint type, which is passed as an extra argument to the CaptureRouter and CaptureAllRouter constructors for the Router' type.

51+CaptureHint values are then used in routerLayout, to display the name and type of captured values, instead of just `<capture>` previously.

52+

53+N.B.:

54+Because the choice smart constructor for routers can aggregate Capture combinators with different capture hints, the Capture*Router constructors actually take a list of CaptureHint, instead of a single one.

55+

56+This PR also introduces Spec tests for the routerLayout function.

57+

58+Warning:

59+This change is potentially breaking, because it adds the constraint `Typeable a` to all types that are to be captured. Because all types are typeable since GHC 7.10, this is not as bad as it sounds ; it only break expressions where `a` is quantified in an expression with `Capture a`.

60+In those cases, the fix is easy: it suffices to add `Typeable a` to the left-hand side of the quantification constraint.

61+

62+For instance, the following code will no longer compile:

63+```haskell

64+type MyAPI a = Capture "foo" a :> Get '[JSON] ()

65+

66+myServer :: forall a. Server (MyAPI a)

67+myServer = const $ return ()

68+

69+myApi :: forall a. Proxy (MyAPI a)

70+myApi = Proxy

71+

72+app :: forall a. (FromHttpApiData a) => Application

73+app = serve (myApi @a) (myServer @a)

74+```

75+

76+Indeed, `app` should be replaced with:

77+```haskell

78+app :: forall a. (FromHttpApiData a, Typeable a) => Application

79+app = serve (myApi @a) (myServer @a)

80+```

81+}

changelog.d/1569new file+13

@@ -0,0 +1,13 @@

1+synopsis: Encode captures using toEncodedUrlPiece

2+prs: #1569

3+issues: #1511

4+

5+description: {

6+The `servant-client` library now makes direct use of `toEncodedUrlPiece` from `ToHttpApiData`

7+to encode captured values when building the request path. It gives user freedom to implement

8+URL-encoding however they need.

9+

10+Previous behavior was to use `toUrlPiece` and URL-encode its output using `toEncodedUrlPiece`

11+from the `Text` instance of `ToHttpApiData`. The issue with this approach is that

12+`ToHttpApiData Text` is overly zealous and also encodes characters, such as `*`, which are perfectly valid in a URL.

13+}

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/curl-mock/curl-mock.cabal+3

@@ -11,6 +11,9 @@ build-type: Simple

1111tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7

1212

1313executable cookbock-curl-mock

14+ if impl(ghc >= 9.2)

15+ -- generic-arbitrary is incompatible

16+ buildable: False

1417 main-is: CurlMock.lhs

1518 build-depends: base == 4.*

1619 , aeson

doc/cookbook/index.rst+1

@@ -37,3 +37,4 @@ 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.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 {

330330```

331331

332332Here 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.

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− let req' = I.defaultMakeClientRequest burl req

122+ 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 at the problem. It is inspired by

202+another shot 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,3 +1,4 @@

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

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

34+ base >= 4.10 && < 4.18

3535 , bytestring >= 0.10.6.0 && < 0.12

3636 , containers >= 0.5.6.2 && < 0.7

3737 , servant-auth == 0.4.*

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

5050 test

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

5252 ghc-options: -Wall

53− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9

53+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10

5454

5555 -- dependencies with bounds inherited from the library stanza

5656 build-depends:

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

6262

6363 -- test dependencies

6464 build-depends:

65− hspec >= 2.5.5 && < 2.9

65+ hspec >= 2.5.5 && < 2.10

6666 , QuickCheck >= 2.11.3 && < 2.15

6767 , aeson >= 1.3.1.1 && < 3

6868 , bytestring >= 0.10.6.0 && < 0.12

@@ -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.7.0.0 && < 0.10

77+ , jose >= 0.10 && < 0.11

7878 other-modules:

7979 Servant.Auth.ClientSpec

8080 default-language: Haskell2010

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

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

38+ base >= 4.10 && < 4.18

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

42+ , lens >= 4.16.1 && <5.3

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.19,

53+ doctest >= 0.16 && < 0.21,

5454 QuickCheck >= 2.11.3 && < 2.15,

5555 template-haskell

5656 ghc-options: -Wall -threaded

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

6464 test

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

6666 ghc-options: -Wall

67− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9

67+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10

6868

6969 -- dependencies with bounds inherited from the library stanza

7070 build-depends:

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

7878 -- test dependencies

7979 build-depends:

8080 servant-auth-docs

81− , hspec >= 2.5.5 && < 2.9

81+ , hspec >= 2.5.5 && < 2.10

8282 , QuickCheck >= 2.11.3 && < 2.15

8383

8484 default-language: Haskell2010

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

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

34+ base >= 4.10 && < 4.18

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.7.0.0 && < 0.10

45− , lens >= 4.16.1 && < 5.2

46− , memory >= 0.14.16 && < 0.18

44+ , jose >= 0.10 && < 0.11

45+ , lens >= 4.16.1 && < 5.3

46+ , memory >= 0.14.16 && < 0.19

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

48− , mtl >= 2.2.2 && < 2.3

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

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

54+ , time >= 1.5.0.1 && < 1.13

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

5656 , wai >= 3.2.1.2 && < 3.3

5757

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

102102 test

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

104104 ghc-options: -Wall

105− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.8

105+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10

106106

107107 -- dependencies with bounds inherited from the library stanza

108108 build-depends:

@@ -123,12 +123,13 @@ test-suite spec

123123 -- test dependencies

124124 build-depends:

125125 servant-auth-server

126− , hspec >= 2.5.5 && < 2.8

126+ , hspec >= 2.5.5 && < 2.10

127127 , QuickCheck >= 2.11.3 && < 2.15

128128 , http-client >= 0.5.13.1 && < 0.8

129− , lens-aeson >= 1.0.2 && < 1.2

129+ , 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

132133 other-modules:

133134 Servant.Auth.ServerSpec

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

5454

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

5656 makeCookies authResult = do

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

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)

6663

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

6865 -> (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 (..))

1111import qualified Network.HTTP.Types as HTTP

1212import Network.Wai (mapResponseHeaders)

1313import Servant

14+import Servant.API.UVerb.Union

1415import Servant.API.Generic

1516import Servant.Server.Generic

1617import Web.Cookie

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

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

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

3536

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+

3643type family AddSetCookieApi a :: *

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

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

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

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

48+#endif

4049type instance AddSetCookieApi (Verb method stat ctyps a)

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

4255type instance AddSetCookieApi Raw = Raw

4356#if MIN_VERSION_servant_server(0,15,0)

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

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

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

5871 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

5972

60−instance AddSetCookies 'Z orig orig where

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

6174 addSetCookies _ = id

6275

6376instance {-# 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 :: Jose.JWKSet

36+ , validationKeys :: IO 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 = Jose.JWKSet [k]

47+ , validationKeys = pure $ 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,6 +2,7 @@

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

33

44import Blaze.ByteString.Builder (toByteString)

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

56import Control.Monad.Except

67import Control.Monad.Reader

78import qualified Crypto.JOSE as Jose

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

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

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

22

33import Control.Lens

4−import Control.Monad.Except

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

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)

108import Data.ByteArray (constEq)

119import qualified Data.ByteString as BS

1210import qualified Data.ByteString.Lazy as BSL

13−import qualified Data.HashMap.Strict as HM

1411import Data.Maybe (fromMaybe)

15−import qualified Data.Text as T

1612import Data.Time (UTCTime)

1713import Network.Wai (requestHeaders)

1814

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

4238-- token expires.

4339makeJWT :: ToJWT a

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

4642 bestAlg <- Jose.bestJWSAlg $ signingKey cfg

4743 let alg = fromMaybe bestAlg $ jwtAlg cfg

4844 ejwt <- Jose.signClaims (signingKey cfg)

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

5854

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

6056verifyJWT jwtCfg input = do

61− verifiedJWT <- liftIO $ runExceptT $ do

57+ keys <- validationKeys jwtCfg

58+ verifiedJWT <- Jose.runJOSE $ do

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

6360 Jose.verifyClaims

6461 (jwtSettingsToJwtValidationSettings jwtCfg)

65− (validationKeys jwtCfg)

62+ keys

6663 unverifiedJWT

6764 return $ case verifiedJWT of

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

6966 Right v -> case decodeJWT v of

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

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

33

44import Control.Applicative

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

56import Control.Monad.Reader

67import Control.Monad.Time

78import Data.Monoid (Monoid (..))

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

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

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE TypeApplications #-}

23module Servant.Auth.ServerSpec (spec) where

34

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

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

67#endif

78

89import 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)

15+ genJWK, newJWSHeader, runJOSE)

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

1717 NumericDate (NumericDate),

1818 SignedJWT,

@@ -25,6 +25,7 @@ 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)

2829import Data.CaseInsensitive (mk)

2930import Data.Foldable (find)

3031import Data.Monoid

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

4041import Network.Wai (responseLBS)

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

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

44+ checkResponse,

4345 cookieExpiryTime, cookies,

4446 defaults, get, getWith, postWith,

4547 header, oauth2Bearer,

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

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

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

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

186− opts <- addJwtToCookie cookieCfg jwt

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

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+

188203

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

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

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

406421 = Auth auths User :>

407422 ( Get '[JSON] Int

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

409− :<|> NamedRoutes DummyRoutes

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

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

411426#if MIN_VERSION_servant_server(0,15,0)

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

413428#endif

414429 :<|> "raw" :> Raw

415430 )

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

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

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

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

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

490506 :<|> raw

491507 Indefinite -> throwAll err401

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

493514 )

494515 :<|> getLogin

495516 :<|> getLogout

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

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

541562

542563createJWT :: 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

544565

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

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

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

570591 = fmap cookie_name (destroyCookieJar cj)

571592 `shouldMatchList` patterns

572593

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+

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

574601shouldMatchCookieNameValues cj patterns

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

servant-auth/servant-auth-swagger/servant-auth-swagger.cabal+4−8

@@ -31,15 +31,13 @@ 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.16

34+ base >= 4.10 && < 4.18

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

41− if impl(ghc >= 9)

42− buildable: False

40+ , lens >= 4.16.1 && < 5.3

4341 exposed-modules:

4442 Servant.Auth.Swagger

4543 default-language: Haskell2010

@@ -51,7 +49,7 @@ test-suite spec

5149 test

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

5351 ghc-options: -Wall

54− build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.9

52+ build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.10

5553 -- dependencies with bounds inherited from the library stanza

5654 build-depends:

5755 base

@@ -61,13 +59,11 @@ test-suite spec

6159 , servant

6260 , servant-auth

6361 , lens

64− if impl(ghc >= 9)

65− buildable: False

6662

6763 -- test dependencies

6864 build-depends:

6965 servant-auth-swagger

70− , hspec >= 2.5.5 && < 2.9

66+ , hspec >= 2.5.5 && < 2.10

7167 , QuickCheck >= 2.11.3 && < 2.15

7268 other-modules:

7369 Servant.Auth.SwaggerSpec

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

36+ base >= 4.10 && < 4.18

3737 , containers >= 0.6 && < 0.7

3838 , aeson >= 1.3.1.1 && < 3

39− , jose >= 0.7.0.0 && < 0.10

40− , lens >= 4.16.1 && < 5.2

39+ , jose >= 0.10 && < 0.11

40+ , lens >= 4.16.1 && < 5.3

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 the Authorization header:

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

3131--

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

3333--

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

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

53+ base >= 4.9 && < 4.18

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

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

59+ , transformers >= 0.5.2.0 && < 0.7

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

6161

6262 if !impl(ghc >= 8.2)

6363 build-depends:

@@ -104,8 +104,8 @@ test-suite spec

104104 -- Additional dependencies

105105 build-depends:

106106 deepseq >= 1.4.2.0 && < 1.5

107− , hspec >= 2.6.0 && < 2.9

107+ , hspec >= 2.6.0 && < 2.10

108108 , QuickCheck >= 2.12.6.1 && < 2.15

109109

110110 build-tool-depends:

111− hspec-discover:hspec-discover >= 2.6.0 && <2.9

111+ hspec-discover:hspec-discover >= 2.6.0 && <2.10

servant-client-core/src/Servant/Client/Core/HasClient.hs+30−12

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

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

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

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

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

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

8181 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)

8282import Servant.API.Generic

8383 (GenericMode(..), ToServant, ToServantApi

@@ -208,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)

208208 clientWithRoute pm (Proxy :: Proxy api)

209209 (appendToPath p req)

210210

211− where p = (toUrlPiece val)

211+ where p = toEncodedUrlPiece val

212212

213213 hoistClientMonad pm _ f cl = \a ->

214214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

@@ -243,7 +243,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)

243243 clientWithRoute pm (Proxy :: Proxy sublayout)

244244 (foldl' (flip appendToPath) req ps)

245245

246− where ps = map (toUrlPiece) vals

246+ where ps = map toEncodedUrlPiece vals

247247

248248 hoistClientMonad pm _ f cl = \as ->

249249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)

@@ -674,6 +674,16 @@ 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+

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

678688-- the corresponding querying function will automatically take

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

@@ -740,7 +750,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where

740750 clientWithRoute pm (Proxy :: Proxy api)

741751 (appendToPath p req)

742752

743− where p = pack $ symbolVal (Proxy :: Proxy path)

753+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)

744754

745755 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

746756

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

776786

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

778788

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+

779797instance ( HasClient m api

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

781799 type Client m (AuthProtect tag :> api)

@@ -874,7 +892,7 @@ infixl 2 /:

874892--

875893-- Example:

876894--

877−-- @@

895+-- @

878896-- type Api = NamedRoutes RootApi

879897--

880898-- data RootApi mode = RootApi

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

894912-- rootClient = client api

895913--

896914-- endpointClient :: ClientM Person

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

898−-- @@

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

916+-- @

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

900918x // f = f x

901919

@@ -906,7 +924,7 @@ x // f = f x

906924--

907925-- Example:

908926--

909−-- @@

927+-- @

910928-- type Api = NamedRoutes RootApi

911929--

912930-- data RootApi mode = RootApi

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

927945-- rootClient = client api

928946--

929947-- hello :: String -> ClientM String

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

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

931949--

932950-- endpointClient :: ClientM Person

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

934−-- @@

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

952+-- @

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

936954(/:) = flip

937955

servant-client-core/src/Servant/Client/Core/Request.hs+6−3

@@ -34,6 +34,8 @@ import Data.Bifunctor

3434import Data.Bitraversable

3535 (Bitraversable (..), bifoldMapDefault, bimapDefault)

3636import qualified Data.ByteString as BS

37+import Data.ByteString.Builder

38+ (Builder)

3739import qualified Data.ByteString.Builder as Builder

3840import qualified Data.ByteString.Lazy as LBS

3941import qualified Data.Sequence as Seq

@@ -112,7 +114,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where

112114 rnfB Nothing = ()

113115 rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt

114116

115−type Request = RequestF RequestBody Builder.Builder

117+type Request = RequestF RequestBody Builder

116118

117119-- | The request body. R replica of the @http-client@ @RequestBody@.

118120data RequestBody

@@ -145,9 +147,10 @@ defaultRequest = Request

145147

146148-- | Append extra path to the request being constructed.

147149--

148−appendToPath :: Text -> Request -> Request

150+-- Warning: This function assumes that the path fragment is already URL-encoded.

151+appendToPath :: Builder -> Request -> Request

149152appendToPath p req

150− = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }

153+ = req { requestPath = requestPath req <> "/" <> p }

151154

152155-- | Append a query parameter to the request being constructed.

153156--

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

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

5252 , semigroupoids >=5.3 && <5.4

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

5454 , transformers >=0.3 && <0.6

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

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

44+ base >= 4.9 && < 4.18

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

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

4949 , stm >= 2.4.5.1 && < 2.6

5050 , text >= 1.2.3.0 && < 2.1

51− , time >= 1.6.0.1 && < 1.12

52− , transformers >= 0.5.2.0 && < 0.6

51+ , time >= 1.6.0.1 && < 1.13

52+ , transformers >= 0.5.2.0 && < 0.7

5353

5454 if !impl(ghc >= 8.2)

5555 build-depends:

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

124124 -- Additional dependencies

125125 build-depends:

126126 entropy >= 0.4.1.3 && < 0.5

127− , hspec >= 2.6.0 && < 2.9

127+ , hspec >= 2.6.0 && < 2.10

128128 , HUnit >= 1.6.0.0 && < 1.7

129129 , network >= 2.8.0.0 && < 3.2

130130 , QuickCheck >= 2.12.6.1 && < 2.15

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

133133 , tdigest >= 0.2 && < 0.3

134134

135135 build-tool-depends:

136− hspec-discover:hspec-discover >= 2.6.0 && < 2.9

136+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10

137137

138138test-suite readme

139139 type: exitcode-stdio-1.0

servant-client/src/Servant/Client/Internal/HttpClient.hs+8−7

@@ -24,7 +24,7 @@ import Control.Monad

2424import Control.Monad.Base

2525 (MonadBase (..))

2626import Control.Monad.Catch

27− (MonadCatch, MonadThrow)

27+ (MonadCatch, MonadThrow, MonadMask)

2828import Control.Monad.Error.Class

2929 (MonadError (..))

3030import Control.Monad.IO.Class

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

8080 { manager :: Client.Manager

8181 , baseUrl :: BaseUrl

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

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

83+ , makeClientRequest :: BaseUrl -> Request -> IO 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,

@@ -136,7 +136,7 @@ newtype ClientM a = ClientM

136136 { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }

137137 deriving ( Functor, Applicative, Monad, MonadIO, Generic

138138 , MonadReader ClientEnv, MonadError ClientError, MonadThrow

139− , MonadCatch)

139+ , MonadCatch, MonadMask)

140140

141141instance MonadBase IO ClientM where

142142 liftBase = ClientM . liftBase

@@ -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− let clientRequest = createClientRequest burl req

165+ clientRequest <- liftIO $ 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 -> Client.Request

233−defaultMakeClientRequest burl r = Client.defaultRequest

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

233+defaultMakeClientRequest burl r = return Client.defaultRequest

234234 { Client.method = requestMethod r

235235 , Client.host = fromString $ baseUrlHost burl

236236 , Client.port = baseUrlPort burl

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

289289 Https -> True

290290

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

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

292+ buildQueryString [] = mempty

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

293294

294295 addQueryParam qs (k, v) =

295296 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

2424 (NFData, force)

2525import Control.Exception

2626 (evaluate, throwIO)

27−import Control.Monad ()

27+import Control.Monad

28+ (unless)

2829import Control.Monad.Base

2930 (MonadBase (..))

3031import Control.Monad.Codensity

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

140141performRequest acceptStatus req = do

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

142143 ClientEnv m burl cookieJar' createClientRequest <- ask

143− let clientRequest = createClientRequest burl req

144+ clientRequest <- liftIO $ createClientRequest burl req

144145 request <- case cookieJar' of

145146 Nothing -> pure clientRequest

146147 Just cj -> liftIO $ do

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

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

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

176177performWithStreamingRequest req k = do

177− m <- asks manager

178− burl <- asks baseUrl

179− createClientRequest <- asks makeClientRequest

180− let request = createClientRequest burl req

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

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

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

183195 let status = Client.responseStatus res

servant-client/test/Servant/ClientTestUtils.hs+13−1

@@ -160,6 +160,7 @@ type Api =

160160 WithStatus 301 Text]

161161 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]

162162 :<|> NamedRoutes RecordRoutes

163+ :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text

163164

164165api :: Proxy Api

165166api = Proxy

@@ -214,7 +215,8 @@ getRoot

214215 :<|> EmptyClient

215216 :<|> uverbGetSuccessOrRedirect

216217 :<|> uverbGetCreated

217− :<|> recordRoutes = client api

218+ :<|> recordRoutes

219+ :<|> captureVerbatim = client api

218220

219221server :: Application

220222server = serve api (

@@ -259,6 +261,7 @@ server = serve api (

259261 { something = pure ["foo", "bar", "pweet"]

260262 }

261263 }

264+ :<|> pure . decodeUtf8 . unVerbatim

262265 )

263266

264267-- * api for testing failures

@@ -370,3 +373,12 @@ instance ToHttpApiData UrlEncodedByteString where

370373

371374instance FromHttpApiData UrlEncodedByteString where

372375 parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8

376+

377+newtype Verbatim = Verbatim { unVerbatim :: ByteString }

378+

379+instance ToHttpApiData Verbatim where

380+ toEncodedUrlPiece = byteString . unVerbatim

381+ toUrlPiece = decodeUtf8 . unVerbatim

382+

383+instance FromHttpApiData Verbatim where

384+ parseUrlPiece = pure . Verbatim . encodeUtf8

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

@@ -36,6 +36,8 @@ import Data.Maybe

3636import Data.Monoid ()

3737import Data.Text

3838 (Text)

39+import Data.Text.Encoding

40+ (encodeUtf8)

3941import qualified Network.HTTP.Client as C

4042import qualified Network.HTTP.Types as HTTP

4143import Test.Hspec

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

160162 mgr <- C.newManager C.defaultManagerSettings

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

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

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

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

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

166169 case res of

@@ -196,3 +199,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

196199 case eitherResponse of

197200 Left clientError -> fail $ show clientError

198201 Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)

202+

203+ it "encodes URL pieces following ToHttpApiData instance" $ \(_, baseUrl) -> do

204+ let textOrig = "*"

205+ eitherResponse <- runClient (captureVerbatim $ Verbatim $ encodeUtf8 textOrig) baseUrl

206+ case eitherResponse of

207+ Left clientError -> fail $ show clientError

208+ Right textBack -> textBack `shouldBe` textOrig

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

35− , resourcet >=1.2.2 && <1.3

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

35+ , resourcet >=1.2.2 && <1.4

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,6 +530,24 @@

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+

533551## GET /streaming

534552

535553### 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.17

44+ base >= 4.9 && < 4.18

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

62+ , lens >= 4.17 && < 5.3

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+8−1

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

6262import Servant.API

6363import Servant.API.ContentTypes

6464import Servant.API.TypeLevel

65+import Servant.API.Generic

6566

6667import qualified Data.Universe.Helpers as U

6768

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

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

447448

448449

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

450451-- number of introduction(s)

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

452453docsWithIntros intros = docsWith defaultDocOptions intros mempty

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

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

11441145 docsFor Proxy = docsFor (Proxy :: Proxy api)

11451146

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

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

1149+

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

11471151 docsFor Proxy (endpoint, action) =

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

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

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

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

11521156

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

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

1159+

11531160-- ToSample instances for simple types

11541161instance ToSample NoContent

11551162instance ToSample Bool

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

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

44+ base >= 4.9 && < 4.18

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

55+ , lens >= 4.17 && < 5.3

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

5757

5858 hs-source-dirs: src

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

7474

7575 -- Additional dependencies

7676 build-depends:

77− hspec >= 2.6.0 && <2.9

77+ hspec >= 2.6.0 && <2.10

7878 build-tool-depends:

79− hspec-discover:hspec-discover >=2.6.0 && <2.9

79+ hspec-discover:hspec-discover >=2.6.0 && <2.10

8080 default-language: Haskell2010

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

@@ -487,6 +487,13 @@ 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+

490497instance HasForeign lang ftype api

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

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

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

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

41+ base >= 4.9 && < 4.18

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

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

4646 , text >= 1.2.3.0 && < 2.1

47− , time >= 1.6.0.1 && < 1.12

48− , transformers >= 0.5.2.0 && < 0.6

47+ , time >= 1.6.0.1 && < 1.13

48+ , transformers >= 0.5.2.0 && < 0.7

4949

5050 if !impl(ghc >= 8.2)

5151 build-depends:

@@ -72,7 +72,7 @@ library

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

7373 , semigroupoids >= 5.3.1 && < 5.4

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

75− , transformers-compat >= 0.6.2 && < 0.7

75+ , transformers-compat >= 0.6.2 && < 0.8

7676

7777 hs-source-dirs: src

7878 default-language: Haskell2010

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

112112 -- Additional dependencies

113113 build-depends:

114114 entropy >= 0.4.1.3 && < 0.5

115− , hspec >= 2.6.0 && < 2.9

115+ , hspec >= 2.6.0 && < 2.10

116116 , HUnit >= 1.6.0.0 && < 1.7

117117 , network >= 2.8.0.0 && < 3.2

118118 , QuickCheck >= 2.12.6.1 && < 2.15

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

121121 , tdigest >= 0.2 && < 0.3

122122

123123 build-tool-depends:

124− hspec-discover:hspec-discover >= 2.6.0 && < 2.9

124+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10

125125

126126test-suite readme

127127 type: exitcode-stdio-1.0

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

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

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

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

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

3737 , servant >=0.15 && <0.20

3838 hs-source-dirs: src

servant-server/CHANGELOG.md+9−2

@@ -3,10 +3,17 @@

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

7−----------

6+0.19.2

7+------

8+

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

10+

11+0.19.1

12+------

813

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

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)

1017

11180.19

1219----

servant-server/example/greet.hs−1

@@ -18,7 +18,6 @@ import Network.Wai.Handler.Warp

1818

1919import Servant

2020import Servant.Server.Generic ()

21−import Servant.API.Generic

2221

2322-- * Example

2423

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

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

11cabal-version: 2.2

22name: servant-server

3−version: 0.19

3+version: 0.19.2

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

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

63+ base >= 4.9 && < 4.18

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

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

6868 , text >= 1.2.3.0 && < 2.1

69− , transformers >= 0.5.2.0 && < 0.6

69+ , transformers >= 0.5.2.0 && < 0.7

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

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

75+ servant >= 0.19 && < 0.20

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

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

91+ , resourcet >= 1.2.2 && < 1.4

9292 , tagged >= 0.8.6 && < 0.9

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

94− , wai >= 3.2.1.2 && < 3.3

94+ , wai >= 3.2.2.1 && < 3.3

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

9696 , word8 >= 0.1.3 && < 0.2

9797

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

159159 build-depends:

160160 aeson >= 1.4.1.0 && < 3

161161 , directory >= 1.3.0.0 && < 1.4

162− , hspec >= 2.6.0 && < 2.9

162+ , hspec >= 2.6.0 && < 2.10

163163 , hspec-wai >= 0.10.1 && < 0.12

164164 , QuickCheck >= 2.12.6.1 && < 2.15

165165 , should-not-typecheck >= 2.1.0 && < 2.2

@@ -167,4 +167,4 @@ test-suite spec

167167 , wai-extra >= 3.0.24.3 && < 3.2

168168

169169 build-tool-depends:

170− hspec-discover:hspec-discover >= 2.6.0 && <2.9

170+ hspec-discover:hspec-discover >= 2.6.0 && <2.10

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

@@ -235,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])

235235-- > │ └─ e/

236236-- > │ └─•

237237-- > ├─ b/

238−-- > │ └─ <capture>/

238+-- > │ └─ <x::Int>/

239239-- > │ ├─•

240240-- > │ ┆

241241-- > │ └─•

@@ -252,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])

252252--

253253-- [@─•@] Leaves reflect endpoints.

254254--

255−-- [@\<capture\>/@] This is a delayed capture of a path component.

255+-- [@\<x::Int\>/@] This is a delayed capture of a single

256+-- path component named @x@, of expected type @Int@.

256257--

257258-- [@\<raw\>@] This is a part of the API we do not know anything about.

258259--

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

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

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

22{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveFunctor #-}

34{-# LANGUAGE DeriveGeneric #-}

45{-# LANGUAGE FlexibleContexts #-}

56{-# LANGUAGE FlexibleInstances #-}

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

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

4546newtype AuthHandler r usr = AuthHandler

4647 { unAuthHandler :: r -> Handler usr }

47− deriving (Generic, Typeable)

48+ deriving (Functor, Generic, Typeable)

4849

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

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

servant-server/src/Servant/Server/Internal.hs+95−11

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

11{-# LANGUAGE AllowAmbiguousTypes #-}

22{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE CPP #-}

34{-# LANGUAGE DataKinds #-}

45{-# LANGUAGE DeriveDataTypeable #-}

56{-# LANGUAGE FlexibleContexts #-}

67{-# LANGUAGE FlexibleInstances #-}

78{-# LANGUAGE InstanceSigs #-}

9+{-# LANGUAGE LambdaCase #-}

810{-# LANGUAGE MultiParamTypeClasses #-}

911{-# LANGUAGE OverloadedStrings #-}

1012{-# LANGUAGE PolyKinds #-}

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

3436import Control.Monad

3537 (join, when)

3638import Control.Monad.Trans

37− (liftIO)

39+ (liftIO, lift)

3840import Control.Monad.Trans.Resource

39− (runResourceT)

41+ (runResourceT, ReleaseKey)

42+import Data.Acquire

4043import qualified Data.ByteString as B

4144import qualified Data.ByteString.Builder as BB

4245import qualified Data.ByteString.Char8 as BC8

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

6366import Network.Socket

6467 (SockAddr)

6568import Network.Wai

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

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

6770 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

6871 requestMethod, responseLBS, responseStream, vault)

6972import Prelude ()

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

7376 CaptureAll, Description, EmptyAPI, Fragment,

7477 FramingRender (..), FramingUnrender (..), FromSourceIO (..),

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

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

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

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

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

79− WithNamedContext, NamedRoutes)

82+ WithNamedContext, WithResource, NamedRoutes)

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

8184import Servant.API.ContentTypes

8285 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

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

9497import Web.HttpApiData

9598 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,

9699 parseUrlPieces)

100+import Data.Kind

101+ (Type)

97102

98103import Servant.Server.Internal.BasicAuth

99104import Servant.Server.Internal.Context

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

112117 (AtLeastOneFragment, FragmentUnique)

113118

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

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

116125

117126 route ::

@@ -173,7 +182,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont

173182-- > server = getBook

174183-- > where getBook :: Text -> Handler Book

175184-- > getBook isbn = ...

176−instance (KnownSymbol capture, FromHttpApiData a

185+instance (KnownSymbol capture, FromHttpApiData a, Typeable a

177186 , HasServer api context, SBoolI (FoldLenient mods)

178187 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

179188 )

@@ -185,7 +194,7 @@ instance (KnownSymbol capture, FromHttpApiData a

185194 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

186195

187196 route Proxy context d =

188− CaptureRouter $

197+ CaptureRouter [hint] $

189198 route (Proxy :: Proxy api)

190199 context

191200 (addCapture d $ \ txt -> withRequest $ \ request ->

@@ -197,6 +206,7 @@ instance (KnownSymbol capture, FromHttpApiData a

197206 where

198207 rep = typeRep (Proxy :: Proxy Capture')

199208 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

209+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))

200210

201211-- | If you use 'CaptureAll' in one of the endpoints for your API,

202212-- this automatically requires your server-side handler to be a

@@ -215,7 +225,7 @@ instance (KnownSymbol capture, FromHttpApiData a

215225-- > server = getSourceFile

216226-- > where getSourceFile :: [Text] -> Handler Book

217227-- > getSourceFile pathSegments = ...

218−instance (KnownSymbol capture, FromHttpApiData a

228+instance (KnownSymbol capture, FromHttpApiData a, Typeable a

219229 , HasServer api context

220230 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

221231 )

@@ -227,7 +237,7 @@ instance (KnownSymbol capture, FromHttpApiData a

227237 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

228238

229239 route Proxy context d =

230− CaptureAllRouter $

240+ CaptureAllRouter [hint] $

231241 route (Proxy :: Proxy api)

232242 context

233243 (addCapture d $ \ txts -> withRequest $ \ request ->

@@ -238,6 +248,43 @@ instance (KnownSymbol capture, FromHttpApiData a

238248 where

239249 rep = typeRep (Proxy :: Proxy CaptureAll)

240250 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

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

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+

241288

242289allowedMethodHead :: Method -> Request -> Bool

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

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

606653 Fail a -> respond $ Fail a

607654 FailFatal e -> respond $ FailFatal e

608655

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+

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

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

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

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

819895-------------------------------------------------------------------------------

820896

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

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

898+instance TypeError (PartialApplication

899+#if __GLASGOW_HASKELL__ >= 904

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

901+#endif

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

823903 where

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

825905 route = error "unreachable"

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

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

864944--

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

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

867951

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

869953

servant-server/src/Servant/Server/Internal/Router.hs+50−15

@@ -9,12 +9,16 @@ import Prelude.Compat

99

1010import Data.Function

1111 (on)

12+import Data.List

13+ (nub)

1214import Data.Map

1315 (Map)

1416import qualified Data.Map as M

1517import Data.Text

1618 (Text)

1719import qualified Data.Text as T

20+import Data.Typeable

21+ (TypeRep)

1822import Network.Wai

1923 (Response, pathInfo)

2024import Servant.Server.Internal.ErrorFormatter

@@ -24,6 +28,21 @@ import Servant.Server.Internal.ServerError

2428

2529type Router env = Router' env RoutingApplication

2630

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

32+data CaptureHint = CaptureHint

33+ { captureName :: Text

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

35+ , captureType :: TypeRep

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

37+ }

38+ deriving (Show, Eq)

39+

40+toCaptureTag :: CaptureHint -> Text

41+toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)

42+

43+toCaptureTags :: [CaptureHint] -> Text

44+toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"

45+

2746-- | Internal representation of a router.

2847--

2948-- The first argument describes an environment type that is

@@ -36,12 +55,23 @@ data Router' env a =

3655 -- ^ the map contains routers for subpaths (first path component used

3756 -- for lookup and removed afterwards), the list contains handlers

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

39− | CaptureRouter (Router' (Text, env) a)

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

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

41− -- environment and removed afterwards

42− | CaptureAllRouter (Router' ([Text], env) a)

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.

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

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

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

4575 | RawRouter (env -> a)

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

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

@@ -69,8 +99,8 @@ leafRouter l = StaticRouter M.empty [l]

6999choice :: Router' env a -> Router' env a -> Router' env a

70100choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =

71101 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)

72−choice (CaptureRouter router1) (CaptureRouter router2) =

73− CaptureRouter (choice router1 router2)

102+choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =

103+ CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)

74104choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3

75105choice router1 router2 = Choice router1 router2

76106

@@ -84,7 +114,11 @@ choice router1 router2 = Choice router1 router2

84114--

85115data RouterStructure =

86116 StaticRouterStructure (Map Text RouterStructure) Int

87− | CaptureRouterStructure 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.

88122 | RawRouterStructure

89123 | ChoiceStructure RouterStructure RouterStructure

90124 deriving (Eq, Show)

@@ -98,11 +132,11 @@ data RouterStructure =

98132routerStructure :: Router' env a -> RouterStructure

99133routerStructure (StaticRouter m ls) =

100134 StaticRouterStructure (fmap routerStructure m) (length ls)

101−routerStructure (CaptureRouter router) =

102− CaptureRouterStructure $

135+routerStructure (CaptureRouter hints router) =

136+ CaptureRouterStructure hints $

103137 routerStructure router

104−routerStructure (CaptureAllRouter router) =

105− CaptureRouterStructure $

138+routerStructure (CaptureAllRouter hints router) =

139+ CaptureRouterStructure hints $

106140 routerStructure router

107141routerStructure (RawRouter _) =

108142 RawRouterStructure

@@ -114,8 +148,8 @@ routerStructure (Choice r1 r2) =

114148-- | Compare the structure of two routers.

115149--

116150sameStructure :: Router' env a -> Router' env b -> Bool

117−sameStructure r1 r2 =

118− routerStructure r1 == routerStructure r2

151+sameStructure router1 router2 =

152+ routerStructure router1 == routerStructure router2

119153

120154-- | Provide a textual representation of the

121155-- structure of a router.

@@ -126,7 +160,8 @@ routerLayout router =

126160 where

127161 mkRouterLayout :: Bool -> RouterStructure -> [Text]

128162 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n

129− mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)

163+ mkRouterLayout c (CaptureRouterStructure hints r) =

164+ mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)

130165 mkRouterLayout c RawRouterStructure =

131166 if c then ["├─ <raw>"] else ["└─ <raw>"]

132167 mkRouterLayout c (ChoiceStructure r1 r2) =

@@ -169,7 +204,7 @@ runRouterEnv fmt router env request respond =

169204 -> let request' = request { pathInfo = rest }

170205 in runRouterEnv fmt router' env request' respond

171206 _ -> respond $ Fail $ fmt request

172− CaptureRouter router' ->

207+ CaptureRouter _ router' ->

173208 case pathInfo request of

174209 [] -> respond $ Fail $ fmt request

175210 -- This case is to handle trailing slashes.

@@ -177,7 +212,7 @@ runRouterEnv fmt router env request respond =

177212 first : rest

178213 -> let request' = request { pathInfo = rest }

179214 in runRouterEnv fmt router' (first, env) request' respond

180− CaptureAllRouter router' ->

215+ CaptureAllRouter _ router' ->

181216 let segments = pathInfo request

182217 request' = request { pathInfo = [] }

183218 in runRouterEnv fmt router' (segments, env) request' respond

servant-server/test/Servant/Server/RouterSpec.hs+127−6

@@ -9,7 +9,9 @@ import Control.Monad

99import Data.Proxy

1010 (Proxy (..))

1111import Data.Text

12− (unpack)

12+ (Text, unpack)

13+import Data.Typeable

14+ (typeRep)

1315import Network.HTTP.Types

1416 (Status (..))

1517import Network.Wai

@@ -27,6 +29,7 @@ spec :: Spec

2729spec = describe "Servant.Server.Internal.Router" $ do

2830 routerSpec

2931 distributivitySpec

32+ serverLayoutSpec

3033

3134routerSpec :: Spec

3235routerSpec = do

@@ -51,7 +54,7 @@ routerSpec = do

5154 toApp = toApplication . runRouter (const err404)

5255

5356 cap :: Router ()

54− cap = CaptureRouter $

57+ cap = CaptureRouter [hint] $

5558 let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)

5659 in leafRouter

5760 $ \env req res ->

@@ -59,6 +62,9 @@ routerSpec = do

5962 . const

6063 $ Route success

6164

65+ hint :: CaptureHint

66+ hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())

67+

6268 router :: Router ()

6369 router = leafRouter (\_ _ res -> res $ Route success)

6470 `Choice` cap

@@ -98,12 +104,30 @@ distributivitySpec =

98104 it "properly handles mixing static paths at different levels" $ do

99105 level `shouldHaveSameStructureAs` levelRef

100106

107+serverLayoutSpec :: Spec

108+serverLayoutSpec =

109+ describe "serverLayout" $ do

110+ it "correctly represents the example API" $ do

111+ exampleLayout `shouldHaveLayout` expectedExampleLayout

112+ it "aggregates capture hints when different" $ do

113+ captureDifferentTypes `shouldHaveLayout` expectedCaptureDifferentTypes

114+ it "nubs capture hints when equal" $ do

115+ captureSameType `shouldHaveLayout` expectedCaptureSameType

116+ it "properly displays CaptureAll hints" $ do

117+ captureAllLayout `shouldHaveLayout` expectedCaptureAllLayout

118+

101119shouldHaveSameStructureAs ::

102120 (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation

103121shouldHaveSameStructureAs p1 p2 =

104122 unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $

105123 expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))

106124

125+shouldHaveLayout ::

126+ (HasServer api '[]) => Proxy api -> Text -> Expectation

127+shouldHaveLayout p l =

128+ unless (routerLayout (makeTrivialRouter p) == l) $

129+ expectationFailure ("expected:\n" ++ unpack l ++ "\nbut got:\n" ++ unpack (layout p))

130+

107131makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()

108132makeTrivialRouter p =

109133 route p EmptyContext (emptyDelayed (FailFatal err501))

@@ -144,12 +168,12 @@ staticRef = Proxy

144168-- structure:

145169

146170type Dynamic =

147− "a" :> Capture "foo" Int :> "b" :> End

148− :<|> "a" :> Capture "bar" Bool :> "c" :> End

149− :<|> "a" :> Capture "baz" Char :> "d" :> End

171+ "a" :> Capture "foo" Int :> "b" :> End

172+ :<|> "a" :> Capture "foo" Int :> "c" :> End

173+ :<|> "a" :> Capture "foo" Int :> "d" :> End

150174

151175type DynamicRef =

152− "a" :> Capture "anything" () :>

176+ "a" :> Capture "foo" Int :>

153177 ("b" :> End :<|> "c" :> End :<|> "d" :> End)

154178

155179dynamic :: Proxy Dynamic

@@ -339,3 +363,100 @@ level = Proxy

339363

340364levelRef :: Proxy LevelRef

341365levelRef = Proxy

366+

367+-- The example API for the 'layout' function.

368+-- Should get factorized by the 'choice' smart constructor.

369+type ExampleLayout =

370+ "a" :> "d" :> Get '[JSON] NoContent

371+ :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool

372+ :<|> "c" :> Put '[JSON] Bool

373+ :<|> "a" :> "e" :> Get '[JSON] Int

374+ :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool

375+ :<|> Raw

376+

377+exampleLayout :: Proxy ExampleLayout

378+exampleLayout = Proxy

379+

380+-- The expected representation of the example API layout

381+--

382+expectedExampleLayout :: Text

383+expectedExampleLayout =

384+ "/\n\

385+ \├─ a/\n\

386+ \│ ├─ d/\n\

387+ \│ │ └─•\n\

388+ \│ └─ e/\n\

389+ \│ └─•\n\

390+ \├─ b/\n\

391+ \│ └─ <x::Int>/\n\

392+ \│ ├─•\n\

393+ \│ ┆\n\

394+ \│ └─•\n\

395+ \├─ c/\n\

396+ \│ └─•\n\

397+ \┆\n\

398+ \└─ <raw>\n"

399+

400+-- A capture API with all capture types being the same

401+--

402+type CaptureSameType =

403+ "a" :> Capture "foo" Int :> "b" :> End

404+ :<|> "a" :> Capture "foo" Int :> "c" :> End

405+ :<|> "a" :> Capture "foo" Int :> "d" :> End

406+

407+captureSameType :: Proxy CaptureSameType

408+captureSameType = Proxy

409+

410+-- The expected representation of the CaptureSameType API layout.

411+--

412+expectedCaptureSameType :: Text

413+expectedCaptureSameType =

414+ "/\n\

415+ \└─ a/\n\

416+ \ └─ <foo::Int>/\n\

417+ \ ├─ b/\n\

418+ \ │ └─•\n\

419+ \ ├─ c/\n\

420+ \ │ └─•\n\

421+ \ └─ d/\n\

422+ \ └─•\n"

423+

424+-- A capture API capturing different types

425+--

426+type CaptureDifferentTypes =

427+ "a" :> Capture "foo" Int :> "b" :> End

428+ :<|> "a" :> Capture "bar" Bool :> "c" :> End

429+ :<|> "a" :> Capture "baz" Char :> "d" :> End

430+

431+captureDifferentTypes :: Proxy CaptureDifferentTypes

432+captureDifferentTypes = Proxy

433+

434+-- The expected representation of the CaptureDifferentTypes API layout.

435+--

436+expectedCaptureDifferentTypes :: Text

437+expectedCaptureDifferentTypes =

438+ "/\n\

439+ \└─ a/\n\

440+ \ └─ <foo::Int|bar::Bool|baz::Char>/\n\

441+ \ ├─ b/\n\

442+ \ │ └─•\n\

443+ \ ├─ c/\n\

444+ \ │ └─•\n\

445+ \ └─ d/\n\

446+ \ └─•\n"

447+

448+-- An API with a CaptureAll part

449+

450+type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End

451+

452+captureAllLayout :: Proxy CaptureAllLayout

453+captureAllLayout = Proxy

454+

455+-- The expected representation of the CaptureAllLayout API.

456+--

457+expectedCaptureAllLayout :: Text

458+expectedCaptureAllLayout =

459+ "/\n\

460+ \└─ a/\n\

461+ \ └─ <foos::[Int]>/\n\

462+ \ └─•\n"

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

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

1717

1818import Control.Monad

1919 (forM_, unless, when)

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

2021import Control.Monad.Error.Class

2122 (MonadError (..))

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

2224import Data.Aeson

2325 (FromJSON, ToJSON, decode', encode)

26+import Data.Acquire

27+ (Acquire, mkAcquire)

2428import qualified Data.ByteString as BS

2529import qualified Data.ByteString.Base64 as Base64

2630import Data.Char

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

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

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

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

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

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

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

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

5862import Servant.Server

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

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

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

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

6165 serveWithContext)

6266import Servant.Test.ComprehensiveAPI

6367import qualified Servant.Types.SourceT as S

6468import Test.Hspec

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

6670import Test.Hspec.Wai

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

71+ (get, matchHeaders, matchStatus, shouldRespondWith,

6872 with, (<:>))

6973import qualified Test.Hspec.Wai as THW

7074

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

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

8286_ = serveWithContext comprehensiveAPI comprehensiveApiContext

8387

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

85−comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext

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

89+comprehensiveApiContext =

90+ NamedContext EmptyContext :.

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

92+ EmptyContext

8693

8794-- * Specs

8895

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

97104 reqBodySpec

98105 headerSpec

99106 rawSpec

107+ rawMSpec

100108 alternativeSpec

101109 responseHeadersSpec

102110 uverbResponseHeadersSpec

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

605613

606614-- }}}

607615------------------------------------------------------------------------------

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

608656-- * alternativeSpec {{{

609657------------------------------------------------------------------------------

610658type AlternativeApi =

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

@@ -77,7 +77,7 @@ library

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

7878 , insert-ordered-containers >=0.2.1.0 && <0.3

7979 , lens >=4.17 && <6

80− , servant >=0.18.1 && <0.20

80+ , servant >=0.18.2 && <0.20

8181 , singleton-bool >=0.1.4 && <0.2

8282 , swagger2 >=2.3.0.1 && <3

8383 , text >=1.2.3.0 && <2.1

@@ -106,14 +106,14 @@ 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.8

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

110110 build-depends: base

111111 , base-compat

112112 , aeson >=1.4.2.0 && <3

113− , hspec >=2.6.0 && <2.8

113+ , hspec >=2.6.0 && <2.11

114114 , QuickCheck

115115 , lens

116− , lens-aeson >=1.0.2 && <1.2

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

117117 , servant

118118 , servant-swagger

119119 , swagger2

servant-swagger/src/Servant/Swagger.hs+5−3

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

5555-- >>> import Data.Typeable

5656-- >>> import GHC.Generics

5757-- >>> import Servant.API

58+-- >>> import System.Environment

5859-- >>> import Test.Hspec

5960-- >>> import Test.QuickCheck

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

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

6465-- >>> :set -XGeneralizedNewtypeDeriving

6566-- >>> :set -XOverloadedStrings

6667-- >>> :set -XTypeOperators

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

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

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

6971-- >>> instance ToJSON User

@@ -160,11 +162,11 @@ import Servant.Swagger.Internal.Orphans ()

160162-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary

161163-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI)

162164-- <BLANKLINE>

163−-- [User]

165+-- [User]...

164166-- ...

165−-- User

167+-- User...

166168-- ...

167−-- UserId

169+-- UserId...

168170-- ...

169171-- Finished in ... seconds

170172-- 3 examples, 0 failures

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

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

33{-# LANGUAGE DataKinds #-}

44{-# LANGUAGE FlexibleContexts #-}

55{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE OverloadedLists #-}

67{-# LANGUAGE OverloadedStrings #-}

78{-# LANGUAGE PolyKinds #-}

89{-# LANGUAGE RankNTypes #-}

910{-# LANGUAGE ScopedTypeVariables #-}

1011{-# LANGUAGE TypeOperators #-}

12+{-# LANGUAGE TypeFamilies #-}

1113#if __GLASGOW_HASKELL__ >= 806

1214{-# LANGUAGE UndecidableInstances #-}

1315#endif

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

3032import Data.Swagger.Declare

3133import Data.Text (Text)

3234import qualified Data.Text as Text

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

3336import GHC.TypeLits

3437import Network.HTTP.Media (MediaType)

3538import Servant.API

3639import Servant.API.Description (FoldDescription,

3740 reflectDescription)

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

3842import Servant.API.Modifiers (FoldRequired)

3943

4044import Servant.Swagger.Internal.TypeLevel.API

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

149153addParam :: Param -> Swagger -> Swagger

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

151155

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

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

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

159+

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

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

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

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

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

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

298306

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+

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

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

301313 where

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

439451 & required ?~ True

440452 & schema .~ ParamBody ref

441453

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+

442457-- =======================================================================

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

444459-- =======================================================================

servant-swagger/src/Servant/Swagger/Internal/Test.hs+8−6

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

2929-- >>> import Control.Applicative

3030-- >>> import GHC.Generics

3131-- >>> import Test.QuickCheck

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

3233-- >>> :set -XDeriveGeneric

3334-- >>> :set -XGeneralizedNewtypeDeriving

3435-- >>> :set -XDataKinds

3536-- >>> :set -XTypeOperators

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

3638

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

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

@@ -53,10 +55,10 @@ import Servant.Swagger.Internal.TypeLevel

5355--

5456-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)

5557-- <BLANKLINE>

56−-- ToJSON matches ToSchema

57−-- User

58+-- ToJSON matches ToSchema...

59+-- User...

5860-- ...

59−-- UserId

61+-- UserId...

6062-- ...

6163-- Finished in ... seconds

6264-- 2 examples, 0 failures

@@ -118,11 +120,11 @@ validateEveryToJSONWithPatternChecker checker _ = props

118120-- :}

119121-- <BLANKLINE>

120122-- read . show == id

121−-- Bool

123+-- Bool...

122124-- ...

123−-- Int

125+-- Int...

124126-- ...

125−-- [Char]

127+-- [Char]...

126128-- ...

127129-- Finished in ... seconds

128130-- 3 examples, 0 failures

servant/CHANGELOG.md+5

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

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+

5100.19

611----

712

servant/servant.cabal+9−8

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

11cabal-version: 2.2

22name: servant

3−version: 0.19

3+version: 0.19.1

44

55synopsis: A family of combinators for defining webservices APIs

66category: Servant, Web

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

6262 Servant.API.Vault

6363 Servant.API.Verbs

6464 Servant.API.WithNamedContext

65+ Servant.API.WithResource

6566

6667 -- Types

6768 exposed-modules:

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

8081 --

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

8283 build-depends:

83− base >= 4.9 && < 4.17

84+ base >= 4.9 && < 4.18

8485 , bytestring >= 0.10.8.1 && < 0.12

8586 , constraints >= 0.2

86− , mtl >= 2.2.2 && < 2.3

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

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

88− , transformers >= 0.5.2.0 && < 0.6

89+ , transformers >= 0.5.2.0 && < 0.7

8990 , text >= 1.2.3.0 && < 2.1

9091

9192

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

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

9495 build-depends:

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

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

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

9798

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

@@ -106,7 +107,7 @@ library

106107 , deepseq >= 1.4.2.0 && < 1.5

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

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

109− , mmorph >= 1.1.2 && < 1.2

110+ , mmorph >= 1.1.2 && < 1.3

110111 , network-uri >= 2.6.1.0 && < 2.7

111112 , QuickCheck >= 2.12.6.1 && < 2.15

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

@@ -166,9 +167,9 @@ test-suite spec

166167

167168 -- Additional dependencies

168169 build-depends:

169− hspec >= 2.6.0 && < 2.9

170+ hspec >= 2.6.0 && < 2.10

170171 , QuickCheck >= 2.12.6.1 && < 2.15

171172 , quickcheck-instances >= 0.3.19 && < 0.4

172173

173174 build-tool-depends:

174− hspec-discover:hspec-discover >= 2.6.0 && < 2.9

175+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10

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

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

3436

3537 -- * Actual endpoints, distinguished by HTTP method

3638 module Servant.API.Verbs,

@@ -38,6 +40,7 @@ module Servant.API (

3840

3941 -- * Sub-APIs defined as records of routes

4042 module Servant.API.NamedRoutes,

43+ module Servant.API.Generic,

4144

4245 -- * Streaming endpoints, distinguished by HTTP method

4346 module Servant.API.Stream,

@@ -100,6 +103,9 @@ import Servant.API.Experimental.Auth

100103 (AuthProtect)

101104import Servant.API.Fragment

102105 (Fragment)

106+import Servant.API.Generic

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

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

103109import Servant.API.Header

104110 (Header, Header')

105111import Servant.API.HttpVersion

@@ -108,10 +114,12 @@ import Servant.API.IsSecure

108114 (IsSecure (..))

109115import Servant.API.Modifiers

110116 (Lenient, Optional, Required, Strict)

117+import Servant.API.NamedRoutes

118+ (NamedRoutes)

111119import Servant.API.QueryParam

112120 (QueryFlag, QueryParam, QueryParam', QueryParams)

113121import Servant.API.Raw

114− (Raw)

122+ (Raw, RawM)

115123import Servant.API.RemoteHost

116124 (RemoteHost)

117125import Servant.API.ReqBody

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

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

134142import Servant.API.Vault

135143 (Vault)

136−import Servant.API.NamedRoutes

137− (NamedRoutes)

138144import Servant.API.Verbs

139145 (Delete, DeleteAccepted, DeleteNoContent,

140146 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

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

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

147153import Servant.API.WithNamedContext

148154 (WithNamedContext)

155+import Servant.API.WithResource

156+ (WithResource)

149157import Servant.Links

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

151159import 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 _ _ = map (, "") $ NE.toList $ contentTypes pctyp

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

299299 where

300300 pctyp = Proxy :: Proxy ctyp

301301

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

@@ -15,3 +15,6 @@ 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,6 +8,7 @@

88{-# LANGUAGE PolyKinds #-}

99{-# LANGUAGE ScopedTypeVariables #-}

1010{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeFamilyDependencies #-}

1112{-# LANGUAGE TypeOperators #-}

1213{-# LANGUAGE UndecidableInstances #-}

1314{-# OPTIONS_HADDOCK not-home #-}

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

5152import Prelude.Compat

5253import Servant.API.Header

5354 (Header)

55+import Servant.API.UVerb.Union

56+import qualified Data.SOP.BasicFunctors as SOP

57+import qualified Data.SOP.NS as SOP

5458

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

5660-- Instead, use 'addOptionalHeader'.

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

170174 => AddHeader h v a new where

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

172176

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+

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

174197-- the value in the following ways:

175198--

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

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

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

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

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

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

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,6 +38,7 @@ 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)

4142import Servant.API.UVerb.Union

4243

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

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

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

8788 type StatusOf (WithStatus n a) = n

8889

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

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

8992

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

9194--

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

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

11{-# LANGUAGE AllowAmbiguousTypes #-}

22{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE CPP #-}

34{-# LANGUAGE DataKinds #-}

45{-# LANGUAGE FlexibleContexts #-}

56{-# LANGUAGE FlexibleInstances #-}

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

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

9293-- >>> safeLink api bad_link

9394-- ...

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

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

9596-- ...

9697--

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

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

174175import Servant.API.QueryParam

175176 (QueryFlag, QueryParam', QueryParams)

176177import Servant.API.Raw

177− (Raw)

178+ (Raw, RawM)

178179import Servant.API.RemoteHost

179180 (RemoteHost)

180181import Servant.API.ReqBody

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

192193 (Verb, NoContentVerb)

193194import Servant.API.WithNamedContext

194195 (WithNamedContext)

196+import Servant.API.WithResource

197+ (WithResource)

195198import Web.HttpApiData

199+import Data.Kind

200+ (Type)

196201

197202-- | A safe link datatype.

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

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

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

557562

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+

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

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

560569 toLink = simpleToLink (Proxy :: Proxy sub)

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

580589 type MkLink Raw a = a

581590 toLink toA _ = toA

582591

592+instance HasLink RawM where

593+ type MkLink RawM a = a

594+ toLink toA _ = toA

595+

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

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

585598 toLink toA _ = toA

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

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

648661

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

651668 where

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

653670 toLink = error "unreachable"

654671

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

657678

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

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

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

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

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

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

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

7576 :<|> endpoint

7677

7778type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DeriveFunctor #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE RankNTypes #-}

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

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

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

156157--

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

157159instance MonadTrans StepT where

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

161+#endif

159162

160163instance MFunctor StepT where

161164 hoist f = go where

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

@@ -33,6 +33,8 @@ 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)

3638import GHC.Generics

3739import Test.Hspec

3840import Test.QuickCheck

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

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

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

8082

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+

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

8293 let p = Proxy :: Proxy PlainText

8394

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

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

22{-# LANGUAGE OverloadedStrings #-}

33module Servant.API.ResponseHeadersSpec where

44

5+import Data.Proxy

6+import GHC.TypeLits

57import Test.Hspec

68

9+import Servant.API.ContentTypes

710import Servant.API.Header

811import Servant.API.ResponseHeaders

12+import Servant.API.UVerb

913

1014spec :: Spec

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

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

2832 it "does not add a header" $ do

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

3034 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+