master..ee82402 · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

on ee82402 help sign in

32 files changed+314−556

since splitsnapshots

unifiedsplit

.gitignore−2

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

77*.stats

88out

99/.stack-work/

10−TAGS

11−dist-newstyle

.gitmodules+12

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

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+56−12

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

1−language: nix

2−nix: 2.3.6

3−sudo: require

1+sudo: required

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

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+

421

522before_install:

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

23+ - unset CC

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

25+ - git submodule update --init --recursive

726

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"

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

1245

1346script:

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

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"

README.md+33−70

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

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

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.

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.

1410

1511

1612## Example

1713

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:

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:

2015

2116```haskell

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

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

2924 :<|> Raw

3025```

3126

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

33−an `XhrRequest`.

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

3428

3529```haskell

3630

@@ -43,16 +37,7 @@ an `XhrRequest`.

4337 (constDyn (BasePath "/"))

4438```

4539

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.

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.

5641

5742```haskell

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

@@ -77,13 +62,7 @@ parameter is a trigger event for the XHR request. The return value

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

7863```

7964

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:

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:

8766

8867```haskell

8968 -- ... continued ...

@@ -101,8 +80,7 @@ elimination functions to filter the result type you care about, like this:

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

10281```

10382

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:

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

10684

10785```haskell

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

@@ -125,53 +103,47 @@ trigger the API calls, and text elements to show the results:

125103 display =<< holdDyn Nothing outputDouble

126104```

127105

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.

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.

133107

134108

135109## Building the library and test server

136110

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.

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:

144115

145116```

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

117+git submodule update --init --recursive

118+./build.sh

147119```

148120

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

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:

150131

151132```

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

133+cd testserver

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

153135```

154136

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.

137+And simply browse to `localhost:8001`

158138

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

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

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

161140

162141

163142## Tagging requests

164143

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.

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.

169145

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:

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:

175147

176148```haskell

177149 ...

@@ -201,10 +173,7 @@ its request. Imagine we wanted to display not just the last "double" from

201173

202174## Simultaneous requests

203175

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:

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:

208177

209178```haskell

210179sayHi

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

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

216185```

217186

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.

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.

build.shnew file+3

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

1+#!/usr/bin/env bash

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

ChangeLog.md → changelog.mdrenamed+1−14

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

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−

1410.3.3

152-----

163

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

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

185

196

2070.3.2

default.nixdeleted−21

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

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-datanew file+1

Submodule changed.

deps/reflex-platformnew file+1

Submodule changed.

deps/servantnew file+1

Submodule changed.

deps/servant-snapnew file+1

Submodule changed.

exec/Example.hs+2−2

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

2121import API

2222import Data.Proxy

2323import Text.Read (readMaybe)

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

25−import Reflex.Dom (mainWidget)

24+import Reflex.Dom hiding (run)

2625------------------------------------------------------------------------------

2726import Servant.Reflex

2827import Servant.Reflex.Multi

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

9897

9998 -- Name the computed API client functions

10099 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.confdeleted−3

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

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

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

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

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

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

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

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.nixdeleted−9

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

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.nixnew file+11

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

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.nixnew file+9

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

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

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

11Name: servant-reflex

2−Version: 0.3.6

3−Synopsis: servant API generator for reflex apps

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

2+Version: 0.3.3

3+Synopsis: Servant reflex API generator

4+Description: Servant reflex API generator

55License: BSD3

66License-file: LICENSE.md

77Author: Greg Hale, Doug Beardsley

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

1717

1818library

1919 exposed-modules:

20− Servant.Common.BaseUrl

21− Servant.Common.Req

2220 Servant.Reflex

2321 Servant.Reflex.Multi

2422

23+ other-modules:

24+ Servant.Common.BaseUrl

25+ Servant.Common.Req

26+

2527 hs-source-dirs: src

2628 build-depends:

27− base >= 4.8 && < 5,

29+ base >= 4.8 && < 4.10,

2830 bytestring >= 0.10 && < 0.11,

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

30− containers >= 0.5.6 && < 0.7,

32+ containers >= 0.5.6 && < 0.6,

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

32− exceptions >= 0.8 && < 0.11,

34+ exceptions >= 0.8 && < 0.9,

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

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

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

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

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

3638 jsaddle >= 0.8 && < 0.10,

3739 mtl >= 2.2.1 && < 2.3,

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

39− reflex >= 0.5 && < 0.9,

40− reflex-dom-core >= 0.6 && < 0.8,

41+ reflex >= 0.5 && < 0.6,

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

4143 safe >= 0.3.9 && < 0.4,

42− servant >= 0.16 && < 0.19,

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

44+ servant >= 0.8 && < 0.12,

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

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

4547 text >= 1.2 && < 1.3,

4648 transformers >= 0.4 && < 0.6

4749

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

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

4951

5052 default-language: Haskell2010

5153

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

5456 buildable: True

5557 else

5658 buildable: False

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

59+ build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text

6760 default-language: Haskell2010

6861 main-is: Example.hs

6962 other-modules: API

shell.nixdeleted−1

@@ -1 +0,0 @@

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

src/Servant/Common/BaseUrl.hs+6−9

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

11{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE CPP #-}

32{-# LANGUAGE DeriveDataTypeable #-}

43{-# LANGUAGE DeriveGeneric #-}

54{-# LANGUAGE FlexibleContexts #-}

@@ -32,11 +31,8 @@ import Reflex

3231import Reflex.Dom.Core

3332import Text.Read

3433

35−#if !MIN_VERSION_reflex_dom_core(0,7,0)

34+

3635type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadJSM (Performable m))

37−#else

38−type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, MonadJSM (Performable m))

39−#endif

4036

4137-- | URI scheme to use

4238data Scheme =

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

8985 where pathWidget :: m (Dynamic t BaseUrl)

9086 pathWidget = do

9187 text "Url base path"

92− t <- inputElement def

88+ t <- textInput (def {_textInputConfig_attributes =

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

9390 return $ BasePath <$> value t

9491 fullUrlWidget :: m (Dynamic t BaseUrl)

9592 fullUrlWidget = do

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

97− srv <- inputElement def

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

9895 text ":"

99− prt <- inputElement def

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

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

101− path <- inputElement def

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

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

src/Servant/Common/Req.hs+16−40

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

1212

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

1414import Control.Applicative (liftA2, liftA3)

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

1615import Control.Concurrent

1716import Control.Monad (join)

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

1918import Data.Bifunctor (first)

2019import qualified Data.ByteString.Builder as Builder

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

22−import Data.ByteString (ByteString)

2321import qualified Data.Map as Map

2422import Data.Maybe (catMaybes, fromMaybe)

2523import Data.Functor.Compose

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

2927import qualified Data.Text as T

3028import qualified Data.Text.Encoding as TE

3129import Data.Traversable (forM)

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

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

3331import qualified Network.URI as N

3432import Reflex.Dom.Core hiding (tag)

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

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

5351 deriving (Functor)

5452

5553data ClientOptions = ClientOptions

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

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

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

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

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

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

9391reqFailure (RequestFailure _ s) = Just s

9492reqFailure _ = Nothing

9593

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−

10394

10495------------------------------------------------------------------------------

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

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

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

233224 , _xhrRequestConfig_user = Nothing

234225 , _xhrRequestConfig_password = Nothing

235− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

226+ , _xhrRequestConfig_responseType = Nothing

236227 , _xhrRequestConfig_withCredentials = False

237228 , _xhrRequestConfig_responseHeaders = def

238229 }

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

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

245236 , _xhrRequestConfig_user = Nothing

246237 , _xhrRequestConfig_password = Nothing

247− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

248− , _xhrRequestConfig_sendData = mempty

238+ , _xhrRequestConfig_responseType = Nothing

239+ , _xhrRequestConfig_sendData = ""

249240 , _xhrRequestConfig_withCredentials = False

250241 }

251242 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

@@ -298,9 +289,7 @@ performRequests reqMeth rs reqHost opts trigger = do

298289performSomeRequestsAsync

299290 :: (MonadIO (Performable m),

300291 MonadJSM (Performable m),

301−#if !MIN_VERSION_reflex_dom_core(0,7,0)

302292 HasWebView (Performable m),

303−#endif

304293 PerformEvent t m,

305294 TriggerEvent t m,

306295 Traversable f,

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

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

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

320309performSomeRequestsAsync'

321− :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)

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

322311 => ClientOptions

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

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

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

330319 return resp

331320 Right r' -> do

332321 resp <- liftIO newEmptyMVar

333− r'' <- liftJSM $ (optsRequestFixup opts) r'

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

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

335324 return resp

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

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

338327

339328

340329

341−type XhrPayload = ByteString

330+type XhrPayload = T.Text

342331bytesToPayload :: BL.ByteString -> XhrPayload

343−bytesToPayload = BL.toStrict

332+bytesToPayload = TE.decodeUtf8 . BL.toStrict

344333

345334

346335performRequestsCT

@@ -355,15 +344,15 @@ performRequestsCT

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

356345performRequestsCT ct reqMeth reqs reqHost opts trigger = do

357346 resps <- performRequests reqMeth reqs reqHost opts trigger

358− let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =

359− first T.pack .

360− mimeUnrender ct $

361− BL.fromStrict x

362− decodeResp _ = Left "No body"

347+ let decodeResp x = first T.pack .

348+ mimeUnrender ct .

349+ BL.fromStrict .

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

351+ (_xhrResponse_responseText x)

363352 return $ fmap

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

365354 Left e -> RequestFailure t e

366− Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)

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

367356 )

368357 resps

369358

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

391380 -> (tag, XhrResponse)

392381 -> ReqResult tag a

393382evalResponse decode (tag, xhr) =

394− let status = _xhrResponse_status xhr

395− okStatus = status >= 200 && status < 400

383+ let okStatus = _xhrResponse_status xhr < 400

396384 errMsg = fromMaybe

397385 ("Empty response with error code " <>

398386 T.pack (show $ _xhrResponse_status xhr))

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

405393 else ResponseFailure tag errMsg xhr

406394 in respPayld

407395

408−------------------------------------------------------------------------------

409−-- | Utility for simultaneously accessing/filtering Success and Failure

410−-- response 'Event's,

411−fanReqResult :: Reflex t => Event t (ReqResult tag a) -> (Event t Text, Event t a)

412−fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess

413−

414−------------------------------------------------------------------------------

415−-- | Utility for simultaneously accessing/filtering Success and Failure

416−-- response 'Event's, but keeping the request tag

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

418−fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'

419−

420396

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

422398note e = maybe (Left e) Right

src/Servant/Reflex.hs+75−126

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

88{-# LANGUAGE MultiParamTypeClasses #-}

99{-# LANGUAGE OverloadedStrings #-}

1010{-# LANGUAGE PolyKinds #-}

11−{-# LANGUAGE Rank2Types #-}

1211{-# LANGUAGE ScopedTypeVariables #-}

1312{-# LANGUAGE TupleSections #-}

1413{-# LANGUAGE TypeFamilies #-}

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

2625module Servant.Reflex

2726 ( client

2827 , clientWithOpts

29− , clientWithOptsAndResultHandler

3028 , clientWithRoute

31− , clientWithRouteAndResultHandler

3229 , BuildHeaderKeysTo(..)

3330 , toHeaders

3431 , HasClient

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

3936

4037------------------------------------------------------------------------------

4138import Control.Applicative

42−import qualified Data.CaseInsensitive as CI

43−import Data.Functor.Identity

44−import qualified Data.Map as Map

4539import Data.Monoid ((<>))

46−import Data.Proxy (Proxy (..))

4740import qualified Data.Set as Set

41+import qualified Data.Text.Encoding as E

42+import Data.CaseInsensitive (mk)

43+import Data.Functor.Identity

44+import Data.Proxy (Proxy (..))

45+import qualified Data.Map as Map

4846import Data.Text (Text)

4947import qualified Data.Text as T

50−import qualified Data.Text.Encoding as E

5148import GHC.Exts (Constraint)

5249import GHC.TypeLits (KnownSymbol, symbolVal)

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

54− BasicAuthData, BuildHeadersTo (..),

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

56− HttpVersion, IsSecure,

57− MimeRender (..), MimeUnrender,

58− NoContent, QueryFlag, QueryParam',

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

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

51+ BasicAuthData, BuildHeadersTo(..),

52+ Capture, contentType, Header,

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

54+ MimeRender(..), MimeUnrender,

55+ NoContent, QueryFlag, QueryParam,

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

6057 RemoteHost, ReqBody,

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

62− contentType)

63−import Servant.API.Description (Summary)

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

6459import qualified Servant.Auth as Auth

6560

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

67− XhrRequest (..), XhrResponse (..),

68− XhrResponseHeaders (..),

69− attachPromptlyDynWith, constDyn, ffor,

70− fmapMaybe, leftmost,

71− performRequestsAsync)

62+ XhrRequest(..),

63+ XhrResponseHeaders(..),

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

65+ leftmost, performRequestsAsync,

66+ )

7267------------------------------------------------------------------------------

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

7469 showBaseUrl,

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

10398-- >

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

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

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

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

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

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

109104client

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

125120 -> Client t m layout tag

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

127122

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−

142123

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

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

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

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

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

147128 type 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

129+ clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag

167130

168131

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

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

171134

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

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

175138

176139

177140-- Capture. Example:

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

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

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

194157

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

196− clientWithRouteAndResultHandler

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

158+ clientWithRoute Proxy q t req baseurl opts val =

159+ clientWithRoute (Proxy :: Proxy sublayout)

160+ q t

161+ (prependToPathParts p req)

162+ baseurl opts

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

199164

200165

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

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

208173 -- TODO how to access input types here?

209174 -- ExceptT ServantError IO a

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

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

175+ clientWithRoute Proxy _ _ req baseurl opts trigs =

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

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

213178 req' = req { reqMethod = method }

214179

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

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

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

223188 -- ExceptT ServantError IO NoContent

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

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

189+ clientWithRoute Proxy _ _ req baseurl opts =

190+ (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl opts

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

227192

228193

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

230195toHeaders r =

231− let hdrs = maybe []

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

196+ let toBS = E.encodeUtf8

197+ hdrs = maybe []

198+ (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))

233199 (Map.toList $ _xhrResponse_headers xhr))

234200 (response r)

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

236202

237−

238203class BuildHeaderKeysTo hs where

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

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

240205

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

242207 where buildHeaderKeysTo _ = []

243208

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

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

246− buildHeaderKeysTo _ =

247− let

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

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

250−

211+ buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)

251212

252213-- HEADERS Verb (Content) --

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

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

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

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

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

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

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

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

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

268− wrap $ toHeaders <$> resp

229+ return $ toHeaders <$> resp

269230 where req' = req { respHeaders =

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

271232 }

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

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

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

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

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

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

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

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

284− wrap $ toHeaders <$> resp

245+ return $ toHeaders <$> resp

285246 where req' = req {respHeaders =

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

287248 }

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

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

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

310271

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

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

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

317278

318279

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

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

327288 Client t m sublayout tag

328289

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−

290+ clientWithRoute Proxy q t =

291+ clientWithRoute (Proxy :: Proxy sublayout) q t

344292

345293

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

@@ -370,15 +318,15 @@ instance (HasClient t m sublayout tag, KnownSymbol sym)

370318-- > -- 'getBooksBy Nothing' for all books

371319-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov

372320instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)

373− => HasClient t m (QueryParam' mods sym a :> sublayout) tag where

321+ => HasClient t m (QueryParam sym a :> sublayout) tag where

374322

375− type Client t m (QueryParam' mods sym a :> sublayout) tag =

323+ type Client t m (QueryParam sym a :> sublayout) tag =

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

377325

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

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

327+ clientWithRoute Proxy q t req baseurl opts mparam =

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

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

382330

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

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

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

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

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

424372

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

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

373+ clientWithRoute Proxy q t req baseurl opts paramlist =

374+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts

427375

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

429377 pname = symbolVal (Proxy :: Proxy sym)

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

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

463411 Dynamic t Bool -> Client t m sublayout tag

464412

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

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

413+ clientWithRoute Proxy q t req baseurl opts flag =

414+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts

467415

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

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

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

477425 -> Event t tag

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

479427

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

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

481429

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

483431 Left e -> Left e

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

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

489437

490438 resps <- performRequestsAsync okReq

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

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

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

493441 ]

494442

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

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

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

521469

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

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

470+ clientWithRoute Proxy q t req baseurl opts body =

471+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts

524472 where req' = req { reqBody = bodyBytesCT }

525473 ctProxy = Proxy :: Proxy ct

526474 ctString = T.pack $ show $ contentType ctProxy

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

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

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

536484

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

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

540488

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

542490

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

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

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

546494

547− clientWithRouteAndResultHandler Proxy =

548− clientWithRouteAndResultHandler (Proxy :: Proxy api)

495+ clientWithRoute Proxy q t req baseurl =

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

549497

550498

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

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

553501

554− clientWithRouteAndResultHandler Proxy =

555− clientWithRouteAndResultHandler (Proxy :: Proxy api)

502+ clientWithRoute Proxy q t req baseurl =

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

556504

557505

558506

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

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

561509

562− clientWithRouteAndResultHandler Proxy =

563− clientWithRouteAndResultHandler (Proxy :: Proxy api)

510+ clientWithRoute Proxy q t req baseurl =

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

564512

565513

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

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

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

570518 -> Client t m api tag

571519

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

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

520+ clientWithRoute Proxy q t req baseurl opts authdata =

521+ clientWithRoute (Proxy :: Proxy api) q t req' baseurl opts

574522 where

575523 req' = req { authData = Just authdata }

576524

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

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

614562

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

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

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

617565

618566

619567type family HasCookieAuth xs :: Constraint where

@@ -622,3 +570,4 @@ type family HasCookieAuth xs :: Constraint where

622570 HasCookieAuth '[] = CookieAuthNotEnabled

623571

624572class CookieAuthNotEnabled

573+

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

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

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)

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)

6462------------------------------------------------------------------------------

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

6664 SupportsServantReflex)

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

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

243241

244242

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−

256243------------------------------------------------------------------------------

257244instance (KnownSymbol sym,

258245 ToHttpApiData a,

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

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

99import Data.Foldable

1010import Test.WebDriver.Commands.Wait

1111import Test.Hspec.WebDriver

12−import Test.Hspec.WebDriver (chromeCaps)

1312

1413

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

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

2928spec = do

3029 describe "servant-reflex tests" $ do

3130

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

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

3332

3433 it "opens the page" $ runWD $

3534 openPage "http://localhost:8000"

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

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

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

@@ -0,0 +1 @@

1+../exec/API.hs

testserver/Main.hs+3−10

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

77{-# LANGUAGE TypeOperators #-}

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

10−import Control.Monad.Reader (reader)

1110import Data.Aeson

1211import Data.Bool

1312import Data.Char (toUpper)

1413import qualified Data.List as L

15−import Data.Maybe (fromMaybe)

1614import Data.Monoid

1715import Data.Proxy

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

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

2725import Servant

2826import Servant.Server

2927-- import Snap.Util.FileServe

30−import System.Environment (lookupEnv)

3128import API

3229import Snap

3330

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

4340testApi :: Proxy API

4441testApi = Proxy

4542

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

43+data App = App

4744

4845-- Server-side handlers.

4946--

@@ -54,7 +51,7 @@ data App = App { appStaticDir :: String }

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

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

5653 :<|> multi :<|> qna :<|> serveSecret

57− :<|> statics

54+ :<|> serveDirectory "static"

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

5956 sayhi nm greetings withGusto = case nm of

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

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

7976 req <- getRequest

8077 liftIO $ putStrLn (show req)

8178 return 101

82− statics = do

83− staticDir <- reader appStaticDir

84− serveDirectory staticDir

8579

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

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

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

9185

9286initApp :: SnapletInit App App

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

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

9588 addRoutes [("", test)

9689 ,("", serveDirectory "static")

9790 ]

98− return (App staticDir)

91+ return App

9992

10093-- Put this all to work!

10194main :: IO ()

testserver/run-wd-tests.shnew file+5

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

1+#!/usr/bin/env bash

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

4+phantomjs --webdriver=127.0.0.1:4444 &

5+dist/build/spec/spec

testserver/testserver.cabal+4−5

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

1919 main-is: Main.hs

2020 -- other-modules:

2121 -- other-extensions:

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

23− , base >=4.8 && < 5

24− , mtl

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

23+ , base >=4.8 && <4.11

2524 , snap >= 1.0 && < 1.2

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

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

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

28− , servant >= 0.16 && < 0.18

27+ , servant >= 0.8 && < 0.12

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

3029 , text >= 1.0 && < 1.3

3130 -- hs-source-dirs:

testserver/tr.nixnew file+32

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

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

2+let

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.nixdeleted−70

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

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