09de487..master · servant-reflex

git.iko.soy/servant-reflex

on master help sign in

32 files changed+555−642

since splitsnapshots

unifiedsplit

.gitignore+2

@@ -7,3 +7,5 @@ log

77*.stats

88out

99/.stack-work/

10+TAGS

11+dist-newstyle

.gitmodules−12

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

1−[submodule "deps/http-api-data"]

2− path = deps/http-api-data

3− url = https://github.com/fizruk/http-api-data

4−[submodule "deps/servant"]

5− path = deps/servant

6− url = https://github.com/haskell-servant/servant

7−[submodule "deps/servant-snap"]

8− path = deps/servant-snap

9− url = https://github.com/haskell-servant/servant-snap

10−[submodule "deps/reflex-platform"]

11− path = deps/reflex-platform

12− url = https://github.com/reflex-frp/reflex-platform

.travis.yml+12−56

@@ -1,61 +1,17 @@

1−sudo: required

2−

3−before_cache:

4− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

5− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar

6−

7−addons:

8− apt:

9− - phantomjs

10−

11−matrix:

12− include:

13− - env: CABALVER=1.24 GHCVER=7.10.3

14− compiler: ": #GHC 7.10.3"

15− addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3], sources: [hvr-ghc]}}

16− - env: CABALVER=1.24 GHCVER=8.0.1

17− compiler: ": #GHC 8.0.1"

18− addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}

19−

20−

1+language: nix

2+nix: 2.3.6

3+sudo: require

214

225before_install:

23− - unset CC

24− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH

25− - git submodule update --init --recursive

6+ - sudo cp -rT $TRAVIS_BUILD_DIR/nix /etc/nix

267

27−install:

28− - cabal --version

29− - BENCH=${BENCH---enable-benchmarks}

30− - TEST=${TEST---enable-tests}

31− - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"

32− - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];

33− then

34− zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >

35− $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;

36− fi

37− - travis_retry cabal update -v

38− - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config

39− - deps/reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal configure -fExample && cabal build"

40− - deps/reflex-platform/work-on ghc ./testdriver --command "cd testdriver && cabal configure && cabal build"

41− - cd testserver && dist/build/back/back -p 8000 &

42− - sleep 3

43− - phantomjs --webdriver=127.0.0.1:4444 &

44− - sleep 3

8+before_script:

9+ - sudo systemctl restart nix-daemon.service

10+ - git config --global user.email "travis-ci@example.com"

11+ - git config --global user.name "Travis-CI"

4512

4613script:

47− - git config --global user.email "travis-ci@example.com"

48− - git config --global user.name "Travis-CI"

49− - ./build.sh

50− # - testdriver/dist/build/spec/spec

51−

52−cache:

53− directories:

54− - /nix

55− - $HOME/.cabal/packages

56− - $HOME/.cabal/store

57−

58−env:

59− global:

60− - ENCRYPTION_LABEL: "3c89d919c82e"

61− - COMMIT_AUTHOR_EMAIL: "imalsogreg@gmail.com"

14+ - nix-build travis.nix -A build

15+ - nix-build travis.nix -A buildGhc

16+ - nix-build travis.nix -A testserver

17+ - nix-build travis.nix -A testresults

changelog.md → ChangeLog.mdrenamed+14−1

@@ -1,7 +1,20 @@

1+0.3.5

2+-----

4+ - Require reflex-dom-core >= 0.6 (for internal handling of case-insensitive headers)

5+ - Require servant >= 0.16

6+ - Eliminate use of deprecated widgets from reflex-dom-core

7+ - Bump the version of reflex-platform used in nix-shell and test suite

9+0.3.4

10+-----

11+

12+Add selenium-based test suite

13+

1140.3.3

215-----

316

4−Explicitly escape reserved characters from path pieces and query parameters

17+- Fix encoding issue: Explicitly escape reserved characters from path pieces and query parameters

518

619

7200.3.2

README.md+70−33

@@ -4,14 +4,19 @@

55## `servant-reflex` lets you share your `servant` APIs with the frontend

7−Keeping your frontend in sync with your API server can be difficult - when the API changes its input parameters or return type, XHR requests from the frontend will fail at runtime. If your API is defined by [servant](haskell-servant.readthedocs.io) combinators, you can use `servant-reflex` to share the API between the server and frontend.

8−Syncronization between is checked at compile time, and rather than building XHR requests by hand, API endpoints are available behind `reflex`'s FRP semantics.

9−

7+Keeping your frontend in sync with your API server can be difficult - when the

8+API changes its input parameters or return type, XHR requests from the

9+frontend will fail at runtime. If your API is defined by

10+[servant](https://haskell-servant.readthedocs.io) combinators, you can use

11+`servant-reflex` to share the API between the server and frontend.

12+Syncronization between is checked at compile time, and rather than building XHR

13+requests by hand, API endpoints are available behind `reflex`'s FRP semantics.

1014

1115

1216## Example

1317

14−We have a webservice API defined in a module where both the server (compiled with ghc) and the frontend (compiled with ghcjs) can see it:

18+We have a webservice API defined in a module where both the server (compiled

19+with ghc) and the frontend (compiled with ghcjs) can see it:

1520

1621```haskell

1722type API = "getint" :> Get '[JSON] Int

@@ -24,7 +29,8 @@ type API = "getint" :> Get '[JSON] Int

2429 :<|> Raw

2530```

2631

27−`servant-reflex` then computes client functions that can query the API through an `XhrRequest`.

32+`servant-reflex` then computes client functions that can query the API through

33+an `XhrRequest`.

2834

2935```haskell

3036

@@ -37,7 +43,16 @@ type API = "getint" :> Get '[JSON] Int

3743 (constDyn (BasePath "/"))

3844```

3945

40−These client functions are computed from your API type. They manage serialization, `XhrRequest` generation, and deserialization for you. `a` parameters used in URL captures become `Dynamic t (Either Text a)` parameters in the client functions. `QueryFlag`, `QueryParams` and `QueryParam` API parameters map to `Dynamic t Bool`, `Dynamic t [a]` and `Dynamic t (QParam a)` respectively. These parameters to the client function are wrapped with failure possibility to allow you to indicate at any time whether input validation for that parameter has failed and no valid XHR request can be generated. The final parameter is a trigger event for the XHR request. The return value `Event t (ReqResult a)` contains responses from the API server.

46+These client functions are computed from your API type. They manage

47+serialization, `XhrRequest` generation, and deserialization for you. `a`

48+parameters used in URL captures become `Dynamic t (Either Text a)` parameters

49+in the client functions. `QueryFlag`, `QueryParams` and `QueryParam` API

50+parameters map to `Dynamic t Bool`, `Dynamic t [a]` and `Dynamic t (QParam a)`

51+respectively. These parameters to the client function are wrapped with failure

52+possibility to allow you to indicate at any time whether input validation for

53+that parameter has failed and no valid XHR request can be generated. The final

54+parameter is a trigger event for the XHR request. The return value

55+`Event t (ReqResult a)` contains responses from the API server.

4156

4257```haskell

4358 -- No need to write these functions. servant-reflex creates them for you!

@@ -62,7 +77,13 @@ These client functions are computed from your API type. They manage serializatio

6277 -> m (Event t (ReqResult () Double))

6378```

6479

65−`ReqResult tag a` is defined in [`Servant.Common.Req`](https://github.com/imalsogreg/servant-reflex/blob/6d866e338edb9bf6fd8f8d5083ff0187b4d8c0d2/src/Servant/Common/Req.hs#L40-L42) and reports whether or not your request was sent (if validation fails, the request won't be sent), and how decoding of the response went. You can pattern match on these explicitly, but usually you'll want to use `fmapMaybe :: (a -> Maybe b) -> Event t a -> Event t b` and one of the elimination functions to filter the result type you care about, like this:

80+`ReqResult tag a` is defined in

81+[`Servant.Common.Req`](https://github.com/imalsogreg/servant-reflex/blob/6d866e338edb9bf6fd8f8d5083ff0187b4d8c0d2/src/Servant/Common/Req.hs#L40-L42)

82+and reports whether or not your request was sent (if validation fails, the

83+request won't be sent), and how decoding of the response went. You can pattern

84+match on these explicitly, but usually you'll want to use

85+`fmapMaybe :: (a -> Maybe b) -> Event t a -> Event t b` and one of the

86+elimination functions to filter the result type you care about, like this:

6687

6788```haskell

6889 -- ... continued ...

@@ -80,7 +101,8 @@ These client functions are computed from your API type. They manage serializatio

80101 dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])

81102```

82103

83−This example builds some input fields to enter API parameters, buttons to trigger the API calls, and text elements to show the results:

104+This example builds some input fields to enter API parameters, buttons to

105+trigger the API calls, and text elements to show the results:

84106

85107```haskell

86108 elClass "div" "int-demo" $ do

@@ -103,47 +125,53 @@ This example builds some input fields to enter API parameters, buttons to trigge

103125 display =<< holdDyn Nothing outputDouble

104126```

105127

106−For a great introduction to recative DOM building, see the [README](https://github.com/reflex-frp/reflex-platform) for the `reflex-platform`. For more information about servant, see their [documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to the respective authors of these fabulous libraries.

128+For a great introduction to recative DOM building, see the

129+[README](https://github.com/reflex-frp/reflex-platform) for the

130+`reflex-platform`. For more information about servant, see their

131+[documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to

132+the respective authors of these fabulous libraries.

107133

108134

109135## Building the library and test server

110136

111−This repository comes with a small example of an API shared between a ghcjs-compiled frontend ([exec/](https://github.com/imalsogreg/servant-reflex/tree/master/exec)) and a ghc-compiled backend ([testserver/](https://github.com/imalsogreg/servant-reflex/tree/master/testserver). To build these components:

112−

113−

114−First build the library:

137+This repository comes with a small example of an API shared between a

138+ghcjs-compiled frontend

139+([exec/](https://github.com/imalsogreg/servant-reflex/tree/master/exec)) and a

140+ghc-compiled backend

141+([testserver/](https://github.com/imalsogreg/servant-reflex/tree/master/testserver).

142+To build these components, we will use the nix packages for the testserver. It

143+manages the frontend build as a dependency.

115144

116145```

117−git submodule update --init --recursive

118−./build.sh

146+nix build -f travis.nix testserver -o server

119147```

120148

121−Then build the test server:

122−

123−```

124−deps/reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal build"

125−```

126−

127−

128−## Running the example site

129−

130−The server must be run from the directory where static assets live:

149+Point it at the static directory and run it:

131150

132151```

133−cd testserver

134−dist/build/back/back -p 8001

152+STATIC_DIR=server/static server/back -p 8000

135153```

136154

137−And simply browse to `localhost:8001`

155+Browse to [http://localhost:8000](http://localhost:8000) and click around.

156+Open the firefox or chrome developer tools and examine the XHR activity

157+under the Network tab.

138158

139−**For a larger example of a project that shares types between backend and frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**

159+**For a larger example of a project that shares types between backend and

160+frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**

140161

141162

142163## Tagging requests

143164

144−The input and the return type of a client function like `getDouble` are both event streams. The individual input events and responses occur at different times and aren't automatically paired up, but you can recover the relationship by tagging the requests.

165+The input and the return type of a client function like `getDouble` are both

166+event streams. The individual input events and responses occur at different

167+times and aren't automatically paired up, but you can recover the

168+relationship by tagging the requests.

145169

146−So far we have used an `Event t ()` to trigger sending a request. If we choose e.g. `Double` for the third `Proxy` argument to `client`, then `Event t Double` will be used to trigger requests, and each `ReqResult` will carry the tag of its request. Imagine we wanted to display not just the last "double" from `doubleIt`, but a whole table of valid inputs and their doubled responses:

170+So far we have used an `Event t ()` to trigger sending a request. If we choose

171+e.g. `Double` for the third `Proxy` argument to `client`, then `Event t Double`

172+will be used to trigger requests, and each `ReqResult` will carry the tag of

173+its request. Imagine we wanted to display not just the last "double" from

174+`doubleIt`, but a whole table of valid inputs and their doubled responses:

147175

148176```haskell

149177 ...

@@ -173,7 +201,10 @@ So far we have used an `Event t ()` to trigger sending a request. If we choose e

173201

174202## Simultaneous requests

175203

176−`Servant.Reflex.Multi` provides an alternative client-generation function called `clientA` (client applicative). Choose a container type that has both `Applicative` and `Traversable` instances, and pass it to `clientA` through another `Proxy`. Our `sayHi` client function will then have this type:

204+`Servant.Reflex.Multi` provides an alternative client-generation function

205+called `clientA` (client applicative). Choose a container type that has both

206+`Applicative` and `Traversable` instances, and pass it to `clientA` through

207+another `Proxy`. Our `sayHi` client function will then have this type:

177208

178209```haskell

179210sayHi

@@ -184,4 +215,10 @@ sayHi

184215 -> m (Event t (f (ReqResult tag Text)))

185216```

186217

187−The dynamic params are each wrapped in `f`. For every firing of the trigger event `tag`, all of these parameters will be combined according to `f`'s `Applicative` instance (when `f` is `[]`, you will get all combinations of all parameters taken together as a request; when `f` is `ZipList`, the Nth elemens of each parameters list will be taken together as a request). Using this interface, you can trigger many XHR's from a single event occurence, and expect the responses to be structured the same way as the requests.

218+The dynamic params are each wrapped in `f`. For every firing of the trigger

219+event `tag`, all of these parameters will be combined according to `f`'s

220+`Applicative` instance (when `f` is `[]`, you will get all combinations of

221+all parameters taken together as a request; when `f` is `ZipList`, the Nth

222+elemens of each parameters list will be taken together as a request). Using

223+this interface, you can trigger many XHR's from a single event occurence, and

224+expect the responses to be structured the same way as the requests.

build.shdeleted−3

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

1−#!/usr/bin/env bash

2−

3−deps/reflex-platform/work-on ./overrides.nix ./. --run "cabal configure --ghcjs -f Example && cabal build && exec/toSite.sh"

default.nixnew file+21

@@ -0,0 +1,21 @@

1+{ mkDerivation, base, bytestring, case-insensitive, containers

2+, data-default, exceptions, ghcjs-dom, http-api-data, http-media

3+, jsaddle, mtl, network-uri, reflex, reflex-dom, reflex-dom-core

4+, safe, servant, servant-auth, stdenv, string-conversions, text

5+, transformers

6+}:

7+mkDerivation {

8+ pname = "servant-reflex";

9+ version = "0.3.6";

10+ src = ./.;

11+ isLibrary = true;

12+ isExecutable = true;

13+ libraryHaskellDepends = [

14+ base bytestring case-insensitive containers data-default exceptions

15+ ghcjs-dom http-api-data http-media jsaddle mtl network-uri reflex

16+ reflex-dom reflex-dom-core safe servant servant-auth string-conversions

17+ text transformers

18+ ];

19+ description = "servant API generator for reflex apps";

20+ license = stdenv.lib.licenses.bsd3;

21+}

deps/http-api-datadeleted−1

Submodule changed.

deps/reflex-platformdeleted−1

Submodule changed.

deps/servantdeleted−1

Submodule changed.

deps/servant-snapdeleted−1

Submodule changed.

exec/Example.hs+2−2

@@ -21,7 +21,8 @@ import Servant.API

2121import API

2222import Data.Proxy

2323import Text.Read (readMaybe)

24−import Reflex.Dom hiding (run)

24+import Reflex.Dom.Core hiding (run, mainWidget)

25+import Reflex.Dom (mainWidget)

2526------------------------------------------------------------------------------

2627import Servant.Reflex

2728import Servant.Reflex.Multi

@@ -97,7 +98,6 @@ run = mdo

9798

9899 -- Name the computed API client functions

99100 let tweakRequest = ClientOptions $ \r -> do

100− putStrLn ("Got req: " ++ show r)

101101 return $ r & withCredentials .~ True

102102 let (getUnit :<|> getInt :<|> sayhi :<|> dbl

103103 :<|> multi :<|> qna :<|> secret :<|> doRaw) =

nix/nix.confnew file+3

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

1+substituters = https://cache.nixos.org/ https://nixcache.reflex-frp.org/

2+trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=

3+trusted-users = travis

nix/reflex-platform.nixnew file+7

@@ -0,0 +1,7 @@

1+let

2+ rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;

3+in import (builtins.fetchTarball

4+ {

5+ url = "https://github.com/reflex-frp/reflex-platform/archive/${rev}.tar.gz";

6+ sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;

7+ }) {}

nix/servant-snap.nixnew file+7

@@ -0,0 +1,7 @@

1+# Servant-snap is marked broken in nixpkgs

2+{ nixpkgs ? import <nixpkgs> {}}: self: super:

3+self.callCabal2nix "servant-snap" (nixpkgs.fetchgit {

4+ url = "https://github.com/haskell-servant/servant-snap.git";

5+ rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";

6+ sha256 = "sha256-fzzQGwG8Ko72OO/kwLMG52eNZSt3F2dxhNgM9gaO4yQ=";

7+}) {}

nix/testresults.nixnew file+17

@@ -0,0 +1,17 @@

1+{ curl, reflexPlatform, testdriver, testserver, phantomjs }:

3+reflexPlatform.nixpkgs.pkgs.runCommand "runWebdriveTest.sh" {} ''

4+ echo About to phantom

5+ ${phantomjs}/bin/phantomjs --webdriver=127.0.0.1:4444 &

6+ sleep 3

7+ echo About to Server

8+ STATIC_DIR=${testserver}/static ${testserver}/back -q --no-access-log --no-error-log -p 8000 &

9+ sleep 3

10+ ${curl}/bin/curl localhost:8000

11+ ${curl}/bin/curl localhost:8000/runmain.js

12+ echo About to testdrive

13+ ${testdriver}/bin/spec > $out 2>&1

14+ echo Done

15+ trap "exit" INT TERM

16+ trap "kill 0" EXIT

17+ ''

nix/testserver.nixnew file+9

@@ -0,0 +1,9 @@

1+servant-reflex: self: super:

3+(self.callCabal2nix "testserver" ../testserver {}).overrideDerivation (drv: {

4+ postInstall = ''

5+ cp dist/build/back/back $out/back

6+ mkdir $out/static

7+ cp ${servant-reflex}/bin/example.jsexe/* $out/static/

8+ '';

9+})

overrides-ghc.nixdeleted−11

@@ -1,11 +0,0 @@

1−{ reflex-platform, ... }:

2−let

3− c2n = reflex-platform.cabal2nixResult;

4− dc = reflex-platform.lib.dontCheck;

5−in reflex-platform.ghc.override {

6− overrides = self: super: {

7− servant-snap = dc (self.callPackage (c2n deps/servant-snap) {});

8− heist = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});

9− xmlhtml = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});

10− };

11−}

overrides.nixdeleted−9

@@ -1,9 +0,0 @@

1−{ reflex-platform, ... }:

2−let

3− dc = reflex-platform.lib.dontCheck;

4− c2n = reflex-platform.cabal2nixResult;

5−in

6−reflex-platform.ghcjs.override {

7− overrides = self: super: {

8− };

9−}

servant-reflex.cabal+24−19

@@ -1,7 +1,7 @@

11Name: servant-reflex

2−Version: 0.3.3

3−Synopsis: Servant reflex API generator

4−Description: Servant reflex API generator

2+Version: 0.3.6

3+Synopsis: servant API generator for reflex apps

4+Description: Generate reflex-compatible client functions from servant API descriptions

55License: BSD3

66License-file: LICENSE.md

77Author: Greg Hale, Doug Beardsley

@@ -17,39 +17,35 @@ Flag Example

1717

1818library

1919 exposed-modules:

20− Servant.Reflex

21− Servant.Reflex.Multi

22−

23− other-modules:

2420 Servant.Common.BaseUrl

2521 Servant.Common.Req

22+ Servant.Reflex

23+ Servant.Reflex.Multi

2624

2725 hs-source-dirs: src

2826 build-depends:

29− base >= 4.8 && < 4.10,

30− aeson >= 0.11 && < 1.3,

27+ base >= 4.8 && < 5,

3128 bytestring >= 0.10 && < 0.11,

3229 case-insensitive >= 1.2.0.4 && < 1.3,

33− containers >= 0.5.6 && < 0.6,

30+ containers >= 0.5.6 && < 0.7,

3431 data-default >= 0.5 && < 0.8,

35− exceptions >= 0.8 && < 0.9,

32+ exceptions >= 0.8 && < 0.11,

3633 ghcjs-dom >= 0.2 && < 0.10,

37− http-api-data >= 0.3.6 && < 0.4,

38− http-media >= 0.6 && < 0.7,

34+ http-api-data >= 0.3.6 && < 0.5,

35+ http-media >= 0.6 && < 0.9,

3936 jsaddle >= 0.8 && < 0.10,

4037 mtl >= 2.2.1 && < 2.3,

4138 network-uri >= 2.6 && < 2.7,

42− reflex >= 0.5 && < 0.6,

43− reflex-dom-core == 0.4 && < 0.5,

39+ reflex >= 0.5 && < 0.9,

40+ reflex-dom-core >= 0.6 && < 0.7,

4441 safe >= 0.3.9 && < 0.4,

45− servant >= 0.13 && < 0.14,

46− servant-checked-exceptions >= 1.1.0.0 && < 1.2,

42+ servant >= 0.16 && < 0.18,

4743 servant-auth >= 0.2.1 && < 0.4,

4844 string-conversions >= 0.4 && < 0.5,

4945 text >= 1.2 && < 1.3,

5046 transformers >= 0.4 && < 0.6

5147

52− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

48+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields

5349

5450 default-language: Haskell2010

5551

@@ -58,7 +54,16 @@ executable example

5854 buildable: True

5955 else

6056 buildable: False

61− build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text

57+ build-depends:

58+ aeson,

59+ reflex,

60+ servant-reflex,

61+ base,

62+ scientific,

63+ servant,

64+ reflex-dom,

65+ reflex-dom-core,

66+ text

6267 default-language: Haskell2010

6368 main-is: Example.hs

6469 other-modules: API

shell.nixnew file+1

@@ -0,0 +1 @@

1+(import ./travis.nix {nativeCompiler = "ghc";}).ghcPkgs.servant-reflex.env

src/Servant/Common/BaseUrl.hs+4−5

@@ -85,15 +85,14 @@ baseUrlWidget = elClass "div" "base-url" $ do

8585 where pathWidget :: m (Dynamic t BaseUrl)

8686 pathWidget = do

8787 text "Url base path"

88− t <- textInput (def {_textInputConfig_attributes =

89− constDyn ("placeholder" =: "/a/b")})

88+ t <- inputElement def

9089 return $ BasePath <$> value t

9190 fullUrlWidget :: m (Dynamic t BaseUrl)

9291 fullUrlWidget = do

9392 schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def

94− srv <- textInput def {_textInputConfig_attributes = constDyn $ "placeholder" =: "example.com"}

93+ srv <- inputElement def

9594 text ":"

96− prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}

95+ prt <- inputElement def

9796 port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))

98− path <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "a/b" }

97+ path <- inputElement def

9998 return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path

src/Servant/Common/Req.hs+46−69

@@ -8,21 +8,18 @@

88{-# LANGUAGE ScopedTypeVariables #-}

99{-# LANGUAGE TupleSections #-}

1010

11−{-# LANGUAGE MultiParamTypeClasses #-}

12−{-# LANGUAGE FlexibleInstances #-}

1311module Servant.Common.Req where

1412

1513-------------------------------------------------------------------------------

1614import Control.Applicative (liftA2, liftA3)

15+import Control.Arrow ((&&&))

1716import Control.Concurrent

1817import Control.Monad (join)

1918import Control.Monad.IO.Class (MonadIO, liftIO)

20−import Data.Aeson

2119import Data.Bifunctor (first)

22−import qualified Data.ByteString.Builder as BB

23−import qualified Data.ByteString as BS

24−import Data.ByteString.Lazy (ByteString)

20+import qualified Data.ByteString.Builder as Builder

2521import qualified Data.ByteString.Lazy.Char8 as BL

22+import Data.ByteString (ByteString)

2623import qualified Data.Map as Map

2724import Data.Maybe (catMaybes, fromMaybe)

2825import Data.Functor.Compose

@@ -30,24 +27,17 @@ import Data.Monoid ((<>))

3027import Data.Proxy (Proxy(..))

3128import Data.Text (Text)

3229import qualified Data.Text as T

33−import qualified Data.Text.Lazy as TL

34−import qualified Data.Text.Encoding as T

30+import qualified Data.Text.Encoding as TE

3531import Data.Traversable (forM)

3632import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)

37−import qualified Language.Javascript.JSaddle as JS

38−import qualified Data.JSString.Text as JS (lazyTextFromJSString)

3933import qualified Network.URI as N

4034import Reflex.Dom.Core hiding (tag)

4135import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

4236 SupportsServantReflex)

43−import Servant.API.ContentTypes ( NoContent(..), Accept, JSON

44− , OctetStream, PlainText

45− , FormUrlEncoded)

37+import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))

4638import Web.HttpApiData (ToHttpApiData(..))

47−import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)

4839-------------------------------------------------------------------------------

4940import Servant.API.BasicAuth

50−-------------------------------------------------------------------------------

5141

5242

5343------------------------------------------------------------------------------

@@ -103,6 +93,13 @@ reqFailure (ResponseFailure _ s _) = Just s

10393reqFailure (RequestFailure _ s) = Just s

10494reqFailure _ = Nothing

10595

96+------------------------------------------------------------------------------

97+-- | Simple filter/accessor like 'reqFailure', but keeping the request tag

98+reqFailure' :: ReqResult tag a -> Maybe (tag,Text)

99+reqFailure' (ResponseFailure tag s _) = Just (tag,s)

100+reqFailure' (RequestFailure tag s) = Just (tag,s)

101+reqFailure' _ = Nothing

102+

106103

107104------------------------------------------------------------------------------

108105-- | Simple filter/accessor for the raw XHR response

@@ -162,7 +159,7 @@ prependToPathParts p req =

162159 req { reqPathParts = p : reqPathParts req }

163160

164161addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t

165−addHeader name val req = req { headers = (name, (fmap . fmap) (T.decodeUtf8 . toHeader) val) : headers req }

162+addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }

166163

167164

168165reqToReflexRequest

@@ -235,7 +232,7 @@ reqToReflexRequest reqMeth reqHost req =

235232 Map.insert "Content-Type" bCT (Map.fromList hs)

236233 , _xhrRequestConfig_user = Nothing

237234 , _xhrRequestConfig_password = Nothing

238− , _xhrRequestConfig_responseType = Nothing

235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

239236 , _xhrRequestConfig_withCredentials = False

240237 , _xhrRequestConfig_responseHeaders = def

241238 }

@@ -247,8 +244,8 @@ reqToReflexRequest reqMeth reqHost req =

247244 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs

248245 , _xhrRequestConfig_user = Nothing

249246 , _xhrRequestConfig_password = Nothing

250− , _xhrRequestConfig_responseType = Nothing

251− , _xhrRequestConfig_sendData = ""

247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

248+ , _xhrRequestConfig_sendData = mempty

252249 , _xhrRequestConfig_withCredentials = False

253250 }

254251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

@@ -257,8 +254,8 @@ reqToReflexRequest reqMeth reqHost req =

257254 mkAuth _ (Left e) = Left e

258255 mkAuth Nothing r = r

259256 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config

260− { _xhrRequestConfig_user = Just $ T.decodeUtf8 u

261− , _xhrRequestConfig_password = Just $ T.decodeUtf8 p}

257+ { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u

258+ , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}

262259

263260 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))

264261 -> Dynamic t (Either Text (XhrRequestConfig x))

@@ -338,9 +335,10 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs

338335 return ()

339336

340337

341−type XhrPayload = T.Text

338+

339+type XhrPayload = ByteString

342340bytesToPayload :: BL.ByteString -> XhrPayload

343−bytesToPayload = T.decodeUtf8 . BL.toStrict

341+bytesToPayload = BL.toStrict

344342

345343

346344performRequestsCT

@@ -355,14 +353,15 @@ performRequestsCT

355353 -> m (Event t (f (ReqResult tag a)))

356354performRequestsCT ct reqMeth reqs reqHost opts trigger = do

357355 resps <- performRequests reqMeth reqs reqHost opts trigger

358− let decodeResp x = first T.pack

359− . mimeUnrender ct

360− . JS.textToJSString

361− =<< note "No body text" (_xhrResponse_responseText x)

356+ let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =

357+ first T.pack .

358+ mimeUnrender ct $

359+ BL.fromStrict x

360+ decodeResp _ = Left "No body"

362361 return $ fmap

363362 (\(t,rs) -> ffor rs $ \r -> case r of

364363 Left e -> RequestFailure t e

365− Right g -> evalResponse decodeResp (t,g)

364+ Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)

366365 )

367366 resps

368367

@@ -389,8 +388,9 @@ evalResponse

389388 :: (XhrResponse -> Either Text a)

390389 -> (tag, XhrResponse)

391390 -> ReqResult tag a

392−evalResponse decodeRes (tag, xhr) =

393− let okStatus = _xhrResponse_status xhr < 400

391+evalResponse decode (tag, xhr) =

392+ let status = _xhrResponse_status xhr

393+ okStatus = status >= 200 && status < 400

394394 errMsg = fromMaybe

395395 ("Empty response with error code " <>

396396 T.pack (show $ _xhrResponse_status xhr))

@@ -399,56 +399,33 @@ evalResponse decodeRes (tag, xhr) =

399399 then either

400400 (\e -> ResponseFailure tag e xhr)

401401 (\v -> ResponseSuccess tag v xhr)

402− (decodeRes xhr)

402+ (decode xhr)

403403 else ResponseFailure tag errMsg xhr

404404 in respPayld

405405

406+------------------------------------------------------------------------------

407+-- | Utility for simultaneously accessing/filtering Success and Failure

408+-- response 'Event's,

409+fanReqResult :: Reflex t => Event t (ReqResult tag a) -> (Event t Text, Event t a)

410+fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess

406411

407−-- | Similar to 'Servant.API.ContentType.MimeUnrender' but with the differnce that

408−-- the second argument expects a JSString instead of ByteString.

409−-- This can lead to better performance ghcjs.

410−class Accept contentType => MimeUnrender contentType a where

411− mimeUnrender :: Proxy contentType -> JS.JSString -> Either String a

412−

413−instance FromJSON a => MimeUnrender JSON a where

414− mimeUnrender _ = note "Failed to decode response" . jsonDecode

415−

416−-- | @urlDecodeAsForm@

417−-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only

418−-- holds if every element of x is non-null (i.e., not @("", "")@)

419−instance FromForm a => MimeUnrender FormUrlEncoded a where

420− mimeUnrender _ = first T.unpack . urlDecodeAsForm . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString

421−

422−-- | @left show . TextL.decodeUtf8'@

423−instance MimeUnrender PlainText TL.Text where

424− mimeUnrender _ = pure . JS.lazyTextFromJSString

425−

426−-- | @left show . TextS.decodeUtf8' . toStrict@

427−instance MimeUnrender PlainText T.Text where

428− mimeUnrender _ = pure . JS.textFromJSString

429−

430−-- | @Right . BC.unpack@

431−instance MimeUnrender PlainText String where

432− mimeUnrender _ = Right . T.unpack . JS.textFromJSString

433−

434−-- | @Right . id@

435−instance MimeUnrender OctetStream ByteString where

436− mimeUnrender _ = pure . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString

412+------------------------------------------------------------------------------

413+-- | Utility for simultaneously accessing/filtering Success and Failure

414+-- response 'Event's, but keeping the request tag

415+fanReqResult' :: Reflex t => Event t (ReqResult tag a) -> (Event t (tag, Text), Event t (tag, a))

416+fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'

437417

438−-- | @Right . toStrict@

439−instance MimeUnrender OctetStream BS.ByteString where

440− mimeUnrender _ = pure . T.encodeUtf8 . JS.textFromJSString

441418

442419note :: e -> Maybe a -> Either e a

443−note e Nothing = Left e

444−note _ (Just a) = Right a

420+note e = maybe (Left e) Right

445421

446422fmapL :: (e -> e') -> Either e a -> Either e' a

447423fmapL _ (Right a) = Right a

448424fmapL f (Left e) = Left (f e)

449425

450−builderToText :: BB.Builder -> T.Text

451−builderToText = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString

426+builderToText :: Builder.Builder -> T.Text

427+builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString

452428

453429escape :: T.Text -> T.Text

454−escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . toEncodedUrlPiece

430+escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece

431+

src/Servant/Reflex.hs+124−207

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

88{-# LANGUAGE MultiParamTypeClasses #-}

99{-# LANGUAGE OverloadedStrings #-}

1010{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE Rank2Types #-}

1112{-# LANGUAGE ScopedTypeVariables #-}

1213{-# LANGUAGE TupleSections #-}

1314{-# LANGUAGE TypeFamilies #-}

@@ -25,7 +26,9 @@

2526module Servant.Reflex

2627 ( client

2728 , clientWithOpts

29+ , clientWithOptsAndResultHandler

2830 , clientWithRoute

31+ , clientWithRouteAndResultHandler

2932 , BuildHeaderKeysTo(..)

3033 , toHeaders

3134 , HasClient

@@ -36,39 +39,41 @@ module Servant.Reflex

3639

3740------------------------------------------------------------------------------

3841import Control.Applicative

39−import Data.Monoid ((<>))

40−import qualified Data.Set as Set

41−import qualified Data.Text.Encoding as E

42−import Data.CaseInsensitive (mk)

42+import qualified Data.CaseInsensitive as CI

4343import Data.Functor.Identity

44−import Data.Proxy (Proxy (..))

4544import qualified Data.Map as Map

45+import Data.Monoid ((<>))

46+import Data.Proxy (Proxy (..))

47+import qualified Data.Set as Set

4648import Data.Text (Text)

4749import qualified Data.Text as T

50+import qualified Data.Text.Encoding as E

4851import GHC.Exts (Constraint)

4952import GHC.TypeLits (KnownSymbol, symbolVal)

50−import Servant.API ((:<|>)(..),(:>), BasicAuth,

51− BasicAuthData, BuildHeadersTo(..),

52− Capture, contentType, Header,

53− Headers(..), HttpVersion, IsSecure,

54− MimeRender(..),

53+import Servant.API ((:<|>) (..), (:>), BasicAuth,

54+ BasicAuthData, BuildHeadersTo (..),

55+ Capture, Header, Headers (..),

56+ HttpVersion, IsSecure,

57+ MimeRender (..), MimeUnrender,

5558 NoContent, QueryFlag, QueryParam,

56− QueryParams, Raw, ReflectMethod(..),

59+ QueryParams, Raw, ReflectMethod (..),

5760 RemoteHost, ReqBody,

58− ToHttpApiData(..), Vault, Verb)

61+ ToHttpApiData (..), Vault, Verb,

62+ contentType)

63+import Servant.API.Description (Summary)

5964import qualified Servant.Auth as Auth

6065

6166import Reflex.Dom.Core (Dynamic, Event, Reflex,

62− XhrRequest(..),

63− XhrResponseHeaders(..),

64− XhrResponse(..), attachPromptlyDynWith, constDyn, ffor, fmapMaybe,

65− leftmost, performRequestsAsync,

66− )

67+ XhrRequest (..), XhrResponse (..),

68+ XhrResponseHeaders (..),

69+ attachPromptlyDynWith, constDyn, ffor,

70+ fmapMaybe, leftmost,

71+ performRequestsAsync)

6772------------------------------------------------------------------------------

6873import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,

6974 showBaseUrl,

7075 SupportsServantReflex)

71−import Servant.Common.Req (ClientOptions(..), MimeUnrender(..),

76+import Servant.Common.Req (ClientOptions(..),

7277 defaultClientOptions,

7378 Req, ReqResult(..), QParam(..),

7479 QueryPart(..), addHeader, authData,

@@ -84,8 +89,6 @@ import Servant.Common.Req (ClientOptions(..), MimeUnrender(..),

8489 response,

8590 reqTag,

8691 qParams, withCredentials)

87−import Servant.Checked.Exceptions.Internal.Envelope (Envelope)

88−import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow, Throws, Throwing, ThrowingNonterminal)

8992

9093

9194-- * Accessing APIs as a Client

@@ -100,7 +103,7 @@ import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow, Throws, Throwin

100103-- >

101104-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))

102105-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l

103−-- -> m (Event t (l, ReqResult Book)))

106+-- > -> m (Event t (l, ReqResult Book)))

104107-- > (getAllBooks :<|> postNewBook) = client myApi host

105108-- > where host = constDyn $ BaseUrl Http "localhost" 8080

106109client

@@ -122,21 +125,53 @@ clientWithOpts

122125 -> Client t m layout tag

123126clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl

124127

128+-- | Like 'clientWithOpts' but allows passing a function which will process the

129+-- result event in some way. This can be used to handle errors in a uniform way

130+-- across call sites.

131+clientWithOptsAndResultHandler

132+ :: (HasClient t m layout tag)

133+ => Proxy layout

134+ -> Proxy m

135+ -> Proxy tag

136+ -> Dynamic t BaseUrl

137+ -> ClientOptions

138+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))

139+ -> Client t m layout tag

140+clientWithOptsAndResultHandler p q t = clientWithRouteAndResultHandler p q t defReq

141+

125142

126143-- | This class lets us define how each API combinator

127144-- influences the creation of an HTTP request. It's mostly

128145-- an internal class, you can just use 'client'.

129−class HasClient t m layout (tag :: *) where

146+class Monad m => HasClient t m layout (tag :: *) where

130147 type Client t m layout tag :: *

131− clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag

148+ clientWithRoute

149+ :: Proxy layout

150+ -> Proxy m

151+ -> Proxy tag

152+ -> Req t

153+ -> Dynamic t BaseUrl

154+ -> ClientOptions

155+ -> Client t m layout tag

156+ clientWithRoute l m t r b o = clientWithRouteAndResultHandler l m t r b o return

157+

158+ clientWithRouteAndResultHandler

159+ :: Proxy layout

160+ -> Proxy m

161+ -> Proxy tag

162+ -> Req t

163+ -> Dynamic t BaseUrl

164+ -> ClientOptions

165+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))

166+ -> Client t m layout tag

132167

133168

134169instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where

135170 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag

136171

137− clientWithRoute Proxy q pTag req baseurl opts =

138− clientWithRoute (Proxy :: Proxy a) q pTag req baseurl opts :<|>

139− clientWithRoute (Proxy :: Proxy b) q pTag req baseurl opts

172+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =

173+ clientWithRouteAndResultHandler (Proxy :: Proxy a) q pTag req baseurl opts wrap :<|>

174+ clientWithRouteAndResultHandler (Proxy :: Proxy b) q pTag req baseurl opts wrap

140175

141176

142177-- Capture. Example:

@@ -157,11 +192,9 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta

157192 type Client t m (Capture capture a :> sublayout) tag =

158193 Dynamic t (Either Text a) -> Client t m sublayout tag

159194

160− clientWithRoute Proxy q t req baseurl opts val =

161− clientWithRoute (Proxy :: Proxy sublayout)

162− q t

163− (prependToPathParts p req)

164− baseurl opts

195+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =

196+ clientWithRouteAndResultHandler

197+ (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap

165198 where p = (fmap . fmap) (toUrlPiece) val

166199

167200

@@ -174,8 +207,8 @@ instance {-# OVERLAPPABLE #-}

174207 Event t tag -> m (Event t (ReqResult tag a))

175208 -- TODO how to access input types here?

176209 -- ExceptT ServantError IO a

177− clientWithRoute Proxy _ _ req baseurl opts trigs =

178− fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs

210+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =

211+ wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs

179212 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

180213 req' = req { reqMethod = method }

181214

@@ -188,29 +221,33 @@ instance {-# OVERLAPPING #-}

188221 Event t tag -> m (Event t (ReqResult tag NoContent))

189222 -- TODO: how to access input types here?

190223 -- ExceptT ServantError IO NoContent

191− clientWithRoute Proxy _ _ req baseurl opts =

192− (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl opts

224+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =

225+ wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs

193226 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

194227

195228

196229toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)

197230toHeaders r =

198− let toBS = E.encodeUtf8

199− hdrs = maybe []

200− (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))

231+ let hdrs = maybe []

232+ (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))

201233 (Map.toList $ _xhrResponse_headers xhr))

202234 (response r)

203235 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}

204236

237+

205238class BuildHeaderKeysTo hs where

206− buildHeaderKeysTo :: Proxy hs -> [T.Text]

239+ buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]

207240

208241instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]

209242 where buildHeaderKeysTo _ = []

210243

211244instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)

212245 => BuildHeaderKeysTo ((Header h v) ': xs) where

213− buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)

246+ buildHeaderKeysTo _ =

247+ let

248+ thisKey = CI.mk $ T.pack (symbolVal (Proxy :: Proxy h))

249+ in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)

250+

214251

215252-- HEADERS Verb (Content) --

216253-- Headers combinator not treated in fully general case,

@@ -225,10 +262,10 @@ instance {-# OVERLAPPABLE #-}

225262 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where

226263 type Client t m (Verb method status cts' (Headers ls a)) tag =

227264 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))

228− clientWithRoute Proxy _ _ req baseurl opts trigs = do

265+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do

229266 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

230267 resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs

231− return $ toHeaders <$> resp

268+ wrap $ toHeaders <$> resp

232269 where req' = req { respHeaders =

233270 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))

234271 }

@@ -241,10 +278,10 @@ instance {-# OVERLAPPABLE #-}

241278 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where

242279 type Client t m (Verb method status cts (Headers ls NoContent)) tag

243280 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))

244− clientWithRoute Proxy _ _ req baseurl opts trigs = do

281+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do

245282 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

246283 resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs

247− return $ toHeaders <$> resp

284+ wrap $ toHeaders <$> resp

248285 where req' = req {respHeaders =

249286 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))

250287 }

@@ -271,11 +308,11 @@ instance (KnownSymbol sym, ToHttpApiData a,

271308 type Client t m (Header sym a :> sublayout) tag =

272309 Dynamic t (Either Text a) -> Client t m sublayout tag

273310

274− clientWithRoute Proxy q t req baseurl opts eVal =

275− clientWithRoute (Proxy :: Proxy sublayout)

276− q t

277− (Servant.Common.Req.addHeader hname eVal req)

278− baseurl opts

311+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =

312+ clientWithRouteAndResultHandler

313+ (Proxy :: Proxy sublayout) q t

314+ (Servant.Common.Req.addHeader hname eVal req)

315+ baseurl opts wrap

279316 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)

280317

281318

@@ -289,8 +326,21 @@ instance HasClient t m sublayout tag

289326 type Client t m (HttpVersion :> sublayout) tag =

290327 Client t m sublayout tag

291328

292− clientWithRoute Proxy q t =

293− clientWithRoute (Proxy :: Proxy sublayout) q t

329+ clientWithRouteAndResultHandler Proxy =

330+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

331+

332+-- | Using a 'Summary' combinator in your API doesn't affect the client

333+-- functions.

334+instance (HasClient t m sublayout tag, KnownSymbol sym)

335+ => HasClient t m (Summary sym :> sublayout) tag where

336+

337+ type Client t m (Summary sym :> sublayout) tag =

338+ Client t m sublayout tag

339+

340+ clientWithRouteAndResultHandler Proxy =

341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

342+

343+

294344

295345

296346-- | If you use a 'QueryParam' in one of your endpoints in your API,

@@ -326,9 +376,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex

326376 Dynamic t (QParam a) -> Client t m sublayout tag

327377

328378 -- if mparam = Nothing, we don't add it to the query string

329− clientWithRoute Proxy q t req baseurl opts mparam =

330− clientWithRoute (Proxy :: Proxy sublayout) q t

331− (req {qParams = paramPair : qParams req}) baseurl opts

379+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =

380+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t

381+ (req {qParams = paramPair : qParams req}) baseurl opts wrap

332382

333383 where pname = symbolVal (Proxy :: Proxy sym)

334384 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm

@@ -372,8 +422,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex

372422 type Client t m (QueryParams sym a :> sublayout) tag =

373423 Dynamic t [a] -> Client t m sublayout tag

374424

375− clientWithRoute Proxy q t req baseurl opts paramlist =

376− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts

425+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =

426+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap

377427

378428 where req' = req { qParams = (T.pack pname, params') : qParams req }

379429 pname = symbolVal (Proxy :: Proxy sym)

@@ -412,8 +462,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)

412462 type Client t m (QueryFlag sym :> sublayout) tag =

413463 Dynamic t Bool -> Client t m sublayout tag

414464

415− clientWithRoute Proxy q t req baseurl opts flag =

416− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts

465+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =

466+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap

417467

418468 where req' = req { qParams = thisPair : qParams req }

419469 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)

@@ -427,7 +477,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where

427477 -> Event t tag

428478 -> m (Event t (ReqResult tag ()))

429479

430− clientWithRoute _ _ _ _ baseurl _ xhrs triggers = do

480+ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do

431481

432482 let xhrs' = liftA2 (\x path -> case x of

433483 Left e -> Left e

@@ -438,7 +488,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where

438488 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())

439489

440490 resps <- performRequestsAsync okReq

441− return $ leftmost [ uncurry RequestFailure <$> badReq

491+ wrap $ leftmost [ uncurry RequestFailure <$> badReq

442492 , evalResponse (const $ Right ()) <$> resps

443493 ]

444494

@@ -469,8 +519,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)

469519 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =

470520 Dynamic t (Either Text a) -> Client t m sublayout tag

471521

472− clientWithRoute Proxy q t req baseurl opts body =

473− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts

522+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =

523+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap

474524 where req' = req { reqBody = bodyBytesCT }

475525 ctProxy = Proxy :: Proxy ct

476526 ctString = T.pack $ show $ contentType ctProxy

@@ -484,9 +534,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)

484534instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where

485535 type Client t m (path :> sublayout) tag = Client t m sublayout tag

486536

487− clientWithRoute Proxy q t req baseurl opts =

488− clientWithRoute (Proxy :: Proxy sublayout) q t

489− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts

537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =

538+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t

539+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap

490540

491541 where p = symbolVal (Proxy :: Proxy path)

492542

@@ -494,23 +544,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient

494544instance HasClient t m api tag => HasClient t m (Vault :> api) tag where

495545 type Client t m (Vault :> api) tag = Client t m api tag

496546

497− clientWithRoute Proxy q t req baseurl =

498− clientWithRoute (Proxy :: Proxy api) q t req baseurl

547+ clientWithRouteAndResultHandler Proxy =

548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

499549

500550

501551instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where

502552 type Client t m (RemoteHost :> api) tag = Client t m api tag

503553

504− clientWithRoute Proxy q t req baseurl =

505− clientWithRoute (Proxy :: Proxy api) q t req baseurl

554+ clientWithRouteAndResultHandler Proxy =

555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

506556

507557

508558

509559instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where

510560 type Client t m (IsSecure :> api) tag = Client t m api tag

511561

512− clientWithRoute Proxy q t req baseurl =

513− clientWithRoute (Proxy :: Proxy api) q t req baseurl

562+ clientWithRouteAndResultHandler Proxy =

563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

514564

515565

516566instance (HasClient t m api tag, Reflex t)

@@ -519,8 +569,8 @@ instance (HasClient t m api tag, Reflex t)

519569 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)

520570 -> Client t m api tag

521571

522− clientWithRoute Proxy q t req baseurl opts authdata =

523− clientWithRoute (Proxy :: Proxy api) q t req' baseurl opts

572+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =

573+ clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap

524574 where

525575 req' = req { authData = Just authdata }

526576

@@ -563,7 +613,7 @@ for empty and one for non-empty lists).

563613instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where

564614

565615 type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag

566− clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)

616+ clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)

567617

568618

569619type family HasCookieAuth xs :: Constraint where

@@ -573,136 +623,3 @@ type family HasCookieAuth xs :: Constraint where

573623

574624class CookieAuthNotEnabled

575625

576−{- servant-checked-exceptions

577−~~~~~~~~~~~~~~~~~~~~~

578−-}

579−

580−-- | Change a 'Throws' into 'Throwing'.

581−instance (HasClient t m (Throwing '[e] :> api) tag) => HasClient t m (Throws e :> api) tag where

582− type Client t m (Throws e :> api) tag = Client t m (Throwing '[e] :> api) tag

583−

584− clientWithRoute

585− :: Proxy (Throws e :> api)

586− -> Proxy m

587− -> Proxy tag

588− -> Req t

589− -> Dynamic t BaseUrl

590− -> ClientOptions

591− -> Client t m (Throwing '[e] :> api) tag

592− clientWithRoute _ = clientWithRoute (Proxy :: Proxy (Throwing '[e] :> api))

593−

594−-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'

595−-- but returning an @'Envelope' es@.

596−instance (HasClient t m (Verb method status ctypes (Envelope es a)) tag) =>

597− HasClient t m (Throwing es :> Verb method status ctypes a) tag where

598−

599− type Client t m (Throwing es :> Verb method status ctypes a) tag =

600− Client t m (Verb method status ctypes (Envelope es a)) tag

601−

602− clientWithRoute

603− :: Proxy (Throwing es :> Verb method status ctypes a)

604− -> Proxy m

605− -> Proxy tag

606− -> Req t

607− -> Dynamic t BaseUrl

608− -> ClientOptions

609− -> Client t m (Verb method status ctypes (Envelope es a)) tag

610− clientWithRoute Proxy =

611− clientWithRoute (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))

612−

613−-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'

614−-- but returning an @'Envelope' \'[]@.

615−instance (HasClient t m (Verb method status ctypes (Envelope '[] a)) tag) =>

616− HasClient t m (NoThrow :> Verb method status ctypes a) tag where

617−

618− type Client t m (NoThrow :> Verb method status ctypes a) tag =

619− Client t m (Verb method status ctypes (Envelope '[] a)) tag

620−

621− clientWithRoute

622− :: Proxy (NoThrow :> Verb method status ctypes a)

623− -> Proxy m

624− -> Proxy tag

625− -> Req t

626− -> Dynamic t BaseUrl

627− -> ClientOptions

628− -> Client t m (Verb method status ctypes (Envelope '[] a)) tag

629− clientWithRoute Proxy =

630− clientWithRoute (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))

631−

632−-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each

633−-- branch of the API.

634−instance HasClient t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag =>

635− HasClient t m (Throwing es :> (api1 :<|> api2)) tag where

636−

637− type Client t m (Throwing es :> (api1 :<|> api2)) tag =

638− Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag

639−

640− clientWithRoute

641− :: Proxy (Throwing es :> (api1 :<|> api2))

642− -> Proxy m

643− -> Proxy tag

644− -> Req t

645− -> Dynamic t BaseUrl

646− -> ClientOptions

647− -> Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag

648− clientWithRoute _ =

649− clientWithRoute (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))

650−

651−-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each branch of the

652−-- API.

653−instance HasClient t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag =>

654− HasClient t m (NoThrow :> (api1 :<|> api2)) tag where

655−

656− type Client t m (NoThrow :> (api1 :<|> api2)) tag =

657− Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag

658−

659− clientWithRoute

660− :: Proxy (NoThrow :> (api1 :<|> api2))

661− -> Proxy m

662− -> Proxy tag

663− -> Req t

664− -> Dynamic t BaseUrl

665− -> ClientOptions

666− -> Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag

667− clientWithRoute _ =

668− clientWithRoute (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))

669−

670−-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the

671−-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other

672−-- combinator, push it down so it is closer to the 'Verb'.

673−instance HasClient t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag =>

674− HasClient t m (Throwing es :> api :> apis) tag where

675−

676− type Client t m (Throwing es :> api :> apis) tag =

677− Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag

678−

679− clientWithRoute

680− :: Proxy (Throwing es :> api :> apis)

681− -> Proxy m

682− -> Proxy tag

683− -> Req t

684− -> Dynamic t BaseUrl

685− -> ClientOptions

686− -> Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag

687− clientWithRoute _ =

688− clientWithRoute (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))

689−

690−-- | When 'NoThrow' comes before any other combinator, push it down so it is

691−-- closer to the 'Verb'.

692−instance HasClient t m (api :> NoThrow :> apis) tag =>

693− HasClient t m (NoThrow :> api :> apis) tag where

694−

695− type Client t m (NoThrow :> api :> apis) tag =

696− Client t m (api :> NoThrow :> apis) tag

697−

698− clientWithRoute

699− :: Proxy (NoThrow :> api :> apis)

700− -> Proxy m

701− -> Proxy tag

702− -> Req t

703− -> Dynamic t BaseUrl

704− -> ClientOptions

705− -> Client t m (api :> NoThrow :> apis) tag

706− clientWithRoute _ =

707− clientWithRoute (Proxy :: Proxy (api :> NoThrow :> apis))

708−

src/Servant/Reflex/Multi.hs+36−165

@@ -37,32 +37,34 @@ module Servant.Reflex.Multi (

3737 ) where

3838

3939------------------------------------------------------------------------------

40−import Control.Applicative (liftA2)

41−import Data.Functor.Compose (Compose (..), getCompose)

42−import Data.Proxy (Proxy (..))

43−import qualified Data.Set as Set

44−import Data.Text (Text)

45−import qualified Data.Text as T

46−import qualified Data.Text.Encoding as E

47−import GHC.TypeLits (KnownSymbol, symbolVal)

48−import Servant.API ((:<|>) (..), (:>), BasicAuth,

49− BasicAuthData, BuildHeadersTo (..),

50− Capture, Header, Headers (..),

51− HttpVersion, IsSecure, MimeRender (..),

52− NoContent, QueryFlag,

53− QueryParam, QueryParams, Raw,

54− ReflectMethod (..), RemoteHost,

55− ReqBody, ToHttpApiData (..), Vault,

56− Verb, contentType)

57−

58−import Reflex.Dom.Core (Dynamic, Event, Reflex,

59− XhrRequest (..),

60− XhrResponseHeaders (..),

61− attachPromptlyDynWith, constDyn)

40+import Control.Applicative (liftA2)

41+import Data.Functor.Compose (Compose (..), getCompose)

42+import Data.Proxy (Proxy (..))

43+import qualified Data.Set as Set

44+import Data.Text (Text)

45+import qualified Data.Text as T

46+import qualified Data.Text.Encoding as E

47+import GHC.TypeLits (KnownSymbol, symbolVal)

48+import Servant.API ((:<|>) (..), (:>), BasicAuth,

49+ BasicAuthData, BuildHeadersTo (..),

50+ Capture, Header, Headers (..),

51+ HttpVersion, IsSecure,

52+ MimeRender (..), MimeUnrender,

53+ NoContent, QueryFlag, QueryParam,

54+ QueryParams, Raw, ReflectMethod (..),

55+ RemoteHost, ReqBody,

56+ ToHttpApiData (..), Vault, Verb,

57+ contentType)

58+import Servant.API.Description (Summary)

59+

60+import Reflex.Dom.Core (Dynamic, Event, Reflex,

61+ XhrRequest (..),

62+ XhrResponseHeaders (..),

63+ attachPromptlyDynWith, constDyn)

6264------------------------------------------------------------------------------

6365import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),

6466 SupportsServantReflex)

65−import Servant.Common.Req (ClientOptions, MimeUnrender,

67+import Servant.Common.Req (ClientOptions,

6668 QParam (..), QueryPart (..), Req,

6769 ReqResult (..), addHeader, authData,

6870 defReq,

@@ -74,8 +76,6 @@ import Servant.Common.Req (ClientOptions, MimeUnrender,

7476 qParams, reqBody, reqFailure,

7577 reqMethod, reqSuccess, reqSuccess',

7678 respHeaders, response, withCredentials)

77−import Servant.Checked.Exceptions.Internal.Envelope (Envelope)

78−import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow, Throws, Throwing, ThrowingNonterminal)

7979import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)

8080

8181

@@ -242,6 +242,17 @@ instance HasClientMulti t m sublayout f tag

242242 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

243243

244244

245+------------------------------------------------------------------------------

246+instance (HasClientMulti t m sublayout f tag, KnownSymbol sym)

247+ => HasClientMulti t m (Summary sym :> sublayout) f tag where

248+

249+ type ClientMulti t m (Summary sym :> sublayout) f tag =

250+ ClientMulti t m sublayout f tag

251+

252+ clientWithRouteMulti Proxy q f tag =

253+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

254+

255+

245256------------------------------------------------------------------------------

246257instance (KnownSymbol sym,

247258 ToHttpApiData a,

@@ -388,143 +399,3 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)

388399 where

389400 req' a r = r { authData = Just (constDyn a) }

390401 reqs' = liftA2 req' <$> authdatas <*> reqs

391−

392−{- servant-checked-exceptions

393−~~~~~~~~~~~~~~~~~~~~~

394−-}

395−

396−-- | Change a 'Throws' into 'Throwing'.

397−instance (HasClientMulti t m (Throwing '[e] :> api) f tag) => HasClientMulti t m (Throws e :> api) f tag where

398− type ClientMulti t m (Throws e :> api) f tag = ClientMulti t m (Throwing '[e] :> api) f tag

399−

400− clientWithRouteMulti

401− :: Proxy (Throws e :> api)

402− -> Proxy m

403− -> Proxy f

404− -> Proxy tag

405− -> Dynamic t (f (Req t))

406− -> Dynamic t BaseUrl

407− -> ClientOptions

408− -> ClientMulti t m (Throwing '[e] :> api) f tag

409− clientWithRouteMulti _ = clientWithRouteMulti (Proxy :: Proxy (Throwing '[e] :> api))

410−

411−-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'

412−-- but returning an @'Envelope' es@.

413−instance (HasClientMulti t m (Verb method status ctypes (Envelope es a)) f tag) =>

414− HasClientMulti t m (Throwing es :> Verb method status ctypes a) f tag where

415−

416− type ClientMulti t m (Throwing es :> Verb method status ctypes a) f tag =

417− ClientMulti t m (Verb method status ctypes (Envelope es a)) f tag

418−

419− clientWithRouteMulti

420− :: Proxy (Throwing es :> Verb method status ctypes a)

421− -> Proxy m

422− -> Proxy f

423− -> Proxy tag

424− -> Dynamic t (f (Req t))

425− -> Dynamic t BaseUrl

426− -> ClientOptions

427− -> ClientMulti t m (Verb method status ctypes (Envelope es a)) f tag

428− clientWithRouteMulti Proxy =

429− clientWithRouteMulti (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))

430−

431−-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'

432−-- but returning an @'Envelope' \'[]@.

433−instance (HasClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag) =>

434− HasClientMulti t m (NoThrow :> Verb method status ctypes a) f tag where

435−

436− type ClientMulti t m (NoThrow :> Verb method status ctypes a) f tag =

437− ClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag

438−

439− clientWithRouteMulti

440− :: Proxy (NoThrow :> Verb method status ctypes a)

441− -> Proxy m

442− -> Proxy f

443− -> Proxy tag

444− -> Dynamic t (f (Req t))

445− -> Dynamic t BaseUrl

446− -> ClientOptions

447− -> ClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag

448− clientWithRouteMulti Proxy =

449− clientWithRouteMulti (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))

450−

451−-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each

452−-- branch of the API.

453−instance HasClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag =>

454− HasClientMulti t m (Throwing es :> (api1 :<|> api2)) f tag where

455−

456− type ClientMulti t m (Throwing es :> (api1 :<|> api2)) f tag =

457− ClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag

458−

459− clientWithRouteMulti

460− :: Proxy (Throwing es :> (api1 :<|> api2))

461− -> Proxy m

462− -> Proxy f

463− -> Proxy tag

464− -> Dynamic t (f (Req t))

465− -> Dynamic t BaseUrl

466− -> ClientOptions

467− -> ClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag

468− clientWithRouteMulti _ =

469− clientWithRouteMulti (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))

470−

471−-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each branch of the

472−-- API.

473−instance HasClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag =>

474− HasClientMulti t m (NoThrow :> (api1 :<|> api2)) f tag where

475−

476− type ClientMulti t m (NoThrow :> (api1 :<|> api2)) f tag =

477− ClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag

478−

479− clientWithRouteMulti

480− :: Proxy (NoThrow :> (api1 :<|> api2))

481− -> Proxy m

482− -> Proxy f

483− -> Proxy tag

484− -> Dynamic t (f (Req t))

485− -> Dynamic t BaseUrl

486− -> ClientOptions

487− -> ClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag

488− clientWithRouteMulti _ =

489− clientWithRouteMulti (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))

490−

491−-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the

492−-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other

493−-- combinator, push it down so it is closer to the 'Verb'.

494−instance HasClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag =>

495− HasClientMulti t m (Throwing es :> api :> apis) f tag where

496−

497− type ClientMulti t m (Throwing es :> api :> apis) f tag =

498− ClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag

499−

500− clientWithRouteMulti

501− :: Proxy (Throwing es :> api :> apis)

502− -> Proxy m

503− -> Proxy f

504− -> Proxy tag

505− -> Dynamic t (f (Req t))

506− -> Dynamic t BaseUrl

507− -> ClientOptions

508− -> ClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag

509− clientWithRouteMulti _ =

510− clientWithRouteMulti (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))

511−

512−-- | When 'NoThrow' comes before any other combinator, push it down so it is

513−-- closer to the 'Verb'.

514−instance HasClientMulti t m (api :> NoThrow :> apis) f tag =>

515− HasClientMulti t m (NoThrow :> api :> apis) f tag where

516−

517− type ClientMulti t m (NoThrow :> api :> apis) f tag =

518− ClientMulti t m (api :> NoThrow :> apis) f tag

519−

520− clientWithRouteMulti

521− :: Proxy (NoThrow :> api :> apis)

522− -> Proxy m

523− -> Proxy f

524− -> Proxy tag

525− -> Dynamic t (f (Req t))

526− -> Dynamic t BaseUrl

527− -> ClientOptions

528− -> ClientMulti t m (api :> NoThrow :> apis) f tag

529− clientWithRouteMulti _ =

530− clientWithRouteMulti (Proxy :: Proxy (api :> NoThrow :> apis))

testdriver/test/Servant/ReflexSpec.hs+2−1

@@ -9,6 +9,7 @@ import qualified Data.Text as T

99import Data.Foldable

1010import Test.WebDriver.Commands.Wait

1111import Test.Hspec.WebDriver

12+import Test.Hspec.WebDriver (chromeCaps)

1213

1314

1415clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()

@@ -28,7 +29,7 @@ spec :: Spec

2829spec = do

2930 describe "servant-reflex tests" $ do

3031

31− session "test page" $ using Chrome $ do

32+ session "test page" $ using [chromeCaps] $ do

3233

3334 it "opens the page" $ runWD $

3435 openPage "http://localhost:8000"

testserver/API.hsmode 120000 → 100644+69−1

@@ -1 +0,0 @@

1−../exec/API.hs

@@ -0,0 +1,69 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeOperators #-}

5+module API where

7+import Data.Aeson

8+import Data.Aeson.Types (typeMismatch)

9+import Data.Text (Text)

10+import Servant.API

11+

12+newtype Question = Question { unQuestion :: Text } deriving (Show)

13+

14+instance ToJSON Question where

15+ toJSON (Question txt) = object ["question" .= txt]

16+

17+instance FromJSON Question where

18+ parseJSON (Object v) = Question <$> v .: "question"

19+ parseJSON x = typeMismatch "Couldn't find key 'question'" x

20+

21+newtype Answer = Answer { unAnswer :: Text } deriving (Show)

22+

23+instance ToJSON Answer where

24+ toJSON (Answer txt) = object ["answer" .= txt]

25+

26+instance FromJSON Answer where

27+ parseJSON (Object v) = Answer <$> v .: "answer"

28+ parseJSON x = typeMismatch "Couldn't find key 'answer'" x

29+

30+

31+-- | API spec for server, client, and docs

32+type API = "getunit" :> Get '[JSON] ()

33+ :<|> "getint" :> Get '[JSON] Int

34+ :<|> "sayhi" :> QueryParam "username" Text

35+ :> QueryParams "greetings" Text

36+ :> QueryFlag "gusto"

37+ :> Get '[JSON] Text

38+ :<|> "double" :> ReqBody '[JSON] Double

39+ :> Post '[JSON] Double

40+ :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text

41+ :<|> "qna" :> ReqBody '[JSON] Question

42+ :> Post '[JSON] Answer

43+ :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int

44+ :<|> Raw

45+

46+type GET = Get '[JSON] ()

47+

48+-- Imported the comprehensive API example for testing.

49+-- https://github.com/haskell-servant/servant/blob/master/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs

50+type ComprehensiveAPI =

51+ GET :<|>

52+ Get '[JSON] Int :<|>

53+ Capture "foo" Int :> GET :<|>

54+ Header "foo" Int :> GET :<|>

55+ HttpVersion :> GET :<|>

56+ IsSecure :> GET :<|>

57+ QueryParam "foo" Int :> GET :<|>

58+ QueryParams "foo" Int :> GET :<|>

59+ QueryFlag "foo" :> GET :<|>

60+-- Raw :<|>

61+ RemoteHost :> GET :<|>

62+ ReqBody '[JSON] Int :> GET :<|>

63+ Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>

64+ "foo" :> GET :<|>

65+ Vault :> GET :<|>

66+ Verb 'POST 204 '[JSON] () :<|>

67+ Verb 'POST 204 '[JSON] Int

68+-- This one isn't in scope

69+-- :<|> WithNamedContext "foo" '[] GET

testserver/Main.hs+10−3

@@ -7,10 +7,12 @@

77{-# LANGUAGE TypeOperators #-}

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

10+import Control.Monad.Reader (reader)

1011import Data.Aeson

1112import Data.Bool

1213import Data.Char (toUpper)

1314import qualified Data.List as L

15+import Data.Maybe (fromMaybe)

1416import Data.Monoid

1517import Data.Proxy

1618import Data.Text hiding (head, length, map,

@@ -25,6 +27,7 @@ import Snap.Http.Server

2527import Servant

2628import Servant.Server

2729-- import Snap.Util.FileServe

30+import System.Environment (lookupEnv)

2831import API

2932import Snap

3033

@@ -40,7 +43,7 @@ instance ToJSON Greet

4043testApi :: Proxy API

4144testApi = Proxy

4245

43−data App = App

46+data App = App { appStaticDir :: String }

4447

4548-- Server-side handlers.

4649--

@@ -51,7 +54,7 @@ data App = App

5154server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)

5255server = return () :<|> return 100 :<|> sayhi :<|> dbl

5356 :<|> multi :<|> qna :<|> serveSecret

54− :<|> serveDirectory "static"

57+ :<|> statics

5558 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text

5659 sayhi nm greetings withGusto = case nm of

5760 Nothing -> return ("Sorry, who are you?" :: Text)

@@ -76,6 +79,9 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl

7679 req <- getRequest

7780 liftIO $ putStrLn (show req)

7881 return 101

82+ statics = do

83+ staticDir <- reader appStaticDir

84+ serveDirectory staticDir

7985

8086-- Turn the server into a WAI app. 'serve' is provided by servant,

8187-- more precisely by the Servant.Server module.

@@ -85,10 +91,11 @@ test = serveSnapWithContext testApi

8591

8692initApp :: SnapletInit App App

8793initApp = makeSnaplet "myapp" "example" Nothing $ do

94+ staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")

8895 addRoutes [("", test)

8996 ,("", serveDirectory "static")

9097 ]

91− return App

98+ return (App staticDir)

9299

93100-- Put this all to work!

94101main :: IO ()

testserver/run-wd-tests.shdeleted−5

@@ -1,5 +0,0 @@

1−#!/usr/bin/env bash

2−

3−dist/build/back/back -p 8000 &

4−phantomjs --webdriver=127.0.0.1:4444 &

5−dist/build/spec/spec

testserver/testserver.cabal+5−4

@@ -19,12 +19,13 @@ executable back

1919 main-is: Main.hs

2020 -- other-modules:

2121 -- other-extensions:

22− build-depends: aeson >= 0.9 && < 1.4

23− , base >=4.8 && <4.11

22+ build-depends: aeson >= 0.9 && < 1.5

23+ , base >=4.8 && < 5

24+ , mtl

2425 , snap >= 1.0 && < 1.2

25− , snap-server >= 1.0 && < 1.1

26+ , snap-server >= 1.0 && < 1.2

2627 , snap-core >= 1.0 && < 1.1

27− , servant >= 0.8 && < 0.12

28+ , servant >= 0.16 && < 0.18

2829 , servant-snap >= 0.8 && < 0.9

2930 , text >= 1.0 && < 1.3

3031 -- hs-source-dirs:

testserver/tr.nixdeleted−32

@@ -1,32 +0,0 @@

1−{ reflex-platform, ... }:

2−let

3−

4− dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;

5− cabal2nixResult = reflex-platform.cabal2nixResult;

6− nixpkgs = (import <nixpkgs> {});

7−in

8−reflex-platform.ghc.override {

9− overrides = self: super: {

10− servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});

11− snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap) {});

12− io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});

13− io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});

14− heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});

15− xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});

16− snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});

17− snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});

18− snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});

19− snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});

20− hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});

21−

22− # servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});

23− # servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});

24− # servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});

25− # servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});

26− # servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});

27− # servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});

28− # servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});

29− # servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});

30−

31− };

32−}

travis.nixnew file+70

@@ -0,0 +1,70 @@

1+{

2+ nativeCompiler ? "ghc",

3+ # ^ Choose a GHC for compiling backend components (web server, selenium)

4+ # (ghc, ghc8_0, ghc8_2, ghc8_4 or ghcHEAD)

6+ jsCompiler ? "ghcjs"

7+ # ^ Choose a GHCJS for compiling the frontend

8+ # (ghcjs, ghcjs8_0, ghcjs8_2 or ghcjs8_4)

10+}:

11+

12+let

13+

14+ reflexPlatform = import ./nix/reflex-platform.nix;

15+

16+ lib = reflexPlatform.nixpkgs.haskell.lib;

17+ do = funs: pkg: builtins.foldl' (a: b: b a) pkg funs;

18+

19+ ghcjsPkgs = with lib; reflexPlatform.${jsCompiler}.override {

20+ overrides = self: super: {

21+ http-media = dontCheck super.http-media;

22+ servant = dontCheck super.servant;

23+ lens-aeson = dontCheck super.lens-aeson;

24+ servant-reflex = lib.appendConfigureFlag

25+ (self.callPackage ./default.nix {}) "-fExample";

26+ };

27+ };

28+

29+ ghcPkgs = with lib; reflexPlatform.${nativeCompiler}.override {

30+ overrides = self: super: {

31+ servant-snap = dontCheck ((import ./nix/servant-snap.nix {}) self super);

32+ testdriver = self.callCabal2nix "testdriver" ./testdriver {};

33+ testserver = import nix/testserver.nix ghcjsPkgs.servant-reflex self super;

34+ servant-reflex = self.callPackage ./default.nix {};

35+ };

36+ };

37+

38+ testresults = import ./nix/testresults.nix

39+ { inherit reflexPlatform;

40+ inherit (ghcPkgs) testserver testdriver;

41+ inherit (reflexPlatform.nixpkgs) curl;

42+ phantomjs = reflexPlatform.nixpkgs.phantomjs2;

43+ };

44+

45+in

46+ rec {

47+

48+ inherit reflexPlatform ghcPkgs ghcjsPkgs;

49+

50+ build = ghcjsPkgs.servant-reflex;

51+ buildGhc = ghcPkgs.servant-reflex;

52+ testserver = ghcPkgs.testserver;

53+ testdriver = ghcPkgs.testdriver;

54+ inherit testresults;

55+

56+ cabalBuild = reflexPlatform.${jsCompiler}.shellFor {

57+ name = "servant-reflex-cabal-builder";

58+

59+ packages = p: [

60+ build

61+ ];

62+

63+ shellHook = ''

64+ cabal configure --ghcjs -f Example

65+ cabal build

66+ exec/toSite.sh

67+ exit $?

68+ '';

69+ };

70+ }