3b6ce36...master · servant-reflex

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

3+

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

8+

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

44

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

66

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 }:

2+

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:

2+

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+25−18

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

27+ base >= 4.8 && < 5,

3028 bytestring >= 0.10 && < 0.11,

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

32− containers >= 0.5.6 && < 0.6,

30+ containers >= 0.5.6 && < 0.7,

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

34− exceptions >= 0.8 && < 0.9,

32+ exceptions >= 0.8 && < 0.11,

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

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

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

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

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

3836 jsaddle >= 0.8 && < 0.10,

3937 mtl >= 2.2.1 && < 2.3,

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

41− reflex >= 0.5 && < 0.6,

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

39+ reflex >= 0.5 && < 0.9,

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

4341 safe >= 0.3.9 && < 0.4,

44− servant >= 0.8 && < 0.12,

45− servant-auth >= 0.2.1 && < 0.3,

42+ servant >= 0.16 && < 0.18,

43+ servant-auth >= 0.2.1 && < 0.4,

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

4745 text >= 1.2 && < 1.3,

4846 transformers >= 0.4 && < 0.6

4947

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

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

5149

5250 default-language: Haskell2010

5351

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

5654 buildable: True

5755 else

5856 buildable: False

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

6067 default-language: Haskell2010

6168 main-is: Example.hs

6269 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+39−16

@@ -12,12 +12,14 @@ module Servant.Common.Req where

1212

1313-------------------------------------------------------------------------------

1414import Control.Applicative (liftA2, liftA3)

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

1516import Control.Concurrent

1617import Control.Monad (join)

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

1819import Data.Bifunctor (first)

1920import qualified Data.ByteString.Builder as Builder

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

22+import Data.ByteString (ByteString)

2123import qualified Data.Map as Map

2224import Data.Maybe (catMaybes, fromMaybe)

2325import Data.Functor.Compose

@@ -27,7 +29,7 @@ import Data.Text (Text)

2729import qualified Data.Text as T

2830import qualified Data.Text.Encoding as TE

2931import Data.Traversable (forM)

30−import Language.Javascript.JSaddle.Monad (JSM, MonadJSM)

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

3133import qualified Network.URI as N

3234import Reflex.Dom.Core hiding (tag)

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

@@ -51,7 +53,7 @@ data ReqResult tag a

5153 deriving (Functor)

5254

5355data ClientOptions = ClientOptions

54− { optsRequestFixup :: forall a. Show a => XhrRequest a -> IO (XhrRequest a)

56+ { optsRequestFixup :: forall a. Show a => XhrRequest a -> JSM (XhrRequest a)

5557 -- ^ Aribtrarily modify requests just before they are sent.

5658 -- Warning: This escape hatch opens the possibility for your

5759 -- requests to diverge from what the server expects, when the

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

9193reqFailure (RequestFailure _ s) = Just s

9294reqFailure _ = Nothing

9395

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+

94103

95104------------------------------------------------------------------------------

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

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

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

224233 , _xhrRequestConfig_user = Nothing

225234 , _xhrRequestConfig_password = Nothing

226− , _xhrRequestConfig_responseType = Nothing

235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

227236 , _xhrRequestConfig_withCredentials = False

228237 , _xhrRequestConfig_responseHeaders = def

229238 }

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

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

236245 , _xhrRequestConfig_user = Nothing

237246 , _xhrRequestConfig_password = Nothing

238− , _xhrRequestConfig_responseType = Nothing

239− , _xhrRequestConfig_sendData = ""

247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

248+ , _xhrRequestConfig_sendData = mempty

240249 , _xhrRequestConfig_withCredentials = False

241250 }

242251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

@@ -307,7 +316,7 @@ performSomeRequestsAsync opts =

307316-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync

308317-- that accepts 'f (Either e (XhrRequestb))' events

309318performSomeRequestsAsync'

310− :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)

319+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)

311320 => ClientOptions

312321 -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)

313322 -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))

@@ -319,7 +328,7 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs

319328 return resp

320329 Right r' -> do

321330 resp <- liftIO newEmptyMVar

322− r'' <- liftIO $ (optsRequestFixup opts) r'

331+ r'' <- liftJSM $ (optsRequestFixup opts) r'

323332 _ <- newXhr r'' $ liftIO . putMVar resp . Right

324333 return resp

325334 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar

@@ -327,9 +336,9 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs

327336

328337

329338

330−type XhrPayload = T.Text

339+type XhrPayload = ByteString

331340bytesToPayload :: BL.ByteString -> XhrPayload

332−bytesToPayload = TE.decodeUtf8 . BL.toStrict

341+bytesToPayload = BL.toStrict

333342

334343

335344performRequestsCT

@@ -344,15 +353,15 @@ performRequestsCT

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

345354performRequestsCT ct reqMeth reqs reqHost opts trigger = do

346355 resps <- performRequests reqMeth reqs reqHost opts trigger

347− let decodeResp x = first T.pack .

348− mimeUnrender ct .

349− BL.fromStrict .

350− TE.encodeUtf8 =<< note "No body text"

351− (_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"

352361 return $ fmap

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

354363 Left e -> RequestFailure t e

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

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

356365 )

357366 resps

358367

@@ -380,7 +389,8 @@ evalResponse

380389 -> (tag, XhrResponse)

381390 -> ReqResult tag a

382391evalResponse decode (tag, xhr) =

383− let okStatus = _xhrResponse_status xhr < 400

392+ let status = _xhrResponse_status xhr

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

384394 errMsg = fromMaybe

385395 ("Empty response with error code " <>

386396 T.pack (show $ _xhrResponse_status xhr))

@@ -393,6 +403,18 @@ evalResponse decode (tag, xhr) =

393403 else ResponseFailure tag errMsg xhr

394404 in respPayld

395405

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

411+

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'

417+

396418

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

398420note e = maybe (Left e) Right

@@ -406,3 +428,4 @@ builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString

406428

407429escape :: T.Text -> T.Text

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

431+

src/Servant/Reflex.hs+123−71

@@ -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,34 +39,36 @@ 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(..), MimeUnrender,

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,

@@ -98,7 +103,7 @@ import Servant.Common.Req (ClientOptions(..),

98103-- >

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

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

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

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

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

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

104109client

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

120125 -> Client t m layout tag

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

122127

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+

123142

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

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

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

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

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

128147 type Client t m layout tag :: *

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

130167

131168

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

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

134171

135− clientWithRoute Proxy q pTag req baseurl opts =

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

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

138175

139176

140177-- Capture. Example:

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

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

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

157194

158− clientWithRoute Proxy q t req baseurl opts val =

159− clientWithRoute (Proxy :: Proxy sublayout)

160− q t

161− (prependToPathParts p req)

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

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

164199

165200

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

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

173208 -- TODO how to access input types here?

174209 -- ExceptT ServantError IO a

175− clientWithRoute Proxy _ _ req baseurl opts trigs =

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

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

178213 req' = req { reqMethod = method }

179214

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

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

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

188223 -- ExceptT ServantError IO NoContent

189− clientWithRoute Proxy _ _ req baseurl opts =

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

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

192227

193228

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

195230toHeaders r =

196− let toBS = E.encodeUtf8

197− hdrs = maybe []

198− (\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))

199233 (Map.toList $ _xhrResponse_headers xhr))

200234 (response r)

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

202236

237+

203238class BuildHeaderKeysTo hs where

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

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

205240

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

207242 where buildHeaderKeysTo _ = []

208243

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

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

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

212251

213252-- HEADERS Verb (Content) --

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

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

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

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

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

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

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

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

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

229− return $ toHeaders <$> resp

268+ wrap $ toHeaders <$> resp

230269 where req' = req { respHeaders =

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

232271 }

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

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

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

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

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

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

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

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

245− return $ toHeaders <$> resp

284+ wrap $ toHeaders <$> resp

246285 where req' = req {respHeaders =

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

248287 }

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

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

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

271310

272− clientWithRoute Proxy q t req baseurl opts eVal =

273− clientWithRoute (Proxy :: Proxy sublayout)

274− q t

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

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

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

278317

279318

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

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

288327 Client t m sublayout tag

289328

290− clientWithRoute Proxy q t =

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

292344

293345

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

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

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

325377

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

327− clientWithRoute Proxy q t req baseurl opts mparam =

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

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

330382

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

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

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

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

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

372424

373− clientWithRoute Proxy q t req baseurl opts paramlist =

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

375427

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

377429 pname = symbolVal (Proxy :: Proxy sym)

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

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

411463 Dynamic t Bool -> Client t m sublayout tag

412464

413− clientWithRoute Proxy q t req baseurl opts flag =

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

415467

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

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

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

425477 -> Event t tag

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

427479

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

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

429481

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

431483 Left e -> Left e

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

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

437489

438490 resps <- performRequestsAsync okReq

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

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

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

441493 ]

442494

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

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

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

469521

470− clientWithRoute Proxy q t req baseurl opts body =

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

472524 where req' = req { reqBody = bodyBytesCT }

473525 ctProxy = Proxy :: Proxy ct

474526 ctString = T.pack $ show $ contentType ctProxy

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

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

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

484536

485− clientWithRoute Proxy q t req baseurl opts =

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

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

488540

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

490542

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

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

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

494546

495− clientWithRoute Proxy q t req baseurl =

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

547+ clientWithRouteAndResultHandler Proxy =

548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

497549

498550

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

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

501553

502− clientWithRoute Proxy q t req baseurl =

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

554+ clientWithRouteAndResultHandler Proxy =

555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

504556

505557

506558

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

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

509561

510− clientWithRoute Proxy q t req baseurl =

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

562+ clientWithRouteAndResultHandler Proxy =

563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

512564

513565

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

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

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

518570 -> Client t m api tag

519571

520− clientWithRoute Proxy q t req baseurl opts authdata =

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

522574 where

523575 req' = req { authData = Just authdata }

524576

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

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

562614

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

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

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

565617

566618

567619type family HasCookieAuth xs :: Constraint where

src/Servant/Reflex/Multi.hs+35−22

@@ -37,28 +37,30 @@ 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− MimeUnrender, 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)

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

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

241243

242244

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+

243256------------------------------------------------------------------------------

244257instance (KnownSymbol sym,

245258 ToHttpApiData a,

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 #-}

4+

5+module API where

6+

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 #-}

88

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)

5+

6+ jsCompiler ? "ghcjs"

7+ # ^ Choose a GHCJS for compiling the frontend

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

9+

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