73c87bc...master · servant

.github/workflows/master.yml+51−62

since splitsnapshots

unifiedsplit

@@ -13,12 +13,14 @@ jobs:

13 strategy:

14 matrix:

15 os: [ubuntu-latest]

16− cabal: ["3.4"]

16+ cabal: ["3.6"]

17 ghc:

18 - "8.6.5"

19 - "8.8.4"

20 - "8.10.7"

21− - "9.0.1"

21+ - "9.0.2"

22+ - "9.2.2"

23+ - "9.4.2"

22

24

23 steps:

25 steps:

24 - uses: actions/checkout@v2

26 - uses: actions/checkout@v2

@@ -47,10 +49,7 @@ jobs:

47

49

48 - name: Configure

50 - name: Configure

49 run: |

51 run: |

50− # Using separate store-dir because default one already has 'ghc-paths' package installed

51− # with hardcoded path to ghcup's GHC path (which it was built with). This leads to failure in

52− # doctest, as it tries to invoke that GHC, and it doesn't exist here.

53− cabal --store-dir /tmp/cabal-store install --ignore-project -j2 doctest --constraint='doctest ^>=0.18'

52+ cabal install --ignore-project -j2 doctest --constraint='doctest ^>=0.20'

54

53

55 - name: Build

54 - name: Build

56 run: |

55 run: |

@@ -61,66 +60,56 @@ jobs:

61 cabal test all

60 cabal test all

62

61

63 - name: Run doctests

62 - name: Run doctests

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

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

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

67 run: |

63 run: |

68 # Necessary for doctest to be found in $PATH

64 # Necessary for doctest to be found in $PATH

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

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

70

66

71− # Filter out base-compat-batteries from .ghc.environment.*, as its modules

67+ DOCTEST="cabal repl --with-ghc=doctest --ghc-options=-w"

72− # conflict with those of base-compat.

73− #

74− # FIXME: This is an ugly hack. Ultimately, we'll want to use cabal-doctest

75− # (or cabal v2-doctest, if it ever lands) to provide a clean GHC environment.

76− # This might allow running doctests in GHCJS build as well.

77− perl -i -e 'while (<ARGV>) { print unless /package-id\s+(base-compat-batteries)-\d+(\.\d+)*/; }' .ghc.environment.*

78−

79− (cd servant && doctest src)

68+ (cd servant && eval $DOCTEST)

80− (cd servant-client && doctest src)

69+ (cd servant-client && eval $DOCTEST)

81− (cd servant-client-core && doctest src)

70+ (cd servant-client-core && eval $DOCTEST)

82− (cd servant-http-streams && doctest src)

71+ (cd servant-http-streams && eval $DOCTEST)

83− (cd servant-docs && doctest src)

72+ (cd servant-docs && eval $DOCTEST)

84− (cd servant-foreign && doctest src)

73+ (cd servant-foreign && eval $DOCTEST)

85− (cd servant-server && doctest src)

74+ (cd servant-server && eval $DOCTEST)

86− (cd servant-machines && doctest src)

75+ (cd servant-machines && eval $DOCTEST)

87− (cd servant-conduit && doctest src)

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

88− (cd servant-pipes && doctest src)

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

89−

78+

90− stack:

79+ # stack:

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

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

92− runs-on: ubuntu-latest

81+ # runs-on: ubuntu-latest

93− strategy:

82+ # strategy:

94− matrix:

83+ # matrix:

95− stack: ["2.7.3"]

84+ # stack: ["2.7.5"]

96− ghc: ["8.10.4"]

85+ # ghc: ["8.10.7"]

97−

86+

98− steps:

87+ # steps:

99− - uses: actions/checkout@v2

88+ # - uses: actions/checkout@v2

100−

89+

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

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

102− name: Setup Haskell Stack

91+ # name: Setup Haskell Stack

103− with:

92+ # with:

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

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

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

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

106−

95+

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

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

108− name: Cache ~/.stack

97+ # name: Cache ~/.stack

109− with:

98+ # with:

110− path: ~/.stack

99+ # path: ~/.stack

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

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

112−

101+

113− - name: Install dependencies

102+ # - name: Install dependencies

114− run: |

103+ # run: |

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

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

116−

105+

117− - name: Build

106+ # - name: Build

118− run: |

107+ # run: |

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

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

120−

109+

121− - name: Test

110+ # - name: Test

122− run: |

111+ # run: |

123− stack test --system-ghc

112+ # stack test --system-ghc

124

113

125 ghcjs:

114 ghcjs:

126 name: ubuntu-latest / ghcjs 8.6

115 name: ubuntu-latest / ghcjs 8.6

CONTRIBUTING.md+4−2

@@ -79,8 +79,10 @@ not been a timely response to a PR, you can ping the Maintainers group (with

79We encourage people to experiment with new combinators and instances - it is

80one of the most powerful ways of using `servant`, and a wonderful way of

81getting to know it better. If you do write a new combinator, we would love to

82−know about it! Either hop on #servant on freenode and let us know, or open an

82+know about it! Either hop on

83+[#haskell-servant on libera.chat](https://web.libera.chat/#haskell-servant) and

83−issue with the `news` tag (which we will close when we read it).

84+let us know, or open an issue with the `news` tag (which we will close when we

85+read it).

84

86

85As for adding them to the main repo: maintaining combinators can be expensive,

87As for adding them to the main repo: maintaining combinators can be expensive,

86since official combinators must have instances for all classes (and new classes

88since official combinators must have instances for all classes (and new classes

cabal.project+1−23

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

47 doc/cookbook/using-custom-monad

48 doc/cookbook/using-free-client

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

50+ doc/cookbook/managed-resource

50

51

51tests: True

52tests: True

52optimization: False

53optimization: False

53-- reorder-goals: True

54-- reorder-goals: True

54−

55−constraints:

56− -- see https://github.com/haskell-infra/hackage-trustees/issues/119

57− foundation >=0.0.14,

58− memory <0.14.12 || >0.14.12

59−

60−constraints: base-compat ^>=0.11

61−constraints: semigroups ^>=0.19

62−

63−-- allow-newer: sqlite-simple-0.4.16.0:semigroups

64−-- allow-newer: direct-sqlite-2.3.24:semigroups

65−

66−-- needed for doctests

67−write-ghc-environment-files: always

68−

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

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

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

72−

73−allow-newer: servant-js:servant

74−

75−-- ghc 9

76−allow-newer: tdigest:base

changelog.d/1529new file+10

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

1+synopsis: Fix performRequest in servant-client-ghcjs

2+prs: #1529

3+

4+description: {

5+

6+performRequest function in servant-client-ghcjs was not compatible with the

7+latest RunClient typeclass. Added the acceptStatus parameter and fixed the

8+functionality to match what servant-client provides.

9+

10+}

changelog.d/1556new file+81

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

1+synopsis: Display capture hints in router layout

2+prs: #1556

3+

4+description: {

5+

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

7+

8+Example:

9+

10+For the following API

11+```haskell

12+type API =

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

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

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

16+```

17+

18+we previously got the following output:

19+

20+```

21+/

22+├─ a/

23+│ ├─ d/

24+│ │ └─•

25+│ └─ e/

26+│ └─•

27+└─ b/

28+ └─ <capture>/

29+ ├─•

30+ ┆

31+ └─•

32+```

33+

34+now we get:

35+

36+```

37+/

38+├─ a/

39+│ ├─ d/

40+│ │ └─•

41+│ └─ e/

42+│ └─•

43+└─ b/

44+ └─ <x::Int>/

45+ ├─•

46+ ┆

47+ └─•

48+```

49+

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

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

52+

53+N.B.:

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

55+

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

57+

58+Warning:

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

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

61+

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

63+```haskell

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

65+

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

67+myServer = const $ return ()

68+

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

70+myApi = Proxy

71+

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

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

74+```

75+

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

77+```haskell

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

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

80+```

81+}

changelog.d/1569new file+13

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

1+synopsis: Encode captures using toEncodedUrlPiece

2+prs: #1569

3+issues: #1511

4+

5+description: {

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

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

8+URL-encoding however they need.

9+

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

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

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

13+}

changelog.d/1571new file+10

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

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

2+prs: #1571

3+issues: #1570

4+description: {

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

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

7+servant-auth-client.

8+

9+This PR also brings Headers support in UVerb responses

10+}

changelog.d/1573new file+2

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

1+synopsis: Add API docs for ServerT

2+prs: #1573

changelog.d/1580new file+12

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

1+synopsis: Allow IO in validationKeys

2+prs: #1580

3+issues: #1579

4+

5+description: {

6+

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

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

9+discover new and expired keys.

10+

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

12+}

changelog.d/1589new file+2

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

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

2+prs: 1589

changelog.d/1595new file+2

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

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

2+prs: #1595

changelog.d/1606new file+10

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

1+synopsis: Handle Cookies correctly for RunStreamingClient

2+prs: #1606

3+issues: #1605

4+

5+description: {

6+

7+Makes performWithStreamingRequest take into consideration the

8+CookieJar, which it previously didn't.

9+

10+}

changelog.d/1638new file+2

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

1+synopsis: Add Functor instance to AuthHandler.

2+prs: #1638

changelog.d/1649new file+8

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

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

2+prs: #1649

3+

4+description: {

5+

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

7+

8+}

doc/Makefile+1−1

@@ -10,7 +10,7 @@ BUILDDIR = _build

10

11# Put it first so that "make" without argument is like "make help".

12help:

13− @if [ ! -d venv ]; then echo "WARNING: There is no venv directory, did you forget to 'virtualenv venv'. Check building-the-docs file."; fi

13+ @if [ ! -d venv ]; then echo "WARNING: There is no venv directory, did you forget to 'virtualenv venv'. Check README.md."; fi

14 @if [ ! "z$$(which $(SPHINXBUILD))" = "z$$(pwd)/venv/bin/sphinx-build" ]; then echo "WARNING: Did you forgot to 'source venv/bin/activate'"; fi

15 @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)

16

doc/conf.py+1−2

@@ -46,7 +46,7 @@ master_doc = 'index'

46

47# General information about the project.

48project = u'Servant'

49−copyright = u'2018, Servant Contributors'

49+copyright = u'2022, Servant Contributors'

50author = u'Servant Contributors'

51

52# The version info for the project you're documenting, acts as replacement for

@@ -169,4 +169,3 @@ texinfo_documents = [

169source_parsers = {

170 '.lhs': CommonMarkParser,

171}

172−

doc/cookbook/curl-mock/curl-mock.cabal+3

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

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

12

13executable cookbock-curl-mock

14+ if impl(ghc >= 9.2)

15+ -- generic-arbitrary is incompatible

16+ buildable: False

14 main-is: CurlMock.lhs

17 main-is: CurlMock.lhs

15 build-depends: base == 4.*

18 build-depends: base == 4.*

16 , aeson

19 , aeson

doc/cookbook/index.rst+3−2

@@ -6,8 +6,8 @@ how to solve many common problems with servant. If you're

6interested in contributing examples of your own, feel free

7to open an issue or a pull request on

8`our github repository <https://github.com/haskell-servant/servant>`_

9−or even to just get in touch with us on the **#servant** IRC channel

9+or even to just get in touch with us on the `**#haskell-servant** IRC channel

10−on freenode or on

10+on libera.chat <https://web.libera.chat/#haskell-servant>_ or on

11`the mailing list <https://groups.google.com/forum/#!forum/haskell-servant>`_.

12

13The scope is very wide. Simple and fancy authentication schemes,

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

37 sentry/Sentry.lhs

38 testing/Testing.lhs

39 open-id-connect/OpenIdConnect.lhs

40+ managed-resource/ManagedResource.lhs

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

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

1+# Request-lifetime Managed Resources

2+

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

4+

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

6+

7+

8+``` haskell

9+{-# LANGUAGE DataKinds #-}

10+{-# LANGUAGE TypeOperators #-}

11+import Control.Concurrent

12+import Control.Exception (bracket, throwIO)

13+import Control.Monad.IO.Class

14+import Control.Monad.Trans.Resource

15+import Data.Acquire

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

17+import Network.Wai.Handler.Warp

18+import Servant

19+import Servant.Client

20+import System.IO

21+```

22+

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

24+

25+``` haskell

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

27+

28+api :: Proxy API

29+api = Proxy

30+```

31+

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

33+

34+``` haskell

35+appContext :: Context '[Acquire Handle]

36+appContext = acquireHandle :. EmptyContext

37+

38+acquireHandle :: Acquire Handle

39+acquireHandle = mkAcquire newHandle closeHandle

40+

41+newHandle :: IO Handle

42+newHandle = do

43+ putStrLn "opening file"

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

45+ putStrLn "opened file"

46+ return h

47+

48+closeHandle :: Handle -> IO ()

49+closeHandle h = do

50+ putStrLn "closing file"

51+ hClose h

52+ putStrLn "closed file"

53+```

54+

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

56+

57+``` haskell

58+server :: Server API

59+server = writeToFile

60+

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

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

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

64+ legalMsg -> liftIO $ do

65+ putStrLn "writing file"

66+ hPutStrLn h legalMsg

67+ putStrLn "wrote file"

68+ return NoContent

69+```

70+

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

72+

73+``` haskell

74+runApp :: IO ()

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

76+

77+postMsg :: String -> ClientM NoContent

78+postMsg = client api

79+

80+main :: IO ()

81+main = do

82+ mgr <- newManager defaultManagerSettings

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

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

85+ liftIO $ putStrLn "sending hello message"

86+ _ <- postMsg "hello"

87+ liftIO $ putStrLn "sending illegal message"

88+ _ <- postMsg "illegal"

89+ liftIO $ putStrLn "done"

90+ print ms

91+```

92+

93+This program prints

94+

95+```

96+sending hello message

97+opening file

98+opened file

99+writing file

100+wrote file

101+closing file

102+closed file

103+sending illegal message

104+opening file

105+opened file

106+closing file

107+closed file

108+wait, that's illegal!

109+CallStack (from HasCallStack):

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

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

112+```

113+

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

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

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

1+cabal-version: 2.2

2+name: cookbook-managed-resource

3+version: 0.1

4+synopsis: Simple managed resource cookbook example

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

6+license: BSD-3-Clause

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

8+author: Servant Contributors

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

10+build-type: Simple

11+tested-with: GHC==9.4.2

12+

13+executable cookbook-managed-resource

14+ main-is: ManagedResource.lhs

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

16+ , text >= 1.2

17+ , aeson >= 1.2

18+ , servant

19+ , servant-client

20+ , servant-server

21+ , warp >= 3.2

22+ , wai >= 3.2

23+ , http-types >= 0.12

24+ , markdown-unlit >= 0.4

25+ , http-client >= 0.5

26+ , transformers

27+ , resourcet

28+ default-language: Haskell2010

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

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

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

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

330```

331

332Here is the code that displays the homepage.

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

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

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

335with some generated information.

336

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

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

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

120

121```haskell

122− let req' = I.defaultMakeClientRequest burl req

122+ req' <- I.defaultMakeClientRequest burl req

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

124```

125

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

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

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

200

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

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

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

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

204The README claims that

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

doc/links.rst+1−1

@@ -12,7 +12,7 @@ Helpful Links

12 `https://github.com/haskell-servant/servant/issues <https://github.com/haskell-servant/servant/issues>`_

13

14- the irc channel:

15− ``#servant`` on freenode

15+ `#haskell-servant on libera.chat <https://web.libera.chat/#haskell-servant>`_

16

17- the mailing list:

18 `groups.google.com/forum/#!forum/haskell-servant <https://groups.google.com/forum/#!forum/haskell-servant>`_

doc/requirements.txt+1

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

1recommonmark==0.5.0

2Sphinx==1.8.4

3sphinx_rtd_theme>=0.4.2

4+jinja2<3.1.0

doc/tutorial/install.rst+26

@@ -40,3 +40,29 @@ nix

40`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at

41the `nix/shell.nix` file in the repository and use it to provision a suitable

42environment to build and run the examples.

43+

44+Note for Ubuntu users

45+--------

46+

47+Ubuntu's packages for `ghc`, `cabal`, and `stack` are years out of date.

48+If the instructions above fail for you,

49+try replacing the Ubuntu packages with up-to-date versions.

50+First remove the installed versions:

51+

52+.. code-block:: bash

53+

54+ # remove the obsolete versions

55+ $ sudo apt remove ghc haskell-stack cabal-install

56+

57+Then install fresh versions of the Haskell toolchain

58+using the `ghcup <https://www.haskell.org/ghcup/install/>`_ installer.

59+

60+As of February 2022, one easy way to do this is by running a bootstrap script:

61+

62+.. code-block:: bash

63+

64+ $ curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh

65+

66+The script is interactive and will prompt you for details about what

67+you want installed and where. To install manually,

68+see `the detailed instructions <https://www.haskell.org/ghcup/install/#manual-install>`_.

doc/tutorial/tutorial.cabal+1−1

@@ -64,7 +64,7 @@ library

64 , blaze-markup >= 0.8.0.0 && < 0.9

65 , cookie >= 0.4.3 && < 0.5

66 , js-jquery >= 3.3.1 && < 3.4

67− , lucid >= 2.9.11 && < 2.10

67+ , lucid >= 2.9.11 && < 2.12

68 , random >= 1.1 && < 1.3

69 , servant-js >= 0.9 && < 0.10

70 , time >= 1.6.0.1 && < 1.13

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

@@ -7,9 +7,9 @@ description: This package provides instances that allow generating clients fr

7 APIs that use

8 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

9 .

10− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.

10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11category: Web, Servant, Authentication

12−homepage: http://github.com/haskell-servant/servant/servant-auth#readme

12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13bug-reports: https://github.com/haskell-servant/servant/issues

14author: Julian K. Arni

15maintainer: jkarni@gmail.com

@@ -31,12 +31,12 @@ library

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

32 ghc-options: -Wall

33 build-depends:

34− base >= 4.10 && < 4.16

34+ base >= 4.10 && < 4.18

35− , bytestring >= 0.10.6.0 && < 0.11

35+ , bytestring >= 0.10.6.0 && < 0.12

36 , containers >= 0.5.6.2 && < 0.7

37 , servant-auth == 0.4.*

38− , servant >= 0.13 && < 0.19

38+ , servant >= 0.13 && < 0.20

39− , servant-client-core >= 0.13 && < 0.19

39+ , servant-client-core >= 0.13 && < 0.20

40

41 exposed-modules:

42 Servant.Auth.Client

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

50 test

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

52 ghc-options: -Wall

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

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

54

55 -- dependencies with bounds inherited from the library stanza

56 build-depends:

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

62

63 -- test dependencies

64 build-depends:

65− hspec >= 2.5.5 && < 2.9

65+ hspec >= 2.5.5 && < 2.10

66 , QuickCheck >= 2.11.3 && < 2.15

67 , aeson >= 1.3.1.1 && < 3

68− , bytestring >= 0.10.6.0 && < 0.11

68+ , bytestring >= 0.10.6.0 && < 0.12

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

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

71 , servant-auth-server >= 0.4.2.0 && < 0.5

72− , servant-server >= 0.13 && < 0.19

72+ , servant-server >= 0.13 && < 0.20

73 , time >= 1.5.0.1 && < 1.13

74 , transformers >= 0.4.2.0 && < 0.6

75 , wai >= 3.2.1.2 && < 3.3

76 , warp >= 3.2.25 && < 3.4

77− , jose >= 0.7.0.0 && < 0.10

77+ , jose >= 0.10 && < 0.11

78 other-modules:

79 Servant.Auth.ClientSpec

80 default-language: Haskell2010

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

@@ -7,9 +7,9 @@ description: This package provides instances that allow generating docs from

7 APIs that use

8 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

9 .

10− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.

10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11category: Web, Servant, Authentication

12−homepage: http://github.com/haskell-servant/servant/servant-auth#readme

12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13bug-reports: https://github.com/haskell-servant/servant/issues

14author: Julian K. Arni

15maintainer: jkarni@gmail.com

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

38+ base >= 4.10 && < 4.18

39− , servant-docs >= 0.11.2 && < 0.12

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

40− , servant >= 0.13 && < 0.19

40+ , servant >= 0.13 && < 0.20

41 , servant-auth == 0.4.*

42− , lens >= 4.16.1 && <5.1

42+ , lens >= 4.16.1 && <5.3

43 exposed-modules:

44 Servant.Auth.Docs

45 default-language: Haskell2010

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

50 build-depends:

51 base,

52 servant-auth-docs,

53− doctest >= 0.16 && < 0.19,

53+ doctest >= 0.16 && < 0.21,

54 QuickCheck >= 2.11.3 && < 2.15,

55 template-haskell

56 ghc-options: -Wall -threaded

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

64 test

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

66 ghc-options: -Wall

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

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

68

69 -- dependencies with bounds inherited from the library stanza

70 build-depends:

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

78 -- test dependencies

79 build-depends:

80 servant-auth-docs

81− , hspec >= 2.5.5 && < 2.9

81+ , hspec >= 2.5.5 && < 2.10

82 , QuickCheck >= 2.11.3 && < 2.15

83

84 default-language: Haskell2010

servant-auth/servant-auth-server/servant-auth-server.cabal+17−16

@@ -1,15 +1,15 @@

1cabal-version: 2.2

2name: servant-auth-server

3−version: 0.4.6.0

3+version: 0.4.7.0

4synopsis: servant-server/servant-auth compatibility

5description: This package provides the required instances for using the @Auth@ combinator

6 in your 'servant' server.

7 .

8 Both cookie- and token- (REST API) based authentication is provided.

9 .

10− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.

10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11category: Web, Servant, Authentication

12−homepage: http://github.com/haskell-servant/servant/servant-auth#readme

12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13bug-reports: https://github.com/haskell-servant/servant/issues

14author: Julian K. Arni

15maintainer: jkarni@gmail.com

@@ -31,27 +31,27 @@ library

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

32 ghc-options: -Wall

33 build-depends:

34− base >= 4.10 && < 4.16

34+ base >= 4.10 && < 4.18

35 , aeson >= 1.0.0.1 && < 3

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

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

38− , bytestring >= 0.10.6.0 && < 0.11

38+ , bytestring >= 0.10.6.0 && < 0.12

39 , case-insensitive >= 1.2.0.11 && < 1.3

40 , cookie >= 0.4.4 && < 0.5

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

42 , entropy >= 0.4.1.3 && < 0.5

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

44− , jose >= 0.7.0.0 && < 0.10

44+ , jose >= 0.10 && < 0.11

45− , lens >= 4.16.1 && < 5.1

45+ , lens >= 4.16.1 && < 5.3

46− , memory >= 0.14.16 && < 0.17

46+ , memory >= 0.14.16 && < 0.19

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

48− , mtl >= 2.2.2 && < 2.3

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

49− , servant >= 0.13 && < 0.19

49+ , servant >= 0.13 && < 0.20

50 , servant-auth == 0.4.*

51− , servant-server >= 0.13 && < 0.19

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

52 , tagged >= 0.8.4 && < 0.9

53− , text >= 1.2.3.0 && < 1.3

53+ , text >= 1.2.3.0 && < 2.1

54− , time >= 1.5.0.1 && < 1.10

54+ , time >= 1.5.0.1 && < 1.13

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

56 , wai >= 3.2.1.2 && < 3.3

57

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

102 test

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

104 ghc-options: -Wall

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

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

106

107 -- dependencies with bounds inherited from the library stanza

108 build-depends:

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

123 -- test dependencies

124 build-depends:

125 servant-auth-server

126− , hspec >= 2.5.5 && < 2.8

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

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

130 , warp >= 3.2.25 && < 3.4

131 , wreq >= 0.5.2.1 && < 0.6

132+ , text >= 1.2.3.0 && < 2.1

132 other-modules:

133 other-modules:

133 Servant.Auth.ServerSpec

134 Servant.Auth.ServerSpec

134 default-language: Haskell2010

135 default-language: Haskell2010

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

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

54

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

56 makeCookies authResult = do

57− xsrf <- makeXsrfCookie cookieSettings

58− fmap (Just xsrf `SetCookieCons`) $

59− case authResult of

57+ case authResult of

60− (Authenticated v) -> do

58+ (Authenticated v) -> do

61− ejwt <- makeSessionCookie cookieSettings jwtSettings v

59+ ejwt <- makeSessionCookie cookieSettings jwtSettings v

62− case ejwt of

60+ xsrf <- makeXsrfCookie cookieSettings

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

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

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

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

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

66

63

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

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

68 -> (AuthResult v, SetCookieList n)

65 -> (AuthResult v, SetCookieList n)

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

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

11import qualified Network.HTTP.Types as HTTP

12import Network.Wai (mapResponseHeaders)

13import Servant

14+import Servant.API.UVerb.Union

15+import Servant.API.Generic

16+import Servant.Server.Generic

14import Web.Cookie

17import Web.Cookie

15

18

16-- What are we doing here? Well, the idea is to add headers to the response,

19-- What are we doing here? Well, the idea is to add headers to the response,

@@ -31,11 +34,24 @@ type family AddSetCookieApiVerb a where

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

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

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

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

33

36

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

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

39+ MapAddSetCookieApiVerb '[] = '[]

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

41+#endif

42+

34type family AddSetCookieApi a :: *

43type family AddSetCookieApi a :: *

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

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

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

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

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

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

48+#endif

37type instance AddSetCookieApi (Verb method stat ctyps a)

49type instance AddSetCookieApi (Verb method stat ctyps a)

38 = Verb method stat ctyps (AddSetCookieApiVerb a)

50 = Verb method stat ctyps (AddSetCookieApiVerb a)

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

52+type instance AddSetCookieApi (UVerb method ctyps as)

53+ = UVerb method ctyps (MapAddSetCookieApiVerb as)

54+#endif

39type instance AddSetCookieApi Raw = Raw

55type instance AddSetCookieApi Raw = Raw

40#if MIN_VERSION_servant_server(0,15,0)

56#if MIN_VERSION_servant_server(0,15,0)

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

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

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

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

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

55 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

71 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

56

72

57−instance AddSetCookies 'Z orig orig where

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

58 addSetCookies _ = id

74 addSetCookies _ = id

59

75

60instance {-# OVERLAPPABLE #-}

76instance {-# OVERLAPPABLE #-}

@@ -72,6 +88,15 @@ instance {-# OVERLAPS #-}

72 => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where

88 => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where

73 addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b

89 addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b

74

90

91+instance {-# OVERLAPS #-}

92+ ( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi

93+ , Generic (api (AsServerT m))

94+ , GServantProduct (Rep (api (AsServerT m)))

95+ , ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

96+ )

97+ => AddSetCookies ('S n) (api (AsServerT m)) cookiedApi where

98+ addSetCookies cookies = addSetCookies cookies . toServant

99+

75-- | for @servant <0.11@

100-- | for @servant <0.11@

76instance

101instance

77 AddSetCookies ('S n) Application Application where

102 AddSetCookies ('S n) Application Application where

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

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

33 -- | Algorithm used to sign JWT.

34 , jwtAlg :: Maybe Jose.Alg

35 -- | Keys used to validate JWT.

36− , validationKeys :: Jose.JWKSet

36+ , validationKeys :: IO Jose.JWKSet

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

38 -- intended recipient of the JWT.

39 , audienceMatches :: Jose.StringOrURI -> IsMatch

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

44defaultJWTSettings k = JWTSettings

45 { signingKey = k

46 , jwtAlg = Nothing

47− , validationKeys = Jose.JWKSet [k]

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

48 , audienceMatches = const Matches }

49

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

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

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

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

3

4import Blaze.ByteString.Builder (toByteString)

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

5import Control.Monad.Except

6import Control.Monad.Except

6import Control.Monad.Reader

7import Control.Monad.Reader

7import qualified Crypto.JOSE as Jose

8import qualified Crypto.JOSE as Jose

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

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

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

2

3import Control.Lens

4−import Control.Monad.Except

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

5import Control.Monad.Reader

6import qualified Crypto.JOSE as Jose

7import qualified Crypto.JWT as Jose

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

9− toJSON)

10import Data.ByteArray (constEq)

8import Data.ByteArray (constEq)

11import qualified Data.ByteString as BS

9import qualified Data.ByteString as BS

12import qualified Data.ByteString.Lazy as BSL

10import qualified Data.ByteString.Lazy as BSL

13−import qualified Data.HashMap.Strict as HM

14import Data.Maybe (fromMaybe)

11import Data.Maybe (fromMaybe)

15−import qualified Data.Text as T

16import Data.Time (UTCTime)

12import Data.Time (UTCTime)

17import Network.Wai (requestHeaders)

13import Network.Wai (requestHeaders)

18

14

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

42-- token expires.

38-- token expires.

43makeJWT :: ToJWT a

39makeJWT :: ToJWT a

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

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

45−makeJWT v cfg expiry = runExceptT $ do

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

46 bestAlg <- Jose.bestJWSAlg $ signingKey cfg

42 bestAlg <- Jose.bestJWSAlg $ signingKey cfg

47 let alg = fromMaybe bestAlg $ jwtAlg cfg

43 let alg = fromMaybe bestAlg $ jwtAlg cfg

48 ejwt <- Jose.signClaims (signingKey cfg)

44 ejwt <- Jose.signClaims (signingKey cfg)

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

58

54

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

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

60verifyJWT jwtCfg input = do

56verifyJWT jwtCfg input = do

57+ keys <- validationKeys jwtCfg

61− verifiedJWT <- liftIO $ runExceptT $ do

58+ verifiedJWT <- Jose.runJOSE $ do

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

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

63 Jose.verifyClaims

60 Jose.verifyClaims

64 (jwtSettingsToJwtValidationSettings jwtCfg)

61 (jwtSettingsToJwtValidationSettings jwtCfg)

65− (validationKeys jwtCfg)

62+ keys

66 unverifiedJWT

63 unverifiedJWT

67 return $ case verifiedJWT of

64 return $ case verifiedJWT of

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

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

69 Right v -> case decodeJWT v of

66 Right v -> case decodeJWT v of

70 Left _ -> Nothing

67 Left _ -> Nothing

71− Right v' -> Just v'

68+ Right v' -> Just v'

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs+10−1

@@ -8,7 +8,10 @@ module Servant.Auth.Server.Internal.ThrowAll where

8

9import Control.Monad.Error.Class

10import Data.Tagged (Tagged (..))

11−import Servant ((:<|>) (..), ServerError(..))

11+import Servant ((:<|>) (..), ServerError(..), NamedRoutes(..))

12+import Servant.API.Generic

13+import Servant.Server.Generic

14+import Servant.Server

12import Network.HTTP.Types

15import Network.HTTP.Types

13import Network.Wai

16import Network.Wai

14

17

@@ -26,6 +29,12 @@ class ThrowAll a where

26instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where

29instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where

27 throwAll e = throwAll e :<|> throwAll e

30 throwAll e = throwAll e :<|> throwAll e

28

31

32+instance

33+ ( ThrowAll (ToServant api (AsServerT m)) , GenericServant api (AsServerT m)) =>

34+ ThrowAll (api (AsServerT m)) where

35+

36+ throwAll = fromServant . throwAll

37+

29-- Really this shouldn't be necessary - ((->) a) should be an instance of

38-- Really this shouldn't be necessary - ((->) a) should be an instance of

30-- MonadError, no?

39-- MonadError, no?

31instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where

40instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where

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

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

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

3

4import Control.Applicative

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

5import Control.Monad.Reader

6import Control.Monad.Reader

6import Control.Monad.Time

7import Control.Monad.Time

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

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

servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs+39−5

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

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE TypeApplications #-}

2module Servant.Auth.ServerSpec (spec) where

3module Servant.Auth.ServerSpec (spec) where

3

4

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

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

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

6#endif

7#endif

7

8

8import Control.Lens

9import Control.Lens

9−import Control.Monad.Except (runExceptT)

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

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

12 JWK, JWSHeader,

13 KeyMaterialGenParam (OctGenParam),

14 ToCompact, encodeCompact,

15− genJWK, newJWSHeader)

15+ genJWK, newJWSHeader, runJOSE)

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

17 NumericDate (NumericDate),

18 SignedJWT,

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

25import Data.Aeson.Lens (_JSON)

26import qualified Data.ByteString as BS

27import qualified Data.ByteString.Lazy as BSL

28+import Data.Text (Text, pack)

28import Data.CaseInsensitive (mk)

29import Data.CaseInsensitive (mk)

29import Data.Foldable (find)

30import Data.Foldable (find)

30import Data.Monoid

31import Data.Monoid

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

40import Network.Wai (responseLBS)

41import Network.Wai (responseLBS)

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

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

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

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

44+ checkResponse,

43 cookieExpiryTime, cookies,

45 cookieExpiryTime, cookies,

44 defaults, get, getWith, postWith,

46 defaults, get, getWith, postWith,

45 header, oauth2Bearer,

47 header, oauth2Bearer,

@@ -50,6 +52,7 @@ import Network.Wreq (Options, auth, basicAuth,

50import Network.Wreq.Types (Postable(..))

52import Network.Wreq.Types (Postable(..))

51import Servant hiding (BasicAuth,

53import Servant hiding (BasicAuth,

52 IsSecure (..), header)

54 IsSecure (..), header)

55+import Servant.API.Generic ((:-))

53import Servant.Auth.Server

56import Servant.Auth.Server

54import Servant.Auth.Server.Internal.Cookie (expireTime)

57import Servant.Auth.Server.Internal.Cookie (expireTime)

55import Servant.Auth.Server.SetCookieOrphan ()

58import Servant.Auth.Server.SetCookieOrphan ()

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

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

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

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

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

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

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

185− opts <- addJwtToCookie cookieCfg jwt

188+ opts' <- addJwtToCookie cookieCfg jwt

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

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

190+ resp <- getWith opts (url port)

191+ resp ^. responseStatus `shouldBe` status401

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

193+

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

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

196+ -- which revealed a bug:

197+ --

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

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

200+ resp ^. responseStatus `shouldBe` status401

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

202+

187

203

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

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

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

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

@@ -405,17 +421,23 @@ type API auths

405 = Auth auths User :>

421 = Auth auths User :>

406 ( Get '[JSON] Int

422 ( Get '[JSON] Int

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

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

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

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

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

409#if MIN_VERSION_servant_server(0,15,0)

426#if MIN_VERSION_servant_server(0,15,0)

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

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

411#endif

428#endif

412 :<|> "raw" :> Raw

429 :<|> "raw" :> Raw

413 )

430 )

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

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

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

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

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

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

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

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

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

418

436

437+data DummyRoutes mode = DummyRoutes

438+ { dummyInt :: mode :- "dummy" :> Get '[JSON] Int

439+ } deriving Generic

440+

419jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])

441jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])

420jwtOnlyApi = Proxy

442jwtOnlyApi = Proxy

421

443

@@ -476,6 +498,7 @@ server ccfg =

476 (\authResult -> case authResult of

498 (\authResult -> case authResult of

477 Authenticated usr -> getInt usr

499 Authenticated usr -> getInt usr

478 :<|> postInt usr

500 :<|> postInt usr

501+ :<|> DummyRoutes { dummyInt = getInt usr }

479 :<|> getHeaderInt

502 :<|> getHeaderInt

480#if MIN_VERSION_servant_server(0,15,0)

503#if MIN_VERSION_servant_server(0,15,0)

481 :<|> return (S.source ["bytestring"])

504 :<|> return (S.source ["bytestring"])

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

483 :<|> raw

506 :<|> raw

484 Indefinite -> throwAll err401

507 Indefinite -> throwAll err401

485 _ -> throwAll err403

508 _ -> throwAll err403

509+ ) :<|>

510+ (\authResult -> case authResult of

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

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

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

486 )

514 )

487 :<|> getLogin

515 :<|> getLogin

488 :<|> getLogout

516 :<|> getLogout

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

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

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

534

562

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

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

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

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

537

565

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

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

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

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

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

563 = fmap cookie_name (destroyCookieJar cj)

591 = fmap cookie_name (destroyCookieJar cj)

564 `shouldMatchList` patterns

592 `shouldMatchList` patterns

565

593

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

595+shouldNotHaveCookies cj patterns =

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

597+ where cookieNames :: [BS.ByteString]

598+ cookieNames = cookie_name <$> destroyCookieJar cj

599+

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

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

567shouldMatchCookieNameValues cj patterns

601shouldMatchCookieNameValues cj patterns

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

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

servant-auth/servant-auth-swagger/servant-auth-swagger.cabal+9−13

@@ -7,9 +7,9 @@ description: This package provides instances that allow generating swagger2 s

7 APIs that use

8 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

9 .

10− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.

10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11category: Web, Servant, Authentication

12−homepage: http://github.com/haskell-servant/servant/servant-auth#readme

12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13bug-reports: https://github.com/haskell-servant/servant/issues

14author: Julian K. Arni

15maintainer: jkarni@gmail.com

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

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

32 ghc-options: -Wall

33 build-depends:

34− base >= 4.10 && < 4.16

34+ base >= 4.10 && < 4.18

35− , text >= 1.2.3.0 && < 1.3

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

38+ , servant >= 0.13 && < 0.20

39 , servant-auth == 0.4.*

40− , lens >= 4.16.1 && < 5.1

40+ , lens >= 4.16.1 && < 5.3

41− if impl(ghc >= 9)

42− buildable: False

43 exposed-modules:

41 exposed-modules:

44 Servant.Auth.Swagger

42 Servant.Auth.Swagger

45 default-language: Haskell2010

43 default-language: Haskell2010

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

51 test

49 test

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

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

53 ghc-options: -Wall

51 ghc-options: -Wall

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

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

55 -- dependencies with bounds inherited from the library stanza

53 -- dependencies with bounds inherited from the library stanza

56 build-depends:

54 build-depends:

57 base

55 base

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

61 , servant

59 , servant

62 , servant-auth

60 , servant-auth

63 , lens

61 , lens

64− if impl(ghc >= 9)

62+

65− buildable: False

66−

67 -- test dependencies

63 -- test dependencies

68 build-depends:

64 build-depends:

69 servant-auth-swagger

65 servant-auth-swagger

70− , hspec >= 2.5.5 && < 2.9

66+ , hspec >= 2.5.5 && < 2.10

71 , QuickCheck >= 2.11.3 && < 2.15

67 , QuickCheck >= 2.11.3 && < 2.15

72 other-modules:

68 other-modules:

73 Servant.Auth.SwaggerSpec

69 Servant.Auth.SwaggerSpec

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

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

1cabal-version: 2.2

2name: servant-auth

3−version: 0.4.0.0

3+version: 0.4.1.0

4synopsis: Authentication combinators for servant

5description: This package provides an @Auth@ combinator for 'servant'. This combinator

6 allows using different authentication schemes in a straightforward way,

@@ -9,9 +9,9 @@ description: This package provides an @Auth@ combinator for 'servant'. This c

9 'servant-auth' additionally provides concrete authentication schemes, such

10 as Basic Access Authentication, JSON Web Tokens, and Cookies.

11 .

12− For more details on how to use this, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.

12+ For more details on how to use this, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

13category: Web, Servant, Authentication

14−homepage: http://github.com/haskell-servant/servant/servant-auth#readme

14+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

15bug-reports: https://github.com/haskell-servant/servant/issues

16author: Julian K. Arni

17maintainer: jkarni@gmail.com

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

36+ base >= 4.10 && < 4.18

37 , containers >= 0.6 && < 0.7

38 , aeson >= 1.3.1.1 && < 3

39− , jose >= 0.7.0.0 && < 0.10

39+ , jose >= 0.10 && < 0.11

40− , lens >= 4.16.1 && < 5.1

40+ , lens >= 4.16.1 && < 5.3

41− , servant >= 0.15 && < 0.19

41+ , servant >= 0.15 && < 0.20

42− , text >= 1.2.3.0 && < 1.3

42+ , text >= 1.2.3.0 && < 2.1

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

44 exposed-modules:

45 Servant.Auth

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

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

27

28-- ** Combinators

29

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

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

31--

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

33--

servant-client-core/CHANGELOG.md+31

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

1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)

2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)

3

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

7+----

8+

9+### Significant changes

10+

11+- Drop support for GHC < 8.6.

12+- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).

13+- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),

14+ which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)

15+ related to hash collisions.

16+- Add `NamedRoutes` combinator, making support for records first-class in Servant

17+ ([#1388](https://github.com/haskell-servant/servant/pull/1388)).

18+- Add custom type errors for partially applied combinators

19+ ([#1289](https://github.com/haskell-servant/servant/pull/1289),

20+ [#1486](https://github.com/haskell-servant/servant/pull/1486)).

21+- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix

22+ erroneous behavior, where only 2XX status codes would be considered

23+ successful, irrelevant of the status parameter specified by the verb

24+ combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))

25+- *servant-client* / *servant-client-core*: Fix `Show` instance for

26+ `Servant.Client.Core.Request`.

27+- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data

28+ in Query parameters.

29+ ([#1432](https://github.com/haskell-servant/servant/pull/1432)).

30+

31+### Other changes

32+

33+- Various version bumps.

34+

40.18.3

350.18.3

5------

36------

6

37

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

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

1cabal-version: 2.2

2name: servant-client-core

3−version: 0.18.3

3+version: 0.19

4

5synopsis: Core functionality and class for client function generation for servant APIs

6category: Servant, Web

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

53+ base >= 4.9 && < 4.18

54 , bytestring >= 0.10.8.1 && < 0.12

55 , constraints >= 0.2 && < 0.14

56 , containers >= 0.5.7.1 && < 0.7

57 , deepseq >= 1.4.2.0 && < 1.5

58− , text >= 1.2.3.0 && < 1.3

58+ , text >= 1.2.3.0 && < 2.1

59− , transformers >= 0.5.2.0 && < 0.6

59+ , transformers >= 0.5.2.0 && < 0.7

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

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

61

62 if !impl(ghc >= 8.2)

63 build-depends:

@@ -65,13 +65,13 @@ library

65

66 -- Servant dependencies

67 build-depends:

68− servant >= 0.18.3 && <0.19

68+ servant >= 0.19

69

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

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

72 build-depends:

73 aeson >= 1.4.1.0 && < 3

74− , base-compat >= 0.10.5 && < 0.12

74+ , base-compat >= 0.10.5 && < 0.13

75 , base64-bytestring >= 1.0.0.1 && < 1.3

76 , exceptions >= 0.10.0 && < 0.11

77 , free >= 5.1 && < 5.2

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

104 -- Additional dependencies

105 build-depends:

106 deepseq >= 1.4.2.0 && < 1.5

107− , hspec >= 2.6.0 && < 2.9

107+ , hspec >= 2.6.0 && < 2.10

108 , QuickCheck >= 2.12.6.1 && < 2.15

109

110 build-tool-depends:

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

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

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

@@ -59,6 +59,7 @@ module Servant.Client.Core

59 , appendToPath

60 , setRequestBodyLBS

61 , setRequestBody

62+ , encodeQueryParamValue

62 ) where

63 ) where

63import Servant.Client.Core.Auth

64import Servant.Client.Core.Auth

64import Servant.Client.Core.BaseUrl

65import Servant.Client.Core.BaseUrl

servant-client-core/src/Servant/Client/Core/HasClient.hs+51−21

@@ -33,9 +33,7 @@ import Control.Arrow

33import Control.Monad

34 (unless)

35import qualified Data.ByteString as BS

36−import Data.ByteString.Builder

37− (toLazyByteString)

38−import qualified Data.ByteString.Lazy as BL

36+import qualified Data.ByteString.Lazy as BL

39import Data.Either

37import Data.Either

40 (partitionEithers)

38 (partitionEithers)

41import Data.Constraint (Dict(..))

39import Data.Constraint (Dict(..))

@@ -65,7 +63,7 @@ import Data.Text

65import Data.Proxy

63import Data.Proxy

66 (Proxy (Proxy))

64 (Proxy (Proxy))

67import GHC.TypeLits

65import GHC.TypeLits

68− (KnownNat, KnownSymbol, symbolVal)

66+ (KnownNat, KnownSymbol, TypeError, symbolVal)

69import Network.HTTP.Types

67import Network.HTTP.Types

70 (Status)

68 (Status)

71import qualified Network.HTTP.Types as H

69import qualified Network.HTTP.Types as H

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

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

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

77 IsSecure, MimeRender (mimeRender),

75 IsSecure, MimeRender (mimeRender),

78 MimeUnrender (mimeUnrender), NoContent (NoContent),

76 MimeUnrender (mimeUnrender), NoContent (NoContent),

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

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

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

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

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

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

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

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

83 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)

81 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)

84import Servant.API.Generic

82import Servant.API.Generic

85 (GenericMode(..), ToServant, ToServantApi

83 (GenericMode(..), ToServant, ToServantApi

@@ -91,6 +89,7 @@ import Servant.API.Status

91import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)

89import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)

92import Servant.API.Modifiers

90import Servant.API.Modifiers

93 (FoldRequired, RequiredArgument, foldRequiredArgument)

91 (FoldRequired, RequiredArgument, foldRequiredArgument)

92+import Servant.API.TypeErrors

94import Servant.API.UVerb

93import Servant.API.UVerb

95 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)

94 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)

96

95

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

209 clientWithRoute pm (Proxy :: Proxy api)

208 clientWithRoute pm (Proxy :: Proxy api)

210 (appendToPath p req)

209 (appendToPath p req)

211

210

212− where p = (toUrlPiece val)

211+ where p = toEncodedUrlPiece val

213

212

214 hoistClientMonad pm _ f cl = \a ->

213 hoistClientMonad pm _ f cl = \a ->

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

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

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

244 clientWithRoute pm (Proxy :: Proxy sublayout)

243 clientWithRoute pm (Proxy :: Proxy sublayout)

245 (foldl' (flip appendToPath) req ps)

244 (foldl' (flip appendToPath) req ps)

246

245

247− where ps = map (toUrlPiece) vals

246+ where ps = map toEncodedUrlPiece vals

248

247

249 hoistClientMonad pm _ f cl = \as ->

248 hoistClientMonad pm _ f cl = \as ->

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

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

@@ -570,7 +569,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire

570 (Proxy :: Proxy mods) add (maybe req add) mparam

569 (Proxy :: Proxy mods) add (maybe req add) mparam

571 where

570 where

572 add :: a -> Request

571 add :: a -> Request

573− add param = appendToQueryString pname (Just $ encodeQueryParam param) req

572+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req

574

573

575 pname :: Text

574 pname :: Text

576 pname = pack $ symbolVal (Proxy :: Proxy sym)

575 pname = pack $ symbolVal (Proxy :: Proxy sym)

@@ -578,9 +577,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire

578 hoistClientMonad pm _ f cl = \arg ->

577 hoistClientMonad pm _ f cl = \arg ->

579 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)

578 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)

580

579

581−encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString

582−encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece

583−

584-- | If you use a 'QueryParams' in one of your endpoints in your API,

580-- | If you use a 'QueryParams' in one of your endpoints in your API,

585-- the corresponding querying function will automatically take

581-- the corresponding querying function will automatically take

586-- an additional argument, a list of values of the type specified

582-- an additional argument, a list of values of the type specified

@@ -622,7 +618,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)

622 )

618 )

623

619

624 where pname = pack $ symbolVal (Proxy :: Proxy sym)

620 where pname = pack $ symbolVal (Proxy :: Proxy sym)

625− paramlist' = map (Just . encodeQueryParam) paramlist

621+ paramlist' = map (Just . encodeQueryParamValue) paramlist

626

622

627 hoistClientMonad pm _ f cl = \as ->

623 hoistClientMonad pm _ f cl = \as ->

628 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)

624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)

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

678

674

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

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

680

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+

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

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

682-- the corresponding querying function will automatically take

688-- the corresponding querying function will automatically take

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

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

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

744 clientWithRoute pm (Proxy :: Proxy api)

750 clientWithRoute pm (Proxy :: Proxy api)

745 (appendToPath p req)

751 (appendToPath p req)

746

752

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

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

748

754

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

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

750

756

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

780

786

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

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

782

788

789+instance HasClient m subapi =>

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

791+

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

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

794+

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

796+

783instance ( HasClient m api

797instance ( HasClient m api

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

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

785 type Client m (AuthProtect tag :> api)

799 type Client m (AuthProtect tag :> api)

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

878--

892--

879-- Example:

893-- Example:

880--

894--

881−-- @@

895+-- @

882-- type Api = NamedRoutes RootApi

896-- type Api = NamedRoutes RootApi

883--

897--

884-- data RootApi mode = RootApi

898-- data RootApi mode = RootApi

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

898-- rootClient = client api

912-- rootClient = client api

899--

913--

900-- endpointClient :: ClientM Person

914-- endpointClient :: ClientM Person

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

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

902−-- @@

916+-- @

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

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

904x // f = f x

918x // f = f x

905

919

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

910--

924--

911-- Example:

925-- Example:

912--

926--

913−-- @@

927+-- @

914-- type Api = NamedRoutes RootApi

928-- type Api = NamedRoutes RootApi

915--

929--

916-- data RootApi mode = RootApi

930-- data RootApi mode = RootApi

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

931-- rootClient = client api

945-- rootClient = client api

932--

946--

933-- hello :: String -> ClientM String

947-- hello :: String -> ClientM String

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

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

935--

949--

936-- endpointClient :: ClientM Person

950-- endpointClient :: ClientM Person

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

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

938−-- @@

952+-- @

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

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

940(/:) = flip

954(/:) = flip

941

955

@@ -979,3 +993,19 @@ decodedAs response ct = do

979 Right val -> return val

993 Right val -> return val

980 where

994 where

981 accept = toList $ contentTypes ct

995 accept = toList $ contentTypes ct

996+

997+-------------------------------------------------------------------------------

998+-- Custom type errors

999+-------------------------------------------------------------------------------

1000+

1001+-- Erroring instance for HasClient' when a combinator is not fully applied

1002+instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)

1003+ where

1004+ type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)

1005+ clientWithRoute _ _ _ = error "unreachable"

1006+ hoistClientMonad _ _ _ _ = error "unreachable"

1007+

1008+-- Erroring instances for 'HasClient' for unknown API combinators

1009+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)

1010+

1011+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api

servant-client-core/src/Servant/Client/Core/Request.hs+20−5

@@ -17,6 +17,7 @@ module Servant.Client.Core.Request (

17 addHeader,

18 appendToPath,

19 appendToQueryString,

20+ encodeQueryParamValue,

20 setRequestBody,

21 setRequestBody,

21 setRequestBodyLBS,

22 setRequestBodyLBS,

22 ) where

23 ) where

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

33import Data.Bitraversable

34import Data.Bitraversable

34 (Bitraversable (..), bifoldMapDefault, bimapDefault)

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

35import qualified Data.ByteString as BS

36import qualified Data.ByteString as BS

37+import Data.ByteString.Builder

38+ (Builder)

36import qualified Data.ByteString.Builder as Builder

39import qualified Data.ByteString.Builder as Builder

37import qualified Data.ByteString.Lazy as LBS

40import qualified Data.ByteString.Lazy as LBS

38import qualified Data.Sequence as Seq

41import qualified Data.Sequence as Seq

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

111 rnfB Nothing = ()

114 rnfB Nothing = ()

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

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

113

116

114−type Request = RequestF RequestBody Builder.Builder

117+type Request = RequestF RequestBody Builder

115

118

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

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

117data RequestBody

120data RequestBody

@@ -142,18 +145,30 @@ defaultRequest = Request

142 , requestMethod = methodGet

145 , requestMethod = methodGet

143 }

146 }

144

147

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

149+--

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

145−appendToPath :: Text -> Request -> Request

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

146appendToPath p req

152appendToPath p req

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

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

148

154

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

156+--

149−appendToQueryString :: Text -- ^ param name

157+appendToQueryString :: Text -- ^ query param name

150− -> Maybe BS.ByteString -- ^ param value

158+ -> Maybe BS.ByteString -- ^ query param value

151 -> Request

159 -> Request

152 -> Request

160 -> Request

153appendToQueryString pname pvalue req

161appendToQueryString pname pvalue req

154 = req { requestQueryString = requestQueryString req

162 = req { requestQueryString = requestQueryString req

155 Seq.|> (encodeUtf8 pname, pvalue)}

163 Seq.|> (encodeUtf8 pname, pvalue)}

156

164

165+-- | Encode a query parameter value.

166+--

167+encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString

168+encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString . toEncodedUrlPiece

169+

170+-- | Add header to the request being constructed.

171+--

157addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request

172addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request

158addHeader name val req

173addHeader name val req

159 = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}

174 = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}

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

@@ -38,7 +38,7 @@ library

38 Servant.Client.Internal.XhrClient

39

40 build-depends:

41− base >=4.11 && <4.12

41+ base >=4.11 && <5

42 , bytestring >=0.10 && <0.12

43 , case-insensitive >=1.2.0.0 && <1.3.0.0

44 , containers >=0.5 && <0.7

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

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

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

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

51− , mtl >=2.2.2 && <2.3

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

52 , semigroupoids >=5.3 && <5.4

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

54 , transformers >=0.3 && <0.6

@@ -56,8 +56,8 @@ library

56

57 -- strict, as we re-export stuff

58 build-depends:

59− servant >=0.16 && <0.17

59+ servant >=0.16 && <0.20

60− , servant-client-core >=0.16 && <0.16.1

60+ , servant-client-core >=0.16 && <0.20

61

62 hs-source-dirs: src

63 default-language: Haskell2010

servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+8−5

@@ -120,7 +120,7 @@ instance Exception StreamingNotSupportedException where

120 displayException _ = "streamingRequest: streaming is not supported!"

121

122instance RunClient ClientM where

123− runRequest = performRequest

123+ runRequestAcceptStatus = performRequest

124 throwClientError = throwError

125

126runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)

@@ -152,15 +152,18 @@ runClientM m = do

152

153 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))

154

155−performRequest :: Request -> ClientM Response

155+performRequest :: Maybe [Status] -> Request -> ClientM Response

156−performRequest req = do

156+performRequest acceptStatus req = do

157 xhr <- liftIO initXhr

158 burl <- asks baseUrl

159 liftIO $ performXhr xhr burl req

160 resp <- toResponse xhr

161

162− let status = statusCode (responseStatusCode resp)

162+ let status = responseStatusCode resp

163− unless (status >= 200 && status < 300) $ do

163+ goodStatus = case acceptStatus of

164+ Nothing -> statusIsSuccessful status

165+ Just good -> status `elem` good

166+ unless goodStatus $ do

164 let f b = (burl, BL.toStrict $ toLazyByteString b)

167 let f b = (burl, BL.toStrict $ toLazyByteString b)

165 throwError $ FailureResponse (bimap (const ()) f req) resp

168 throwError $ FailureResponse (bimap (const ()) f req) resp

166

169

servant-client/CHANGELOG.md+31

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

1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md)