master..256cec5 · servant

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

since splitsnapshots

unifiedsplit

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

20 - "8.10.7"

21 - "9.0.2"

22 - "9.2.2"

23− - "9.4.2"

24

23

25 steps:

24 steps:

26 - uses: actions/checkout@v2

25 - uses: actions/checkout@v2

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

60 cabal test all

59 cabal test all

61

60

62 - name: Run doctests

61 - 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' }}

63 run: |

65 run: |

64 # Necessary for doctest to be found in $PATH

66 # Necessary for doctest to be found in $PATH

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

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

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

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

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

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

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

78

80

79− # stack:

81+ stack:

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

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

81− # runs-on: ubuntu-latest

83+ runs-on: ubuntu-latest

82− # strategy:

84+ strategy:

83− # matrix:

85+ matrix:

84− # stack: ["2.7.5"]

86+ stack: ["2.7.3"]

85− # ghc: ["8.10.7"]

87+ ghc: ["8.10.7"]

86−

88+

87− # steps:

89+ steps:

88− # - uses: actions/checkout@v2

90+ - uses: actions/checkout@v2

89−

91+

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

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

91− # name: Setup Haskell Stack

93+ name: Setup Haskell Stack

92− # with:

94+ with:

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

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

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

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

95−

97+

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

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

97− # name: Cache ~/.stack

99+ name: Cache ~/.stack

98− # with:

100+ with:

99− # path: ~/.stack

101+ path: ~/.stack

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

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

101−

103+

102− # - name: Install dependencies

104+ - name: Install dependencies

103− # run: |

105+ run: |

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

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

105−

107+

106− # - name: Build

108+ - name: Build

107− # run: |

109+ run: |

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

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

109−

111+

110− # - name: Test

112+ - name: Test

111− # run: |

113+ run: |

112− # stack test --system-ghc

114+ stack test --system-ghc

113

115

114 ghcjs:

116 ghcjs:

115 name: ubuntu-latest / ghcjs 8.6

117 name: ubuntu-latest / ghcjs 8.6

cabal.project−1

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

47 doc/cookbook/using-custom-monad

48 doc/cookbook/using-free-client

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

50− doc/cookbook/managed-resource

51

50

52tests: True

51tests: True

53optimization: False

52optimization: False

changelog.d/1556deleted−81

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

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/1569deleted−13

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

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/1571deleted−10

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

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

2−prs: #1571

3−issues: #1570

4−description: {

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

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

7−servant-auth-client.

8−

9−This PR also brings Headers support in UVerb responses

10−}

changelog.d/1573deleted−2

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

1−synopsis: Add API docs for ServerT

2−prs: #1573

changelog.d/1580deleted−12

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

1−synopsis: Allow IO in validationKeys

2−prs: #1580

3−issues: #1579

4−

5−description: {

6−

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

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

9−discover new and expired keys.

10−

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

12−}

changelog.d/1589deleted−2

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

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

2−prs: 1589

changelog.d/1595deleted−2

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

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

2−prs: #1595

changelog.d/1606deleted−10

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

1−synopsis: Handle Cookies correctly for RunStreamingClient

2−prs: #1606

3−issues: #1605

4−

5−description: {

6−

7−Makes performWithStreamingRequest take into consideration the

8−CookieJar, which it previously didn't.

9−

10−}

changelog.d/1638deleted−2

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

1−synopsis: Add Functor instance to AuthHandler.

2−prs: #1638

changelog.d/1649deleted−8

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

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

2−prs: #1649

3−

4−description: {

5−

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

7−

8−}

doc/cookbook/index.rst−1

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

37 sentry/Sentry.lhs

38 testing/Testing.lhs

39 open-id-connect/OpenIdConnect.lhs

40− managed-resource/ManagedResource.lhs

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

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

1−# Request-lifetime Managed Resources

2−

3−Let's see how we can write a handle that uses a resource managed by Servant. The resource is created automatically by Servant when the server recieves a request, and the resource is automatically destroyed when the server is finished handling a request.

4−

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

6−

7−

8−``` haskell

9−{-# LANGUAGE DataKinds #-}

10−{-# LANGUAGE TypeOperators #-}

11−import Control.Concurrent

12−import Control.Exception (bracket, throwIO)

13−import Control.Monad.IO.Class

14−import Control.Monad.Trans.Resource

15−import Data.Acquire

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

17−import Network.Wai.Handler.Warp

18−import Servant

19−import Servant.Client

20−import System.IO

21−```

22−

23−Here we define an API type that uses the `WithResource` combinator. The server handler for an endpoint with a `WithResource res` component will receive a value of that type as an argument.

24−

25−``` haskell

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

27−

28−api :: Proxy API

29−api = Proxy

30−```

31−

32−But this resource value has to come from somewhere. Servant obtains the value using an Acquire provided in the context. The Acquire knows how to both create and destroy resources of a particular type.

33−

34−``` haskell

35−appContext :: Context '[Acquire Handle]

36−appContext = acquireHandle :. EmptyContext

37−

38−acquireHandle :: Acquire Handle

39−acquireHandle = mkAcquire newHandle closeHandle

40−

41−newHandle :: IO Handle

42−newHandle = do

43− putStrLn "opening file"

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

45− putStrLn "opened file"

46− return h

47−

48−closeHandle :: Handle -> IO ()

49−closeHandle h = do

50− putStrLn "closing file"

51− hClose h

52− putStrLn "closed file"

53−```

54−

55−Now we create the handler which will use this resource. This handler will write the request message to the System.IO.Handle which was provided to us. In some situations the handler will succeed, but in some in will fail. In either case, Servant will clean up the resource for us.

56−

57−``` haskell

58−server :: Server API

59−server = writeToFile

60−

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

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

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

64− legalMsg -> liftIO $ do

65− putStrLn "writing file"

66− hPutStrLn h legalMsg

67− putStrLn "wrote file"

68− return NoContent

69−```

70−

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

72−

73−``` haskell

74−runApp :: IO ()

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

76−

77−postMsg :: String -> ClientM NoContent

78−postMsg = client api

79−

80−main :: IO ()

81−main = do

82− mgr <- newManager defaultManagerSettings

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

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

85− liftIO $ putStrLn "sending hello message"

86− _ <- postMsg "hello"

87− liftIO $ putStrLn "sending illegal message"

88− _ <- postMsg "illegal"

89− liftIO $ putStrLn "done"

90− print ms

91−```

92−

93−This program prints

94−

95−```

96−sending hello message

97−opening file

98−opened file

99−writing file

100−wrote file

101−closing file

102−closed file

103−sending illegal message

104−opening file

105−opened file

106−closing file

107−closed file

108−wait, that's illegal!

109−CallStack (from HasCallStack):

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

111−Left (FailureResponse (Request {requestPath = (BaseUrl {baseUrlScheme = Http, baseUrlHost = "localhost", baseUrlPort = 8080, baseUrlPath = ""},""), requestQueryString = fromList [], requestBody = Just ((),text/plain;charset=utf-8), requestAccept = fromList [], requestHeaders = fromList [], requestHttpVersion = HTTP/1.1, requestMethod = "POST"}) (Response {responseStatusCode = Status {statusCode = 500, statusMessage = "Internal Server Error"}, responseHeaders = fromList [("Transfer-Encoding","chunked"),("Date","Thu, 24 Nov 2022 21:04:47 GMT"),("Server","Warp/3.3.23"),("Content-Type","text/plain; charset=utf-8")], responseHttpVersion = HTTP/1.1, responseBody = "Something went wrong"}))

112−```

113−

114−and appends to a file called `test.txt`. We can see from the output that when a legal message is sent, the file is opened, written to, and closed. We can also see that when an illegal message is sent, the file is opened but not written to. Crucially, it is still closed even though the handler threw an exception.

doc/cookbook/managed-resource/managed-resource.cabaldeleted−30

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

1−cabal-version: 2.2

2−name: cookbook-managed-resource

3−version: 0.1

4−synopsis: Simple managed resource cookbook example

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

11−tested-with: GHC==9.4.2

12−

13−executable cookbook-managed-resource

14− main-is: ManagedResource.lhs

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

16− , text >= 1.2

17− , aeson >= 1.2

18− , servant

19− , servant-client

20− , servant-server

21− , warp >= 3.2

22− , wai >= 3.2

23− , http-types >= 0.12

24− , markdown-unlit >= 0.4

25− , http-client >= 0.5

26− , transformers

27− , resourcet

28− default-language: Haskell2010

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

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

doc/cookbook/open-id-connect/OpenIdConnect.lhs+1−1

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

330```

331

332Here is the code that displays the homepage.

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

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

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

335with some generated information.

336

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

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

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

120

121```haskell

122− req' <- I.defaultMakeClientRequest burl req

122+ let req' = I.defaultMakeClientRequest burl req

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

124```

125

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

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

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

200

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

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

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

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

204The README claims that

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

doc/requirements.txt−1

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

1recommonmark==0.5.0

2Sphinx==1.8.4

3sphinx_rtd_theme>=0.4.2

4−jinja2<3.1.0

servant-auth/servant-auth-client/servant-auth-client.cabal+2−2

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

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

32 ghc-options: -Wall

33 build-depends:

34− base >= 4.10 && < 4.18

34+ base >= 4.10 && < 4.17

35 , bytestring >= 0.10.6.0 && < 0.12

36 , containers >= 0.5.6.2 && < 0.7

37 , servant-auth == 0.4.*

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

74 , transformers >= 0.4.2.0 && < 0.6

75 , wai >= 3.2.1.2 && < 3.3

76 , warp >= 3.2.25 && < 3.4

77− , jose >= 0.10 && < 0.11

77+ , jose >= 0.7.0.0 && < 0.10

78 other-modules:

79 Servant.Auth.ClientSpec

80 default-language: Haskell2010

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

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

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

36 ghc-options: -Wall

37 build-depends:

38− base >= 4.10 && < 4.18

38+ base >= 4.10 && < 4.17

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

40 , servant >= 0.13 && < 0.20

41 , servant-auth == 0.4.*

42− , lens >= 4.16.1 && <5.3

42+ , lens >= 4.16.1 && <5.2

43 exposed-modules:

44 Servant.Auth.Docs

45 default-language: Haskell2010

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

50 build-depends:

51 base,

52 servant-auth-docs,

53− doctest >= 0.16 && < 0.21,

53+ doctest >= 0.16 && < 0.19,

54 QuickCheck >= 2.11.3 && < 2.15,

55 template-haskell

56 ghc-options: -Wall -threaded

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

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

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

32 ghc-options: -Wall

33 build-depends:

34− base >= 4.10 && < 4.18

34+ base >= 4.10 && < 4.17

35 , aeson >= 1.0.0.1 && < 3

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

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

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

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

42 , entropy >= 0.4.1.3 && < 0.5

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

44− , jose >= 0.10 && < 0.11

44+ , jose >= 0.7.0.0 && < 0.10

45− , lens >= 4.16.1 && < 5.3

45+ , lens >= 4.16.1 && < 5.2

46− , memory >= 0.14.16 && < 0.19

46+ , memory >= 0.14.16 && < 0.18

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

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

48+ , mtl >= 2.2.2 && < 2.3

49 , servant >= 0.13 && < 0.20

50 , servant-auth == 0.4.*

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

52 , tagged >= 0.8.4 && < 0.9

53 , text >= 1.2.3.0 && < 2.1

54− , time >= 1.5.0.1 && < 1.13

54+ , time >= 1.5.0.1 && < 1.12

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

56 , wai >= 3.2.1.2 && < 3.3

57

@@ -126,10 +126,9 @@ test-suite spec

126 , hspec >= 2.5.5 && < 2.10

127 , QuickCheck >= 2.11.3 && < 2.15

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

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

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

130 , warp >= 3.2.25 && < 3.4

131 , wreq >= 0.5.2.1 && < 0.6

132− , text >= 1.2.3.0 && < 2.1

133 other-modules:

132 other-modules:

134 Servant.Auth.ServerSpec

133 Servant.Auth.ServerSpec

135 default-language: Haskell2010

134 default-language: Haskell2010

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

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

54

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

56 makeCookies authResult = do

57+ xsrf <- makeXsrfCookie cookieSettings

58+ fmap (Just xsrf `SetCookieCons`) $

57− case authResult of

59+ case authResult of

58− (Authenticated v) -> do

60+ (Authenticated v) -> do

59− ejwt <- makeSessionCookie cookieSettings jwtSettings v

61+ ejwt <- makeSessionCookie cookieSettings jwtSettings v

60− xsrf <- makeXsrfCookie cookieSettings

62+ case ejwt of

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

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

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

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

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

63

66

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

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

65 -> (AuthResult v, SetCookieList n)

68 -> (AuthResult v, SetCookieList n)

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

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

11import qualified Network.HTTP.Types as HTTP

12import Network.Wai (mapResponseHeaders)

13import Servant

14−import Servant.API.UVerb.Union

15import Servant.API.Generic

14import Servant.API.Generic

16import Servant.Server.Generic

15import Servant.Server.Generic

17import Web.Cookie

16import Web.Cookie

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

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

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

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

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

36

35

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−

43type family AddSetCookieApi a :: *

36type family AddSetCookieApi a :: *

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

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

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

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

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

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

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

48−#endif

49type instance AddSetCookieApi (Verb method stat ctyps a)

40type instance AddSetCookieApi (Verb method stat ctyps a)

50 = Verb method stat ctyps (AddSetCookieApiVerb a)

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

55type instance AddSetCookieApi Raw = Raw

42type instance AddSetCookieApi Raw = Raw

56#if MIN_VERSION_servant_server(0,15,0)

43#if MIN_VERSION_servant_server(0,15,0)

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

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

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

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

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

71 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

58 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

72

59

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

60+instance AddSetCookies 'Z orig orig where

74 addSetCookies _ = id

61 addSetCookies _ = id

75

62

76instance {-# OVERLAPPABLE #-}

63instance {-# OVERLAPPABLE #-}

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

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

33 -- | Algorithm used to sign JWT.

34 , jwtAlg :: Maybe Jose.Alg

35 -- | Keys used to validate JWT.

36− , validationKeys :: IO Jose.JWKSet

36+ , validationKeys :: Jose.JWKSet

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

38 -- intended recipient of the JWT.

39 , audienceMatches :: Jose.StringOrURI -> IsMatch

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

44defaultJWTSettings k = JWTSettings

45 { signingKey = k

46 , jwtAlg = Nothing

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

47+ , validationKeys = Jose.JWKSet [k]

48 , audienceMatches = const Matches }

49

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

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

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

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

3

4import Blaze.ByteString.Builder (toByteString)

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

6import Control.Monad.Except

5import Control.Monad.Except

7import Control.Monad.Reader

6import Control.Monad.Reader

8import qualified Crypto.JOSE as Jose

7import qualified Crypto.JOSE as Jose

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

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

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

2

3import Control.Lens

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

4+import Control.Monad.Except

5import Control.Monad.Reader

6import qualified Crypto.JOSE as Jose

7import qualified Crypto.JWT as Jose

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

9+ toJSON)

8import Data.ByteArray (constEq)

10import Data.ByteArray (constEq)

9import qualified Data.ByteString as BS

11import qualified Data.ByteString as BS

10import qualified Data.ByteString.Lazy as BSL

12import qualified Data.ByteString.Lazy as BSL

13+import qualified Data.HashMap.Strict as HM

11import Data.Maybe (fromMaybe)

14import Data.Maybe (fromMaybe)

15+import qualified Data.Text as T

12import Data.Time (UTCTime)

16import Data.Time (UTCTime)

13import Network.Wai (requestHeaders)

17import Network.Wai (requestHeaders)

14

18

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

38-- token expires.

42-- token expires.

39makeJWT :: ToJWT a

43makeJWT :: ToJWT a

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

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

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

45+makeJWT v cfg expiry = runExceptT $ do

42 bestAlg <- Jose.bestJWSAlg $ signingKey cfg

46 bestAlg <- Jose.bestJWSAlg $ signingKey cfg

43 let alg = fromMaybe bestAlg $ jwtAlg cfg

47 let alg = fromMaybe bestAlg $ jwtAlg cfg

44 ejwt <- Jose.signClaims (signingKey cfg)

48 ejwt <- Jose.signClaims (signingKey cfg)

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

54

58

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

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

56verifyJWT jwtCfg input = do

60verifyJWT jwtCfg input = do

57− keys <- validationKeys jwtCfg

58− verifiedJWT <- Jose.runJOSE $ do

61+ verifiedJWT <- liftIO $ runExceptT $ do

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

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

60 Jose.verifyClaims

63 Jose.verifyClaims

61 (jwtSettingsToJwtValidationSettings jwtCfg)

64 (jwtSettingsToJwtValidationSettings jwtCfg)

62− keys

65+ (validationKeys jwtCfg)

63 unverifiedJWT

66 unverifiedJWT

64 return $ case verifiedJWT of

67 return $ case verifiedJWT of

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

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

66 Right v -> case decodeJWT v of

69 Right v -> case decodeJWT v of

67 Left _ -> Nothing

70 Left _ -> Nothing

68− Right v' -> Just v'

71+ Right v' -> Just v'

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

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

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

3

4import Control.Applicative

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

6import Control.Monad.Reader

5import Control.Monad.Reader

7import Control.Monad.Time

6import Control.Monad.Time

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

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

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

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

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE TypeApplications #-}

3module Servant.Auth.ServerSpec (spec) where

2module Servant.Auth.ServerSpec (spec) where

4

3

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

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

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

7#endif

6#endif

8

7

9import Control.Lens

8import Control.Lens

9+import Control.Monad.Except (runExceptT)

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

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

12 JWK, JWSHeader,

13 KeyMaterialGenParam (OctGenParam),

14 ToCompact, encodeCompact,

15− genJWK, newJWSHeader, runJOSE)

15+ genJWK, newJWSHeader)

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

17 NumericDate (NumericDate),

18 SignedJWT,

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

25import Data.Aeson.Lens (_JSON)

26import qualified Data.ByteString as BS

27import qualified Data.ByteString.Lazy as BSL

28−import Data.Text (Text, pack)

29import Data.CaseInsensitive (mk)

28import Data.CaseInsensitive (mk)

30import Data.Foldable (find)

29import Data.Foldable (find)

31import Data.Monoid

30import Data.Monoid

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

41import Network.Wai (responseLBS)

40import Network.Wai (responseLBS)

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

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

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

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

44− checkResponse,

45 cookieExpiryTime, cookies,

43 cookieExpiryTime, cookies,

46 defaults, get, getWith, postWith,

44 defaults, get, getWith, postWith,

47 header, oauth2Bearer,

45 header, oauth2Bearer,

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

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

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

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

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

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

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

188− opts' <- addJwtToCookie cookieCfg jwt

186+ opts <- addJwtToCookie cookieCfg jwt

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

190− resp <- getWith opts (url port)

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

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−

203

188

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

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

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

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

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

421 = Auth auths User :>

406 = Auth auths User :>

422 ( Get '[JSON] Int

407 ( Get '[JSON] Int

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

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

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

409+ :<|> NamedRoutes DummyRoutes

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

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

426#if MIN_VERSION_servant_server(0,15,0)

411#if MIN_VERSION_servant_server(0,15,0)

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

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

428#endif

413#endif

429 :<|> "raw" :> Raw

414 :<|> "raw" :> Raw

430 )

415 )

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

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

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

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

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

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

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

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

506 :<|> raw

490 :<|> raw

507 Indefinite -> throwAll err401

491 Indefinite -> throwAll err401

508 _ -> throwAll err403

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

514 )

493 )

515 :<|> getLogin

494 :<|> getLogin

516 :<|> getLogout

495 :<|> getLogout

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

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

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

562

541

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

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

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

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

565

544

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

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

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

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

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

591 = fmap cookie_name (destroyCookieJar cj)

570 = fmap cookie_name (destroyCookieJar cj)

592 `shouldMatchList` patterns

571 `shouldMatchList` patterns

593

572

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−

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

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

601shouldMatchCookieNameValues cj patterns

574shouldMatchCookieNameValues cj patterns

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

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

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

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

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

32 ghc-options: -Wall

33 build-depends:

34− base >= 4.10 && < 4.18

34+ base >= 4.10 && < 4.16

35 , text >= 1.2.3.0 && < 2.1

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

37 , swagger2 >= 2.2.2 && < 3

38 , servant >= 0.13 && < 0.20

39 , servant-auth == 0.4.*

40− , lens >= 4.16.1 && < 5.3

40+ , lens >= 4.16.1 && < 5.2

41+ if impl(ghc >= 9)

42+ buildable: False

41 exposed-modules:

43 exposed-modules:

42 Servant.Auth.Swagger

44 Servant.Auth.Swagger

43 default-language: Haskell2010

45 default-language: Haskell2010

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

59 , servant

61 , servant

60 , servant-auth

62 , servant-auth

61 , lens

63 , lens

64+ if impl(ghc >= 9)

65+ buildable: False

62

66

63 -- test dependencies

67 -- test dependencies

64 build-depends:

68 build-depends:

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

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

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

34 ghc-options: -Wall

35 build-depends:

36− base >= 4.10 && < 4.18

36+ base >= 4.10 && < 4.17

37 , containers >= 0.6 && < 0.7

38 , aeson >= 1.3.1.1 && < 3

39− , jose >= 0.10 && < 0.11

39+ , jose >= 0.7.0.0 && < 0.10

40− , lens >= 4.16.1 && < 5.3

40+ , lens >= 4.16.1 && < 5.2

41 , servant >= 0.15 && < 0.20

42 , text >= 1.2.3.0 && < 2.1

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

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

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

27

28-- ** Combinators

29

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

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

31--

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

33--

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

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

50 --

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

52 build-depends:

53− base >= 4.9 && < 4.18

53+ base >= 4.9 && < 4.17

54 , bytestring >= 0.10.8.1 && < 0.12

55 , constraints >= 0.2 && < 0.14

56 , containers >= 0.5.7.1 && < 0.7

57 , deepseq >= 1.4.2.0 && < 1.5

58 , text >= 1.2.3.0 && < 2.1

59− , transformers >= 0.5.2.0 && < 0.7

59+ , transformers >= 0.5.2.0 && < 0.6

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

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

61

62 if !impl(ghc >= 8.2)

63 build-depends:

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

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

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

75 IsSecure, MimeRender (mimeRender),

76 MimeUnrender (mimeUnrender), NoContent (NoContent),

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

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

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

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

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

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

81 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)

82import Servant.API.Generic

83 (GenericMode(..), ToServant, ToServantApi

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

208 clientWithRoute pm (Proxy :: Proxy api)

209 (appendToPath p req)

210

211− where p = toEncodedUrlPiece val

211+ where p = (toUrlPiece val)

212

213 hoistClientMonad pm _ f cl = \a ->

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

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

243 clientWithRoute pm (Proxy :: Proxy sublayout)

244 (foldl' (flip appendToPath) req ps)

245

246− where ps = map toEncodedUrlPiece vals

246+ where ps = map (toUrlPiece) vals

247

248 hoistClientMonad pm _ f cl = \as ->

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

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

674

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

676

677−instance RunClient m => HasClient m RawM where

678− type Client m RawM

679− = H.Method -> m Response

680−

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

682− clientWithRoute _pm Proxy req httpMethod = do

683− runRequest req { requestMethod = httpMethod }

684−

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

686−

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

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

688-- the corresponding querying function will automatically take

678-- the corresponding querying function will automatically take

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

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

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

750 clientWithRoute pm (Proxy :: Proxy api)

740 clientWithRoute pm (Proxy :: Proxy api)

751 (appendToPath p req)

741 (appendToPath p req)

752

742

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

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

754

744

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

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

756

746

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

786

776

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

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

788

778

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−

797instance ( HasClient m api

779instance ( HasClient m api

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

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

799 type Client m (AuthProtect tag :> api)

781 type Client m (AuthProtect tag :> api)

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

892--

874--

893-- Example:

875-- Example:

894--

876--

895−-- @

877+-- @@

896-- type Api = NamedRoutes RootApi

878-- type Api = NamedRoutes RootApi

897--

879--

898-- data RootApi mode = RootApi

880-- data RootApi mode = RootApi

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

912-- rootClient = client api

894-- rootClient = client api

913--

895--

914-- endpointClient :: ClientM Person

896-- endpointClient :: ClientM Person

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

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

916−-- @

898+-- @@

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

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

918x // f = f x

900x // f = f x

919

901

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

924--

906--

925-- Example:

907-- Example:

926--

908--

927−-- @

909+-- @@

928-- type Api = NamedRoutes RootApi

910-- type Api = NamedRoutes RootApi

929--

911--

930-- data RootApi mode = RootApi

912-- data RootApi mode = RootApi

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

945-- rootClient = client api

927-- rootClient = client api

946--

928--

947-- hello :: String -> ClientM String

929-- hello :: String -> ClientM String

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

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

949--

931--

950-- endpointClient :: ClientM Person

932-- endpointClient :: ClientM Person

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

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

952−-- @

934+-- @@

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

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

954(/:) = flip

936(/:) = flip

955

937

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

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

34import Data.Bitraversable

35 (Bitraversable (..), bifoldMapDefault, bimapDefault)

36import qualified Data.ByteString as BS

37−import Data.ByteString.Builder

38− (Builder)

39import qualified Data.ByteString.Builder as Builder

37import qualified Data.ByteString.Builder as Builder

40import qualified Data.ByteString.Lazy as LBS

38import qualified Data.ByteString.Lazy as LBS

41import qualified Data.Sequence as Seq

39import qualified Data.Sequence as Seq

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

114 rnfB Nothing = ()

112 rnfB Nothing = ()

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

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

116

114

117−type Request = RequestF RequestBody Builder

115+type Request = RequestF RequestBody Builder.Builder

118

116

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

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

120data RequestBody

118data RequestBody

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

147

145

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

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

149--

147--

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

151−appendToPath :: Builder -> Request -> Request

148+appendToPath :: Text -> Request -> Request

152appendToPath p req

149appendToPath p req

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

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

154

151

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

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

156--

153--

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

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

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

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

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

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

51+ , mtl >=2.2.2 && <2.3

52 , semigroupoids >=5.3 && <5.4

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

54 , transformers >=0.3 && <0.6

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

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

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

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

43 build-depends:

44− base >= 4.9 && < 4.18

44+ base >= 4.9 && < 4.17

45 , bytestring >= 0.10.8.1 && < 0.12

46 , containers >= 0.5.7.1 && < 0.7

47 , deepseq >= 1.4.2.0 && < 1.5

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

48+ , mtl >= 2.2.2 && < 2.3

49 , stm >= 2.4.5.1 && < 2.6

50 , text >= 1.2.3.0 && < 2.1

51− , time >= 1.6.0.1 && < 1.13

51+ , time >= 1.6.0.1 && < 1.12

52− , transformers >= 0.5.2.0 && < 0.7

52+ , transformers >= 0.5.2.0 && < 0.6

53

54 if !impl(ghc >= 8.2)

55 build-depends:

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

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

24import Control.Monad.Base

25 (MonadBase (..))

26import Control.Monad.Catch

27− (MonadCatch, MonadThrow, MonadMask)

27+ (MonadCatch, MonadThrow)

28import Control.Monad.Error.Class

29 (MonadError (..))

30import Control.Monad.IO.Class

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

80 { manager :: Client.Manager

81 , baseUrl :: BaseUrl

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

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

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

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

85 -- Note that:

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

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

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

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

138 , MonadReader ClientEnv, MonadError ClientError, MonadThrow

139− , MonadCatch, MonadMask)

139+ , MonadCatch)

140

141instance MonadBase IO ClientM where

142 liftBase = ClientM . liftBase

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

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

163performRequest acceptStatus req = do

164 ClientEnv m burl cookieJar' createClientRequest <- ask

165− clientRequest <- liftIO $ createClientRequest burl req

165+ let clientRequest = createClientRequest burl req

166 request <- case cookieJar' of

167 Nothing -> pure clientRequest

168 Just cj -> liftIO $ do

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

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

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

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

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

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

233−defaultMakeClientRequest burl r = return Client.defaultRequest

233+defaultMakeClientRequest burl r = Client.defaultRequest

234 { Client.method = requestMethod r

235 , Client.host = fromString $ baseUrlHost burl

236 , Client.port = baseUrlPort burl

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

289 Https -> True

290

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

292− buildQueryString [] = mempty

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

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

294

293

295 addQueryParam qs (k, v) =

294 addQueryParam qs (k, v) =

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

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

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

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

24 (NFData, force)

25import Control.Exception

26 (evaluate, throwIO)

27−import Control.Monad

27+import Control.Monad ()

28− (unless)

29import Control.Monad.Base

28import Control.Monad.Base

30 (MonadBase (..))

29 (MonadBase (..))

31import Control.Monad.Codensity

30import Control.Monad.Codensity

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

141performRequest acceptStatus req = do

140performRequest acceptStatus req = do

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

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

143 ClientEnv m burl cookieJar' createClientRequest <- ask

142 ClientEnv m burl cookieJar' createClientRequest <- ask

144− clientRequest <- liftIO $ createClientRequest burl req

143+ let clientRequest = createClientRequest burl req

145 request <- case cookieJar' of

144 request <- case cookieJar' of

146 Nothing -> pure clientRequest

145 Nothing -> pure clientRequest

147 Just cj -> liftIO $ do

146 Just cj -> liftIO $ do

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

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

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

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

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

177performWithStreamingRequest req k = do

176performWithStreamingRequest req k = do

178− ClientEnv m burl cookieJar' createClientRequest <- ask

177+ m <- asks manager

179− clientRequest <- liftIO $ createClientRequest burl req

178+ burl <- asks baseUrl

180− request <- case cookieJar' of

179+ createClientRequest <- asks makeClientRequest

181− Nothing -> pure clientRequest

180+ let request = createClientRequest burl req

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

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

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

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

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

195 let status = Client.responseStatus res

183 let status = Client.responseStatus res

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

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

160 WithStatus 301 Text]

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

162 :<|> NamedRoutes RecordRoutes

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

164

163

165api :: Proxy Api

164api :: Proxy Api

166api = Proxy

165api = Proxy

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

215 :<|> EmptyClient

214 :<|> EmptyClient

216 :<|> uverbGetSuccessOrRedirect

215 :<|> uverbGetSuccessOrRedirect

217 :<|> uverbGetCreated

216 :<|> uverbGetCreated

218− :<|> recordRoutes

217+ :<|> recordRoutes = client api

219− :<|> captureVerbatim = client api

220

218

221server :: Application

219server :: Application

222server = serve api (

220server = serve api (

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

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

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

262 }

260 }

263 }

261 }

264− :<|> pure . decodeUtf8 . unVerbatim

265 )

262 )

266

263

267-- * api for testing failures

264-- * api for testing failures

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

373

370

374instance FromHttpApiData UrlEncodedByteString where

371instance FromHttpApiData UrlEncodedByteString where

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

372 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+1−11

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

36import Data.Monoid ()

37import Data.Text

38 (Text)

39−import Data.Text.Encoding

40− (encodeUtf8)

41import qualified Network.HTTP.Client as C

39import qualified Network.HTTP.Client as C

42import qualified Network.HTTP.Types as HTTP

40import qualified Network.HTTP.Types as HTTP

43import Test.Hspec

41import Test.Hspec

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

162 mgr <- C.newManager C.defaultManagerSettings

160 mgr <- C.newManager C.defaultManagerSettings

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

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

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

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

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

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

166− (defaultMakeClientRequest url r)

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

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

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

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

169 case res of

166 case res of

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

199 case eitherResponse of

196 case eitherResponse of

200 Left clientError -> fail $ show clientError

197 Left clientError -> fail $ show clientError

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

198 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

31 base >=4.9 && <5

32 , bytestring >=0.10.8.1 && <0.12

33 , conduit >=1.3.1 && <1.4

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

34+ , mtl >=2.2.2 && <2.3

35− , resourcet >=1.2.2 && <1.4

35+ , resourcet >=1.2.2 && <1.3

36 , servant >=0.15 && <0.20

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

38 hs-source-dirs: src

servant-docs/golden/comprehensive.md−18

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

530

531```

532

533−## GET /resource

534−

535−### Response:

536−

537−- Status code 200

538−- Headers: []

539−

540−- Supported content types are:

541−

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

543− - `application/json`

544−

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

546−

547−```javascript

548−

549−```

550−

551## GET /streaming

533## GET /streaming

552

534

553### Request:

535### Request:

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

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

41 --

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

43 build-depends:

44− base >= 4.9 && < 4.18

44+ base >= 4.9 && < 4.17

45 , bytestring >= 0.10.8.1 && < 0.12

46 , text >= 1.2.3.0 && < 2.1

47

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

59 , hashable >= 1.2.7.0 && < 1.5

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

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

62− , lens >= 4.17 && < 5.3

62+ , lens >= 4.17 && < 5.2

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

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

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

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

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

62import Servant.API

63import Servant.API.ContentTypes

64import Servant.API.TypeLevel

65−import Servant.API.Generic

66

65

67import qualified Data.Universe.Helpers as U

66import qualified Data.Universe.Helpers as U

68

67

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

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

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

448

447

449

448

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

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

451-- number of introduction(s)

450-- number of introduction(s)

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

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

453docsWithIntros intros = docsWith defaultDocOptions intros mempty

452docsWithIntros intros = docsWith defaultDocOptions intros mempty

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

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

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

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

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

1146

1145

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

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

1149−

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

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

1151 docsFor Proxy (endpoint, action) =

1147 docsFor Proxy (endpoint, action) =

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

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

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

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

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

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

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

1156

1152

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

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

1159−

1160-- ToSample instances for simple types

1153-- ToSample instances for simple types

1161instance ToSample NoContent

1154instance ToSample NoContent

1162instance ToSample Bool

1155instance ToSample Bool

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

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

41 --

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

43 build-depends:

44− base >= 4.9 && < 4.18

44+ base >= 4.9 && < 4.17

45 , text >= 1.2.3.0 && < 2.1

46

47 -- Servant dependencies

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

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

53 build-depends:

54 base-compat >= 0.10.5 && < 0.13

55− , lens >= 4.17 && < 5.3

55+ , lens >= 4.17 && < 5.2

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

57

58 hs-source-dirs: src

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

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

487

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

489

490−instance HasForeign lang ftype api =>

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

492−

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

494−

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

496−

497instance HasForeign lang ftype api

490instance HasForeign lang ftype api

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

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

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

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

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

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

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

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

40 build-depends:

41− base >= 4.9 && < 4.18

41+ base >= 4.9 && < 4.17

42 , bytestring >= 0.10.8.1 && < 0.12

43 , containers >= 0.5.7.1 && < 0.7

44 , deepseq >= 1.4.2.0 && < 1.5

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

45+ , mtl >= 2.2.2 && < 2.3

46 , text >= 1.2.3.0 && < 2.1

47− , time >= 1.6.0.1 && < 1.13

47+ , time >= 1.6.0.1 && < 1.12

48− , transformers >= 0.5.2.0 && < 0.7

48+ , transformers >= 0.5.2.0 && < 0.6

49

50 if !impl(ghc >= 8.2)

51 build-depends:

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

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

31 base >=4.9 && <5

32 , bytestring >=0.10.8.1 && <0.12

33 , machines >=0.6.4 && <0.8

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

34+ , mtl >=2.2.2 && <2.3

35 , servant >=0.15 && <0.20

36 hs-source-dirs: src

37 default-language: Haskell2010

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

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

32 , bytestring >=0.10.8.1 && <0.12

33 , pipes >=4.3.9 && <4.4

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

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

35+ , mtl >=2.2.2 && <2.3

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

37 , servant >=0.15 && <0.20

38 hs-source-dirs: src

servant-server/CHANGELOG.md−6

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

3

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

5

6−0.19.2

7−------

8−

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

10−

110.19.1

60.19.1

12------

7------

13

8

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

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

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

17

11

180.19

120.19

19----

13----

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

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

1cabal-version: 2.2

2name: servant-server

3−version: 0.19.2

3+version: 0.19.1

4

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

6category: Servant, Web

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

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

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

25build-type: Simple

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

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

27

28extra-source-files:

29 CHANGELOG.md

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

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

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

62 build-depends:

63− base >= 4.9 && < 4.18

63+ base >= 4.9 && < 4.17

64 , bytestring >= 0.10.8.1 && < 0.12

65 , constraints >= 0.2 && < 0.14

66 , containers >= 0.5.7.1 && < 0.7

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

67+ , mtl >= 2.2.2 && < 2.3

68 , text >= 1.2.3.0 && < 2.1

69− , transformers >= 0.5.2.0 && < 0.7

69+ , transformers >= 0.5.2.0 && < 0.6

70 , filepath >= 1.4.1.1 && < 1.5

71

72 -- Servant dependencies

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

74 build-depends:

75− servant >= 0.19 && < 0.20

75+ servant >= 0.19

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

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

77

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

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

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

88 , network >= 2.8 && < 3.2

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

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

91− , resourcet >= 1.2.2 && < 1.4

91+ , resourcet >= 1.2.2 && < 1.3

92 , tagged >= 0.8.6 && < 0.9

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

94− , wai >= 3.2.2.1 && < 3.3

94+ , wai >= 3.2.1.2 && < 3.3

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

96 , word8 >= 0.1.3 && < 0.2

97

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

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

235-- > │ └─ e/

236-- > │ └─•

237-- > ├─ b/

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

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

239-- > │ ├─•

240-- > │ ┆

241-- > │ └─•

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

252--

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

254--

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

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

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

257--

256--

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

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

259--

258--

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

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

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

2{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveFunctor #-}

4{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DeriveGeneric #-}

5{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

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

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

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

46newtype AuthHandler r usr = AuthHandler

45newtype AuthHandler r usr = AuthHandler

47 { unAuthHandler :: r -> Handler usr }

46 { unAuthHandler :: r -> Handler usr }

48− deriving (Functor, Generic, Typeable)

47+ deriving (Generic, Typeable)

49

48

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

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

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

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

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

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

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE CPP #-}

4{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

5{-# LANGUAGE DeriveDataTypeable #-}

4{-# LANGUAGE DeriveDataTypeable #-}

6{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE InstanceSigs #-}

7{-# LANGUAGE InstanceSigs #-}

9−{-# LANGUAGE LambdaCase #-}

10{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

11{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE OverloadedStrings #-}

12{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE PolyKinds #-}

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

36import Control.Monad

34import Control.Monad

37 (join, when)

35 (join, when)

38import Control.Monad.Trans

36import Control.Monad.Trans

39− (liftIO, lift)

37+ (liftIO)

40import Control.Monad.Trans.Resource

38import Control.Monad.Trans.Resource

41− (runResourceT, ReleaseKey)

39+ (runResourceT)

42−import Data.Acquire

43import qualified Data.ByteString as B

40import qualified Data.ByteString as B

44import qualified Data.ByteString.Builder as BB

41import qualified Data.ByteString.Builder as BB

45import qualified Data.ByteString.Char8 as BC8

42import qualified Data.ByteString.Char8 as BC8

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

66import Network.Socket

63import Network.Socket

67 (SockAddr)

64 (SockAddr)

68import Network.Wai

65import Network.Wai

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

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

70 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

67 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

71 requestMethod, responseLBS, responseStream, vault)

68 requestMethod, responseLBS, responseStream, vault)

72import Prelude ()

69import Prelude ()

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

76 CaptureAll, Description, EmptyAPI, Fragment,

73 CaptureAll, Description, EmptyAPI, Fragment,

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

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

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

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

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

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

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

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

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

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

82− WithNamedContext, WithResource, NamedRoutes)

79+ WithNamedContext, NamedRoutes)

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

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

84import Servant.API.ContentTypes

81import Servant.API.ContentTypes

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

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

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

97import Web.HttpApiData

94import Web.HttpApiData

98 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,

95 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,

99 parseUrlPieces)

96 parseUrlPieces)

100−import Data.Kind

101− (Type)

102

97

103import Servant.Server.Internal.BasicAuth

98import Servant.Server.Internal.BasicAuth

104import Servant.Server.Internal.Context

99import Servant.Server.Internal.Context

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

117 (AtLeastOneFragment, FragmentUnique)

112 (AtLeastOneFragment, FragmentUnique)

118

113

119class HasServer api context where

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

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

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

125

116

126 route ::

117 route ::

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

182-- > server = getBook

173-- > server = getBook

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

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

184-- > getBook isbn = ...

175-- > getBook isbn = ...

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

176+instance (KnownSymbol capture, FromHttpApiData a

186 , HasServer api context, SBoolI (FoldLenient mods)

177 , HasServer api context, SBoolI (FoldLenient mods)

187 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

178 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

188 )

179 )

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

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

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

195

186

196 route Proxy context d =

187 route Proxy context d =

197− CaptureRouter [hint] $

188+ CaptureRouter $

198 route (Proxy :: Proxy api)

189 route (Proxy :: Proxy api)

199 context

190 context

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

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

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

206 where

197 where

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

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

208 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

199 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

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

210

200

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

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

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

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

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

225-- > server = getSourceFile

215-- > server = getSourceFile

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

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

227-- > getSourceFile pathSegments = ...

217-- > getSourceFile pathSegments = ...

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

218+instance (KnownSymbol capture, FromHttpApiData a

229 , HasServer api context

219 , HasServer api context

230 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

220 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

231 )

221 )

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

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

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

238

228

239 route Proxy context d =

229 route Proxy context d =

240− CaptureAllRouter [hint] $

230+ CaptureAllRouter $

241 route (Proxy :: Proxy api)

231 route (Proxy :: Proxy api)

242 context

232 context

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

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

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

248 where

238 where

249 rep = typeRep (Proxy :: Proxy CaptureAll)

239 rep = typeRep (Proxy :: Proxy CaptureAll)

250 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

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

288

241

289allowedMethodHead :: Method -> Request -> Bool

242allowedMethodHead :: Method -> Request -> Bool

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

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

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

653 Fail a -> respond $ Fail a

606 Fail a -> respond $ Fail a

654 FailFatal e -> respond $ FailFatal e

607 FailFatal e -> respond $ FailFatal e

655

608

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−

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

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

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

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

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

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

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

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

819-------------------------------------------------------------------------------

896

820

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

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

898−instance TypeError (PartialApplication

899−#if __GLASGOW_HASKELL__ >= 904

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

901−#endif

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

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

903 where

823 where

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

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

905 route = error "unreachable"

825 route = error "unreachable"

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

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

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

944--

864--

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

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

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

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

947−#if __GLASGOW_HASKELL__ >= 904

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

949−#endif

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

951

867

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

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

953

869

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

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

9

10import Data.Function

11 (on)

12−import Data.List

13− (nub)

14import Data.Map

12import Data.Map

15 (Map)

13 (Map)

16import qualified Data.Map as M

14import qualified Data.Map as M

17import Data.Text

15import Data.Text

18 (Text)

16 (Text)

19import qualified Data.Text as T

17import qualified Data.Text as T

20−import Data.Typeable

21− (TypeRep)

22import Network.Wai

18import Network.Wai

23 (Response, pathInfo)

19 (Response, pathInfo)

24import Servant.Server.Internal.ErrorFormatter

20import Servant.Server.Internal.ErrorFormatter

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

28

24

29type Router env = Router' env RoutingApplication

25type Router env = Router' env RoutingApplication

30

26

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−

46-- | Internal representation of a router.

27-- | Internal representation of a router.

47--

28--

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

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

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

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

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

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

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

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

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

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

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

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

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

60− -- environment and removed afterwards.

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

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

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

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

71 -- environment and are removed afterwards

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

75 | RawRouter (env -> a)

45 | RawRouter (env -> a)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

73+ CaptureRouter (choice router1 router2)

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

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

105choice router1 router2 = Choice router1 router2

75choice router1 router2 = Choice router1 router2

106

76

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

114--

84--

115data RouterStructure =

85data RouterStructure =

116 StaticRouterStructure (Map Text RouterStructure) Int

86 StaticRouterStructure (Map Text RouterStructure) Int

117− | CaptureRouterStructure [CaptureHint] RouterStructure

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

122 | RawRouterStructure

88 | RawRouterStructure

123 | ChoiceStructure RouterStructure RouterStructure

89 | ChoiceStructure RouterStructure RouterStructure

124 deriving (Eq, Show)

90 deriving (Eq, Show)

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

132routerStructure :: Router' env a -> RouterStructure

98routerStructure :: Router' env a -> RouterStructure

133routerStructure (StaticRouter m ls) =

99routerStructure (StaticRouter m ls) =

134 StaticRouterStructure (fmap routerStructure m) (length ls)

100 StaticRouterStructure (fmap routerStructure m) (length ls)

135−routerStructure (CaptureRouter hints router) =

101+routerStructure (CaptureRouter router) =

136− CaptureRouterStructure hints $

102+ CaptureRouterStructure $

137 routerStructure router

103 routerStructure router

138−routerStructure (CaptureAllRouter hints router) =

104+routerStructure (CaptureAllRouter router) =

139− CaptureRouterStructure hints $

105+ CaptureRouterStructure $

140 routerStructure router

106 routerStructure router

141routerStructure (RawRouter _) =

107routerStructure (RawRouter _) =

142 RawRouterStructure

108 RawRouterStructure

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

148-- | Compare the structure of two routers.

114-- | Compare the structure of two routers.

149--

115--

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

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

151−sameStructure router1 router2 =

117+sameStructure r1 r2 =

152− routerStructure router1 == routerStructure router2

118+ routerStructure r1 == routerStructure r2

153

119

154-- | Provide a textual representation of the

120-- | Provide a textual representation of the

155-- structure of a router.

121-- structure of a router.

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

160 where

126 where

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

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

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

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

163− mkRouterLayout c (CaptureRouterStructure hints r) =

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

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

165 mkRouterLayout c RawRouterStructure =

130 mkRouterLayout c RawRouterStructure =

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

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

167 mkRouterLayout c (ChoiceStructure r1 r2) =

132 mkRouterLayout c (ChoiceStructure r1 r2) =

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

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

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

205 in runRouterEnv fmt router' env request' respond

170 in runRouterEnv fmt router' env request' respond

206 _ -> respond $ Fail $ fmt request

171 _ -> respond $ Fail $ fmt request

207− CaptureRouter _ router' ->

172+ CaptureRouter router' ->

208 case pathInfo request of

173 case pathInfo request of

209 [] -> respond $ Fail $ fmt request

174 [] -> respond $ Fail $ fmt request

210 -- This case is to handle trailing slashes.

175 -- This case is to handle trailing slashes.

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

212 first : rest

177 first : rest

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

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

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

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

215− CaptureAllRouter _ router' ->

180+ CaptureAllRouter router' ->

216 let segments = pathInfo request

181 let segments = pathInfo request

217 request' = request { pathInfo = [] }

182 request' = request { pathInfo = [] }

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

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

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

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

9import Data.Proxy

10 (Proxy (..))

11import Data.Text

12− (Text, unpack)

12+ (unpack)

13−import Data.Typeable

14− (typeRep)

15import Network.HTTP.Types

13import Network.HTTP.Types

16 (Status (..))

14 (Status (..))

17import Network.Wai

15import Network.Wai

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

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

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

30 routerSpec

28 routerSpec

31 distributivitySpec

29 distributivitySpec

32− serverLayoutSpec

33

30

34routerSpec :: Spec

31routerSpec :: Spec

35routerSpec = do

32routerSpec = do

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

54 toApp = toApplication . runRouter (const err404)

51 toApp = toApplication . runRouter (const err404)

55

52

56 cap :: Router ()

53 cap :: Router ()

57− cap = CaptureRouter [hint] $

54+ cap = CaptureRouter $

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

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

59 in leafRouter

56 in leafRouter

60 $ \env req res ->

57 $ \env req res ->

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

62 . const

59 . const

63 $ Route success

60 $ Route success

64

61

65− hint :: CaptureHint

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

67−

68 router :: Router ()

62 router :: Router ()

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

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

70 `Choice` cap

64 `Choice` cap

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

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

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

105 level `shouldHaveSameStructureAs` levelRef

99 level `shouldHaveSameStructureAs` levelRef

106

100

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−

119shouldHaveSameStructureAs ::

101shouldHaveSameStructureAs ::

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

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

121shouldHaveSameStructureAs p1 p2 =

103shouldHaveSameStructureAs p1 p2 =

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

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

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

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

124

106

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−

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

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

132makeTrivialRouter p =

108makeTrivialRouter p =

133 route p EmptyContext (emptyDelayed (FailFatal err501))

109 route p EmptyContext (emptyDelayed (FailFatal err501))

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

168-- structure:

144-- structure:

169

145

170type Dynamic =

146type Dynamic =

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

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

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

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

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

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

174

150

175type DynamicRef =

151type DynamicRef =

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

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

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

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

178

154

179dynamic :: Proxy Dynamic

155dynamic :: Proxy Dynamic

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

363

339

364levelRef :: Proxy LevelRef

340levelRef :: Proxy LevelRef

365levelRef = Proxy

341levelRef = 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+6−54

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

17

18import Control.Monad

19 (forM_, unless, when)

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

21import Control.Monad.Error.Class

20import Control.Monad.Error.Class

22 (MonadError (..))

21 (MonadError (..))

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

24import Data.Aeson

22import Data.Aeson

25 (FromJSON, ToJSON, decode', encode)

23 (FromJSON, ToJSON, decode', encode)

26−import Data.Acquire

27− (Acquire, mkAcquire)

28import qualified Data.ByteString as BS

24import qualified Data.ByteString as BS

29import qualified Data.ByteString.Base64 as Base64

25import qualified Data.ByteString.Base64 as Base64

30import Data.Char

26import Data.Char

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

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

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

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

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

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

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

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

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

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

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

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

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

62import Servant.Server

58import Servant.Server

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

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

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

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

65 serveWithContext)

61 serveWithContext)

66import Servant.Test.ComprehensiveAPI

62import Servant.Test.ComprehensiveAPI

67import qualified Servant.Types.SourceT as S

63import qualified Servant.Types.SourceT as S

68import Test.Hspec

64import Test.Hspec

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

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

70import Test.Hspec.Wai

66import Test.Hspec.Wai

71− (get, matchHeaders, matchStatus, shouldRespondWith,

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

72 with, (<:>))

68 with, (<:>))

73import qualified Test.Hspec.Wai as THW

69import qualified Test.Hspec.Wai as THW

74

70

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

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

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

86_ = serveWithContext comprehensiveAPI comprehensiveApiContext

82_ = serveWithContext comprehensiveAPI comprehensiveApiContext

87

83

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

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

89−comprehensiveApiContext =

90− NamedContext EmptyContext :.

85+comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext

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

92− EmptyContext

93

86

94-- * Specs

87-- * Specs

95

88

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

104 reqBodySpec

97 reqBodySpec

105 headerSpec

98 headerSpec

106 rawSpec

99 rawSpec

107− rawMSpec

108 alternativeSpec

100 alternativeSpec

109 responseHeadersSpec

101 responseHeadersSpec

110 uverbResponseHeadersSpec

102 uverbResponseHeadersSpec

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

613

605

614-- }}}

606-- }}}

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

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

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

656-- * alternativeSpec {{{

608-- * alternativeSpec {{{

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

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

658type AlternativeApi =

610type AlternativeApi =

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

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

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

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

79 , lens >=4.17 && <6

80− , servant >=0.18.2 && <0.20

80+ , servant >=0.18.1 && <0.20

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

82 , swagger2 >=2.3.0.1 && <3

83 , text >=1.2.3.0 && <2.1

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

106 type: exitcode-stdio-1.0

107 hs-source-dirs: test

108 main-is: Spec.hs

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

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

110 build-depends: base

111 , base-compat

112 , aeson >=1.4.2.0 && <3

113− , hspec >=2.6.0 && <2.11

113+ , hspec >=2.6.0 && <2.10

114 , QuickCheck

115 , lens

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

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

117 , servant

118 , servant-swagger

119 , swagger2

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

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

55-- >>> import Data.Typeable

56-- >>> import GHC.Generics

57-- >>> import Servant.API

58−-- >>> import System.Environment

59-- >>> import Test.Hspec

58-- >>> import Test.Hspec

60-- >>> import Test.QuickCheck

59-- >>> import Test.QuickCheck

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

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

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

65-- >>> :set -XGeneralizedNewtypeDeriving

64-- >>> :set -XGeneralizedNewtypeDeriving

66-- >>> :set -XOverloadedStrings

65-- >>> :set -XOverloadedStrings

67-- >>> :set -XTypeOperators

66-- >>> :set -XTypeOperators

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

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

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

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

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

71-- >>> instance ToJSON User

69-- >>> instance ToJSON User

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

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

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE OverloadedLists #-}

7{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE OverloadedStrings #-}

8{-# LANGUAGE PolyKinds #-}

7{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeOperators #-}

10{-# LANGUAGE TypeOperators #-}

12−{-# LANGUAGE TypeFamilies #-}

13#if __GLASGOW_HASKELL__ >= 806

11#if __GLASGOW_HASKELL__ >= 806

14{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

15#endif

13#endif

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

32import Data.Swagger.Declare

30import Data.Swagger.Declare

33import Data.Text (Text)

31import Data.Text (Text)

34import qualified Data.Text as Text

32import qualified Data.Text as Text

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

36import GHC.TypeLits

33import GHC.TypeLits

37import Network.HTTP.Media (MediaType)

34import Network.HTTP.Media (MediaType)

38import Servant.API

35import Servant.API

39import Servant.API.Description (FoldDescription,

36import Servant.API.Description (FoldDescription,

40 reflectDescription)

37 reflectDescription)

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

42import Servant.API.Modifiers (FoldRequired)

38import Servant.API.Modifiers (FoldRequired)

43

39

44import Servant.Swagger.Internal.TypeLevel.API

40import Servant.Swagger.Internal.TypeLevel.API

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

153addParam :: Param -> Swagger -> Swagger

149addParam :: Param -> Swagger -> Swagger

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

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

155

151

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

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

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

159−

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

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

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

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

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

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

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

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

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

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

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

306

298

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−

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

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

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

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

313 where

301 where

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

451 & required ?~ True

439 & required ?~ True

452 & schema .~ ParamBody ref

440 & schema .~ ParamBody ref

453

441

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−

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

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

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

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

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

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

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

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

29-- >>> import Control.Applicative

30-- >>> import GHC.Generics

31-- >>> import Test.QuickCheck

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

33-- >>> :set -XDeriveGeneric

32-- >>> :set -XDeriveGeneric

34-- >>> :set -XGeneralizedNewtypeDeriving

33-- >>> :set -XGeneralizedNewtypeDeriving

35-- >>> :set -XDataKinds

34-- >>> :set -XDataKinds

36-- >>> :set -XTypeOperators

35-- >>> :set -XTypeOperators

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

38

36

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

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

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

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

servant/CHANGELOG.md−5

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

2

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

4

5−0.19.1

6−------

7−

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

9−

100.19

50.19

11----

6----

12

7

servant/servant.cabal+5−6

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

1cabal-version: 2.2

2name: servant

3−version: 0.19.1

3+version: 0.19

4

5synopsis: A family of combinators for defining webservices APIs

6category: Servant, Web

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

62 Servant.API.Vault

63 Servant.API.Verbs

64 Servant.API.WithNamedContext

65− Servant.API.WithResource

66

65

67 -- Types

66 -- Types

68 exposed-modules:

67 exposed-modules:

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

81 --

80 --

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

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

83 build-depends:

82 build-depends:

84− base >= 4.9 && < 4.18

83+ base >= 4.9 && < 4.17

85 , bytestring >= 0.10.8.1 && < 0.12

84 , bytestring >= 0.10.8.1 && < 0.12

86 , constraints >= 0.2

85 , constraints >= 0.2

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

86+ , mtl >= 2.2.2 && < 2.3

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

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

89− , transformers >= 0.5.2.0 && < 0.7

88+ , transformers >= 0.5.2.0 && < 0.6

90 , text >= 1.2.3.0 && < 2.1

89 , text >= 1.2.3.0 && < 2.1

91

90

92

91

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

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

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

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

95 build-depends:

94 build-depends:

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

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

97 , singleton-bool >= 0.1.4 && < 0.1.7

96 , singleton-bool >= 0.1.4 && < 0.1.7

98

97

99 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

98 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

servant/src/Servant/API.hs+6−10

@@ -31,8 +31,6 @@ module Servant.API (

31 -- | Access the location for arbitrary data to be shared by applications and middleware

32 module Servant.API.WithNamedContext,

33 -- | Access context entries in combinators in servant-server

34− module Servant.API.WithResource,

35− -- | Access a managed resource scoped to a single request

36

34

37 -- * Actual endpoints, distinguished by HTTP method

35 -- * Actual endpoints, distinguished by HTTP method

38 module Servant.API.Verbs,

36 module Servant.API.Verbs,

@@ -103,23 +101,21 @@ import Servant.API.Experimental.Auth

103 (AuthProtect)

101 (AuthProtect)

104import Servant.API.Fragment

102import Servant.API.Fragment

105 (Fragment)

103 (Fragment)

106−import Servant.API.Generic

107− (AsApi, GServantProduct, GenericMode ((:-)), GenericServant,

108− ToServant, ToServantApi, fromServant, genericApi, toServant)

109import Servant.API.Header

104import Servant.API.Header

110 (Header, Header')

105 (Header, Header')

106+import Servant.API.Generic

107+ (GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct,

108+ GenericServant, fromServant, toServant, genericApi)

111import Servant.API.HttpVersion

109import Servant.API.HttpVersion

112 (HttpVersion (..))

110 (HttpVersion (..))

113import Servant.API.IsSecure

111import Servant.API.IsSecure

114 (IsSecure (..))

112 (IsSecure (..))

115import Servant.API.Modifiers

113import Servant.API.Modifiers

116 (Lenient, Optional, Required, Strict)

114 (Lenient, Optional, Required, Strict)

117−import Servant.API.NamedRoutes

118− (NamedRoutes)

119import Servant.API.QueryParam

115import Servant.API.QueryParam

120 (QueryFlag, QueryParam, QueryParam', QueryParams)

116 (QueryFlag, QueryParam, QueryParam', QueryParams)

121import Servant.API.Raw

117import Servant.API.Raw

122− (Raw, RawM)

118+ (Raw)

123import Servant.API.RemoteHost

119import Servant.API.RemoteHost

124 (RemoteHost)

120 (RemoteHost)

125import Servant.API.ReqBody

121import Servant.API.ReqBody

@@ -141,6 +137,8 @@ import Servant.API.UVerb

141 Unique, WithStatus (..), inject, statusOf)

137 Unique, WithStatus (..), inject, statusOf)

142import Servant.API.Vault

138import Servant.API.Vault

143 (Vault)

139 (Vault)

140+import Servant.API.NamedRoutes

141+ (NamedRoutes)

144import Servant.API.Verbs

142import Servant.API.Verbs

145 (Delete, DeleteAccepted, DeleteNoContent,

143 (Delete, DeleteAccepted, DeleteNoContent,

146 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

144 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

@@ -152,8 +150,6 @@ import Servant.API.Verbs

152 ReflectMethod (reflectMethod), StdMethod (..), Verb)

150 ReflectMethod (reflectMethod), StdMethod (..), Verb)

153import Servant.API.WithNamedContext

151import Servant.API.WithNamedContext

154 (WithNamedContext)

152 (WithNamedContext)

155−import Servant.API.WithResource

156− (WithResource)

157import Servant.Links

153import Servant.Links

158 (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)

154 (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)

159import Web.HttpApiData

155import Web.HttpApiData

servant/src/Servant/API/ContentTypes.hs+1−1

@@ -295,7 +295,7 @@ instance {-# OVERLAPPABLE #-}

295-- then this would be taken care of. However there is no more specific instance

296-- between that and 'MimeRender JSON a', so we do this instead

297instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where

298− allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp

298+ allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp

299 where

300 pctyp = Proxy :: Proxy ctyp

301

servant/src/Servant/API/Raw.hs−3

@@ -15,6 +15,3 @@ import Data.Typeable

15-- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles>

16-- to serve static files stored in a particular directory on your filesystem

17data Raw deriving Typeable

18−

19−-- | Variant of 'Raw' that lets you access the underlying monadic context to process the request.

20−data RawM deriving Typeable

servant/src/Servant/API/ResponseHeaders.hs−23

@@ -8,7 +8,6 @@

8{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeFamilies #-}

11−{-# LANGUAGE TypeFamilyDependencies #-}

12{-# LANGUAGE TypeOperators #-}

11{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

14{-# OPTIONS_HADDOCK not-home #-}

13{-# OPTIONS_HADDOCK not-home #-}

@@ -52,9 +51,6 @@ import Prelude ()

52import Prelude.Compat

51import Prelude.Compat

53import Servant.API.Header

52import Servant.API.Header

54 (Header)

53 (Header)

55−import Servant.API.UVerb.Union

56−import qualified Data.SOP.BasicFunctors as SOP

57−import qualified Data.SOP.NS as SOP

58

54

59-- | Response Header objects. You should never need to construct one directly.

55-- | Response Header objects. You should never need to construct one directly.

60-- Instead, use 'addOptionalHeader'.

56-- Instead, use 'addOptionalHeader'.

@@ -174,25 +170,6 @@ instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '

174 => AddHeader h v a new where

170 => AddHeader h v a new where

175 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)

171 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)

176

172

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−

196-- | @addHeader@ adds a header to a response. Note that it changes the type of

173-- | @addHeader@ adds a header to a response. Note that it changes the type of

197-- the value in the following ways:

174-- the value in the following ways:

198--

175--

servant/src/Servant/API/TypeLevel.hs+3−3

@@ -110,7 +110,7 @@ type family IsElem' a s :: Constraint

110--

111-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))

112-- ...

113−-- ... Could not ...

113+-- ... Could not deduce...

114-- ...

115--

116-- An endpoint is considered within an api even if it is missing combinators

@@ -151,7 +151,7 @@ type family IsElem endpoint api :: Constraint where

151--

152-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI))

153-- ...

154−-- ... Could not ...

154+-- ... Could not deduce...

155-- ...

156--

157-- This uses @IsElem@ for checking; thus the note there applies here.

@@ -174,7 +174,7 @@ type family AllIsElem xs api :: Constraint where

174--

175-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))

176-- ...

177−-- ... Could not ...

177+-- ... Could not deduce...

178-- ...

179type family IsIn (endpoint :: *) (api :: *) :: Constraint where

180 IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)

servant/src/Servant/API/UVerb.hs−3

@@ -38,7 +38,6 @@ import GHC.TypeLits (Nat)

38import Network.HTTP.Types (Status, StdMethod)

39import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))

40import Servant.API.Status (KnownStatus, statusVal)

41−import Servant.API.ResponseHeaders (Headers)

42import Servant.API.UVerb.Union

41import Servant.API.UVerb.Union

43

42

44class KnownStatus (StatusOf a) => HasStatus (a :: *) where

43class KnownStatus (StatusOf a) => HasStatus (a :: *) where

@@ -87,8 +86,6 @@ newtype WithStatus (k :: Nat) a = WithStatus a

87instance KnownStatus n => HasStatus (WithStatus n a) where

86instance KnownStatus n => HasStatus (WithStatus n a) where

88 type StatusOf (WithStatus n a) = n

87 type StatusOf (WithStatus n a) = n

89

88

90−instance HasStatus a => HasStatus (Headers ls a) where

91− type StatusOf (Headers ls a) = StatusOf a

92

89

93-- | A variant of 'Verb' that can have any of a number of response values and status codes.

90-- | A variant of 'Verb' that can have any of a number of response values and status codes.

94--

91--

servant/src/Servant/API/UVerb/Union.hs+2−2

@@ -128,9 +128,9 @@ type DuplicateElementError (rs :: [k]) =

128 ':$$: 'Text " " ':<>: 'ShowType rs

129

130type family Elem (x :: k) (xs :: [k]) :: Bool where

131− Elem x (x ': _) = 'True

132− Elem x (_ ': xs) = Elem x xs

133 Elem _ '[] = 'False

131 Elem _ '[] = 'False

132+ Elem x (x' ': xs) =

133+ If (x == x') 'True (Elem x xs)

134

135type family Unique xs :: Constraint where

136 Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))

servant/src/Servant/API/WithResource.hsdeleted−3

@@ -1,3 +0,0 @@

1−module Servant.API.WithResource (WithResource) where

2−

3−data WithResource res

servant/src/Servant/Links.hs+4−25

@@ -1,6 +1,5 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE CPP #-}

4{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

5{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

@@ -92,7 +91,7 @@

92-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)

91-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)

93-- >>> safeLink api bad_link

92-- >>> safeLink api bad_link

94-- ...

93-- ...

95−-- ...Could not ...

94+-- ...Could not deduce...

96-- ...

95-- ...

97--

96--

98-- This error is essentially saying that the type family couldn't find

97-- This error is essentially saying that the type family couldn't find

@@ -175,7 +174,7 @@ import Servant.API.NamedRoutes

175import Servant.API.QueryParam

174import Servant.API.QueryParam

176 (QueryFlag, QueryParam', QueryParams)

175 (QueryFlag, QueryParam', QueryParams)

177import Servant.API.Raw

176import Servant.API.Raw

178− (Raw, RawM)

177+ (Raw)

179import Servant.API.RemoteHost

178import Servant.API.RemoteHost

180 (RemoteHost)

179 (RemoteHost)

181import Servant.API.ReqBody

180import Servant.API.ReqBody

@@ -193,11 +192,7 @@ import Servant.API.Verbs

193 (Verb, NoContentVerb)

192 (Verb, NoContentVerb)

194import Servant.API.WithNamedContext

193import Servant.API.WithNamedContext

195 (WithNamedContext)

194 (WithNamedContext)

196−import Servant.API.WithResource

197− (WithResource)

198import Web.HttpApiData

195import Web.HttpApiData

199−import Data.Kind

200− (Type)

201

196

202-- | A safe link datatype.

197-- | A safe link datatype.

203-- The only way of constructing a 'Link' is using 'safeLink', which means any

198-- The only way of constructing a 'Link' is using 'safeLink', which means any

@@ -560,10 +555,6 @@ instance HasLink sub => HasLink (WithNamedContext name context sub) where

560 type MkLink (WithNamedContext name context sub) a = MkLink sub a

555 type MkLink (WithNamedContext name context sub) a = MkLink sub a

561 toLink toA _ = toLink toA (Proxy :: Proxy sub)

556 toLink toA _ = toLink toA (Proxy :: Proxy sub)

562

557

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−

567instance HasLink sub => HasLink (RemoteHost :> sub) where

558instance HasLink sub => HasLink (RemoteHost :> sub) where

568 type MkLink (RemoteHost :> sub) a = MkLink sub a

559 type MkLink (RemoteHost :> sub) a = MkLink sub a

569 toLink = simpleToLink (Proxy :: Proxy sub)

560 toLink = simpleToLink (Proxy :: Proxy sub)

@@ -589,10 +580,6 @@ instance HasLink Raw where

589 type MkLink Raw a = a

580 type MkLink Raw a = a

590 toLink toA _ = toA

581 toLink toA _ = toA

591

582

592−instance HasLink RawM where

593− type MkLink RawM a = a

594− toLink toA _ = toA

595−

596instance HasLink (Stream m status fr ct a) where

583instance HasLink (Stream m status fr ct a) where

597 type MkLink (Stream m status fr ct a) r = r

584 type MkLink (Stream m status fr ct a) r = r

598 toLink toA _ = toA

585 toLink toA _ = toA

@@ -660,20 +647,12 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)

660-- >>> import Data.Text (Text)

647-- >>> import Data.Text (Text)

661

648

662-- Erroring instance for 'HasLink' when a combinator is not fully applied

649-- Erroring instance for 'HasLink' when a combinator is not fully applied

663−instance TypeError (PartialApplication

650+instance TypeError (PartialApplication HasLink arr) => HasLink ((arr :: a -> b) :> sub)

664−#if __GLASGOW_HASKELL__ >= 904

665− @(Type -> Constraint)

666−#endif

667− HasLink arr) => HasLink ((arr :: a -> b) :> sub)

668 where

651 where

669 type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)

652 type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)

670 toLink = error "unreachable"

653 toLink = error "unreachable"

671

654

672-- Erroring instances for 'HasLink' for unknown API combinators

655-- Erroring instances for 'HasLink' for unknown API combinators

673−instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub

656+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasLink ty) => HasLink (ty :> sub)

674−#if __GLASGOW_HASKELL__ >= 904

675− @(Type -> Constraint)

676−#endif

677− HasLink ty) => HasLink (ty :> sub)

678

657

679instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api

658instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api

servant/src/Servant/Test/ComprehensiveAPI.hs−1

@@ -72,7 +72,6 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =

72 :<|> "description" :> Description "foo" :> GET

73 :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)

74 :<|> "fragment" :> Fragment Int :> GET

75− :<|> "resource" :> WithResource Int :> GET

76 :<|> endpoint

75 :<|> endpoint

77

76

78type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint

77type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint

servant/src/Servant/Types/SourceT.hs−3

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveFunctor #-}

1{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE RankNTypes #-}

@@ -155,10 +154,8 @@ instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where

155-- | >>> lift [1,2,3] :: StepT [] Int

154-- | >>> lift [1,2,3] :: StepT [] Int

156-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]

155-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]

157--

156--

158−#if !MIN_VERSION_transformers(0,6,0)

159instance MonadTrans StepT where

157instance MonadTrans StepT where

160 lift = Effect . fmap (`Yield` Stop)

158 lift = Effect . fmap (`Yield` Stop)

161−#endif

162

159

163instance MFunctor StepT where

160instance MFunctor StepT where

164 hoist f = go where

161 hoist f = go where

servant/test/Servant/API/ContentTypesSpec.hs−11

@@ -33,8 +33,6 @@ import Data.String.Conversions

33import qualified Data.Text as TextS

34import qualified Data.Text.Encoding as TextSE

35import qualified Data.Text.Lazy as TextL

36−import Control.Exception

37− (evaluate)

38import GHC.Generics

36import GHC.Generics

39import Test.Hspec

37import Test.Hspec

40import Test.QuickCheck

38import Test.QuickCheck

@@ -80,15 +78,6 @@ spec = describe "Servant.API.ContentTypes" $ do

80 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

78 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

81 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

79 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

82

80

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−

92 describe "The PlainText Content-Type type" $ do

81 describe "The PlainText Content-Type type" $ do

93 let p = Proxy :: Proxy PlainText

82 let p = Proxy :: Proxy PlainText

94

83

servant/test/Servant/API/ResponseHeadersSpec.hs−11

@@ -2,14 +2,10 @@

2{-# LANGUAGE OverloadedStrings #-}

3module Servant.API.ResponseHeadersSpec where

4

5−import Data.Proxy

6−import GHC.TypeLits

7import Test.Hspec

5import Test.Hspec

8

6

9−import Servant.API.ContentTypes

10import Servant.API.Header

7import Servant.API.Header

11import Servant.API.ResponseHeaders

8import Servant.API.ResponseHeaders

12−import Servant.API.UVerb

13

9

14spec :: Spec

10spec :: Spec

15spec = describe "Servant.API.ResponseHeaders" $ do

11spec = describe "Servant.API.ResponseHeaders" $ do

@@ -32,10 +28,3 @@ spec = describe "Servant.API.ResponseHeaders" $ do

32 it "does not add a header" $ do

28 it "does not add a header" $ do

33 let val = noHeader 5 :: Headers '[Header "test" Int] Int

29 let val = noHeader 5 :: Headers '[Header "test" Int] Int

34 getHeaders val `shouldBe` []

30 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−