master..fa2a523 · servant-reflex

git.iko.soy/servant-reflex

37 files changed+1156−463

unifiedsplit

.gitignore−2 .travis.yml+24−11 README.md+33−70 build.sh+3 ChangeLog.md → changelog.md+1−14 default.nix+24−11 exec/API.hs+4−1 exec/Example.hs+158−18 nix.conf+3 nix/nix.conf−3 nix/reflex-platform.nix+9−7 nix/servant-reflex.nix+24 nix/servant-snap.nix−7 nix/testdriver.nix+3 nix/testresults.nix+9−4 nix/testserver.nix+24−8 overrides-ghc.nix+11 overrides.nix+9 release.nix+27 servant-reflex.cabal+24−24 shell.nix+3−1 src/Servant/Common/BaseUrl.hs+5−4 src/Servant/Common/Req.hs+3−25 src/Servant/Reflex.hs+71−123 src/Servant/Reflex/Multi.hs+22−35 src/Servant/Reflex/RequestAPI.hs+567 testdriver/default.nix+16 testdriver/shell.nix+1 testdriver/test/Servant/ReflexSpec.hs−1 testserver/API.hs+4−1 testserver/Main.hs+17−18 testserver/default.nix+14 testserver/run-wd-tests.sh+5 testserver/shell.nix+1 testserver/testserver.cabal+5−5 testserver/tr.nix+32 travis.nix−70

.gitignore−2

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

77*.stats

88out

99/.stack-work/

10−TAGS

11−dist-newstyle

.travis.yml+24−11

@@ -1,17 +1,30 @@

11language: nix

2−nix: 2.3.6

3−sudo: require

3+cache: false

56before_install:

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

7+ - unset CC

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"

9+install:

1210

1311script:

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

12+ - git clone https://github.com/reflex-frp/reflex-platform

13+ - cd reflex-platform && sudo echo "Yes" | ./try-reflex --command "exit 0"

14+ - strace nix build -f ../release.nix servant-reflex

15+

16+ - nix build -f ./release.nix servant-reflex --substituters https://cache.nixos.org --substituters https://nixcache.reflex-frp.org

17+ - nix build -f ./release.nix testresults

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

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

20+

21+cache:

22+ directories:

23+ - /nix

24+ - $HOME/.cabal/packages

25+ - $HOME/.cabal/store

26+

27+env:

28+ global:

29+ - ENCRYPTION_LABEL: "3c89d919c82e"

30+ - 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.nix+24−11

@@ -1,21 +1,34 @@

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

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

2+, containers, data-default, exceptions, generic-lens, ghcjs-dom, http-api-data

3+, http-media, jsaddle, mtl, network-uri, reflex, reflex-dom

4+, reflex-dom-core, safe, scientific, servant, servant-auth, stdenv

5+, string-conversions, text, transformers

66}:

77mkDerivation {

88 pname = "servant-reflex";

9− version = "0.3.6";

10− src = ./.;

9+ version = "0.3.3";

10+ # src = ./.;

11+ src = builtins.filterSource

12+ (path: type:

13+ baseNameOf path != "result"

14+ && baseNameOf path != "nix"

15+ # baseNameOf (toString path) == "src" ||

16+ # baseNameOf (toString path) == "exec" ||

17+ # baseNameOf (toString path) == "servant-reflex.cabal"

18+

19+ ) ./.;

20+ configureFlags = [ "-fexample" ];

1121 isLibrary = true;

1222 isExecutable = true;

1323 libraryHaskellDepends = [

1424 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

25+ generic-lens ghcjs-dom http-api-data http-media jsaddle mtl network-uri reflex

26+ reflex-dom-core safe servant servant-auth string-conversions text

27+ transformers

1828 ];

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

29+ executableHaskellDepends = [

30+ aeson base reflex reflex-dom scientific servant text

31+ ];

32+ description = "Servant reflex API generator";

2033 license = stdenv.lib.licenses.bsd3;

2134}

exec/API.hs+4−1

@@ -31,6 +31,7 @@ instance FromJSON Answer where

3131-- | API spec for server, client, and docs

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

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

34+ :<|> "dblint" :> Capture "anint" Int :> Get '[JSON] Int

3435 :<|> "sayhi" :> QueryParam "username" Text

3536 :> QueryParams "greetings" Text

3637 :> QueryFlag "gusto"

@@ -39,7 +40,9 @@ type API = "getunit" :> Get '[JSON] ()

3940 :> Post '[JSON] Double

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

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

42− :> Post '[JSON] Answer

43+ :> Header "qnum" Int

44+ :> Header "is-favorite" Bool

45+ :> Post '[JSON] (Headers '[Header "anum" Int, Header "was-favorite" Bool] Answer)

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

4447 :<|> Raw

4548

exec/Example.hs+158−18

@@ -5,6 +5,8 @@

55{-# LANGUAGE RankNTypes #-}

66{-# LANGUAGE RecursiveDo #-}

77{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeApplications #-}

9+{-# LANGUAGE TypeOperators #-}

810

911module Main where

1012

@@ -21,21 +23,157 @@ import Servant.API

2123import API

2224import Data.Proxy

2325import Text.Read (readMaybe)

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

25−import Reflex.Dom (mainWidget)

26+import Reflex.Dom hiding (run)

2627------------------------------------------------------------------------------

2728import Servant.Reflex

2829import Servant.Reflex.Multi

30+import qualified Servant.Reflex.RequestAPI as SR

2931

3032

3133api :: Proxy API

3234api = Proxy

3335

36+type MyAPI =

37+ "getunit" :> Get '[JSON] ()

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

39+ :<|> "dblint" :> Capture "anint" Int :> Get '[JSON] Int

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

41+ :> QueryParams "greetings" Text

42+ :> QueryFlag "gusto"

43+ :> Get '[JSON] Text

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

45+ :> Post '[JSON] Double

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

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

48+ :> Header "qnum" Int

49+ :> Header "is-favorite" Bool

50+ :> Post '[JSON] (Headers '[Header "anum" Int, Header "was-favorite" Bool] Answer)

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

52+

3453main :: IO ()

3554main = mainWidget $ do

55+ divClass "example-tuple" runTuple

3656 divClass "example-base" run

3757 divClass "example-multi" runMulti

3858

59+hiWidget :: (SupportsServantReflex t m,

60+ DomBuilder t m,

61+ DomBuilderSpace m ~ GhcjsDomSpace,

62+ PostBuild t m) => m (Dynamic t (Maybe Text),

63+ Dynamic t [Text],

64+ Dynamic t Bool,

65+ Event t ())

66+hiWidget = do

67+ text "Name"

68+ el "br" $ return ()

69+ inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ (textInput def)

70+ let checkedName = fmap (\i -> bool (Just i) Nothing (T.null i)) inp

71+ el "br" $ return ()

72+

73+ text "Greetings (space-separated)"

74+ el "br" $ return ()

75+ greetings <- fmap (fmap T.words . value) $

76+ divClass "greetings-input" $ (textInput def)

77+

78+ el "br" $ return ()

79+

80+ gusto <- fmap value $ divClass "gusto-input" $ checkbox False def

81+

82+ el "br" $ return ()

83+ sayHiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"

84+ return (checkedName, greetings, gusto, sayHiClicks)

85+

86+

87+readWidget :: (SupportsServantReflex t m,

88+ DomBuilder t m,

89+ DomBuilderSpace m ~ GhcjsDomSpace,

90+ PostBuild t m,

91+ Read a

92+ ) => m (Dynamic t (Maybe a))

93+readWidget = fmap (readMaybe . T.unpack) . value <$> textInput def

94+

95+readWidget' :: (SupportsServantReflex t m,

96+ DomBuilder t m,

97+ DomBuilderSpace m ~ GhcjsDomSpace,

98+ PostBuild t m,

99+ Read a

100+ ) => a -> m (Dynamic t a)

101+readWidget' d = fmap (fromMaybe d . readMaybe . T.unpack) . value <$> textInput def

102+

103+basicAuthWidget :: (SupportsServantReflex t m,

104+ DomBuilder t m,

105+ DomBuilderSpace m ~ GhcjsDomSpace,

106+ PostBuild t m

107+ ) => m (Dynamic t BasicAuthData)

108+basicAuthWidget = do

109+ un <- fmap value $ text "Username" >> textArea def

110+ pw <- fmap value $ text "Unhidden PW" >> textArea def

111+ return $ BasicAuthData <$> fmap T.encodeUtf8 un <*> fmap T.encodeUtf8 pw

112+

113+

114+runTuple :: forall t m. (SupportsServantReflex t m,

115+ DomBuilder t m,

116+ DomBuilderSpace m ~ GhcjsDomSpace,

117+ MonadFix m,

118+ PostBuild t m,

119+ MonadHold t m) => m ()

120+runTuple = do

121+ el "h1" (text "Tuple API")

122+ url <- baseUrlWidget

123+

125+ SR.clientR (Proxy @API) (Proxy @m) (Proxy @t) (Proxy @[]) url

126+

127+ u <- divClass "demo-group" $ do

128+ unitBtn <- button "get unit"

129+ getUnit (fmap (:[]) unitBtn)

130+

131+ (giR, diR) <- divClass "demo-group" $ do

132+ int <- readWidget

133+ getIntBtn <- button "get int"

134+ dblIntBtn <- button "double int"

135+ gi <- getInt (fmap (:[]) getIntBtn)

136+ di <- dblInt (fmap (:[]) (fmapMaybe id $ tagPromptlyDyn int dblIntBtn))

137+ return (gi, di)

138+

139+ hiResp <- divClass "demo-group" $ do

140+ (nm, greets, gusto, hiClicks) <- hiWidget

141+ let hiReqs = tagPromptlyDyn ((,,) <$> nm <*> greets <*> gusto) hiClicks

142+ sayHi (fmap (:[]) hiReqs)

143+

144+ dblResp <- divClass "demo-group" $ do

145+ dblInput <- readWidget

146+ dblBtn <- button "double double"

147+ dbl $ (fmap (:[])) $ fmapMaybe id $ tagPromptlyDyn dblInput dblBtn

148+

149+ twoPathResp <- divClass "demo-group" $ do

150+ twoPathInp <- text "Two Path" >> checkbox False def

151+ ab (fmap (:[]) $ updated (value twoPathInp))

152+

153+ qnaR <- divClass "demo-group" $ do

154+ q <- fmap Question . value <$> textInput def

155+ i <- readWidget' 0

156+ f <- readWidget' False

157+ question (fmap (:[]) (updated $ (,,) <$> q <*> i <*> f))

158+

159+ secretR <- divClass "demo-group" $ do

160+ ba <- basicAuthWidget

161+ sBtn <- button "Get secret"

162+ secret (fmap pure $ tagPromptlyDyn ba sBtn)

163+

164+ divClass "demo-group" $ do

165+ el "div" $ text "responses"

166+ dynText =<< holdDyn "No responses yet"

167+ (leftmost [ tshow <$> u , tshow <$> giR

168+ , tshow <$> diR

169+ , tshow <$> hiResp , tshow <$> dblResp

170+ , tshow <$> twoPathResp

171+ , T.concat . fmap (either tshow (\x -> tshow (tshow (getHeaders x), tshow (getResponse x)))) <$> qnaR

172+ , tshow <$> secretR

173+ ])

174+

175+ return ()

176+

39177

40178runMulti :: forall t m. (SupportsServantReflex t m,

41179 DomBuilder t m,

@@ -46,7 +184,7 @@ runMulti :: forall t m. (SupportsServantReflex t m,

46184runMulti = do

47185 url <- baseUrlWidget

48186 el "br" blank

49− let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =

187+ let (_ :<|> _ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =

50188 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url

51189

52190 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def

@@ -98,8 +236,9 @@ run = mdo

98236

99237 -- Name the computed API client functions

100238 let tweakRequest = ClientOptions $ \r -> do

239+ -- putStrLn ("Got req: " ++ show r)

101240 return $ r & withCredentials .~ True

102− let (getUnit :<|> getInt :<|> sayhi :<|> dbl

241+ let (getUnit :<|> getInt :<|> dblInt :<|> sayhi :<|> dbl

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

104243 clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest

105244

@@ -159,7 +298,7 @@ run = mdo

159298 holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))

160299 el "br" (return ())

161300 divClass "double-result" $ el "p" $ dynText =<<

162− holdDyn "No number yet" (fmap tShow $

301+ holdDyn "No number yet" (fmap tshow $

163302 fmapMaybe reqSuccess (dblResp))

164303 return dblBtn

165304

@@ -168,7 +307,7 @@ run = mdo

168307 b <- value <$> checkbox False def

169308 mpGo <- button "Test"

170309 multiResp <- multi b (tag (current reqCount) mpGo)

171− dynText =<< holdDyn "No res yet" (fmap tShow $

310+ dynText =<< holdDyn "No res yet" (fmap tshow $

172311 fmapMaybe reqSuccess $

173312 (multiResp))

174313 return mpGo

@@ -182,14 +321,15 @@ run = mdo

182321 txt <- value <$> textInput def

183322 ev <- fmap (1 <$) $ button "Question"

184323 let dQ = Right . Question <$> traceDyn "will send: " txt

185− rr <- qna dQ ev

324+ -- rr <- qna dQ ev _ _

186325 el "p" $

187− dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)

326+ return ()

327+ -- dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)

188328

189329 divClass "demo-group" $ do

190330 un <- fmap value $ text "Username" >> textArea def

191331 pw <- fmap value $ text "Unhidden PW" >> textArea def

192− let ba :: Dynamic t (BasicAuthData ) = BasicAuthData

332+ let ba :: Dynamic t BasicAuthData = BasicAuthData

193333 <$> fmap T.encodeUtf8 un

194334 <*> fmap T.encodeUtf8 pw

195335 b <- button "Get secret"

@@ -200,20 +340,20 @@ run = mdo

200340

201341showXhrResponse :: XhrResponse -> Text

202342showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

203− T.unlines ["stat: " <> tShow stat

204− ,"stattxt: " <> tShow stattxt

343+ T.unlines ["stat: " <> tshow stat

344+ ,"stattxt: " <> tshow stattxt

205345 ,"resp: " <> maybe "" showRB rbmay

206− ,"rtext: " <> tShow rtmay

207− ,"rHeaders: " <> tShow respHeaders]

346+ ,"rtext: " <> tshow rtmay

347+ ,"rHeaders: " <> tshow respHeaders]

208348

209−tShow :: Show a => a -> Text

210−tShow = T.pack . show

349+tshow :: Show a => a -> Text

350+tshow = T.pack . show

211351

212352showRB :: XhrResponseBody -> Text

213−showRB (XhrResponseBody_Default t) = tShow t

214−showRB (XhrResponseBody_Text t) = tShow t

353+showRB (XhrResponseBody_Default t) = tshow t

354+showRB (XhrResponseBody_Text t) = tshow t

215355showRB (XhrResponseBody_Blob t) = "<Blob>"

216−showRB (XhrResponseBody_ArrayBuffer t) = tShow t

356+showRB (XhrResponseBody_ArrayBuffer t) = tshow t

217357

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

219359note e = maybe (Left e) Right

nix.confnew file+3

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

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

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

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

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.nix+9−7

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

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

1+{ fetchFromGitHub }:

4+import (fetchFromGitHub {

5+ owner = "reflex-frp";

6+ repo = "reflex-platform";

7+ rev = "04aa7c00d79a2fac81f5b302b919e1b630c20e7f";

8+ sha256 = "1ckz07a839h3f8k94x2ybi9c89hqbkwnn1zxjxb0bfim8f2wqar7";

9+ }) { }

nix/servant-reflex.nixnew file+24

@@ -0,0 +1,24 @@

1+{ pkgs ? import <nixpkgs> {}, reflexPlatform, compiler ? "ghcjs" }:

3+let

5+ generic-lens-src = pkgs.fetchFromGitHub {

6+ owner = "kcsongor";

7+ repo = "generic-lens";

8+ rev = "6787a4e85d09ad9fcfe5baae53fea2cccbae5976";

9+ sha256 = "1bvjwxm4ik2zcx9s57ibi376y255vm5mawx12s1sjcn09mv1vvdh";

10+ };

11+

12+ ghcjsPackages = reflexPlatform.${compiler}.override {

13+ overrides = self: super: {

14+ servant = super.servant;

15+ generic-lens = pkgs.haskell.lib.dontCheck (self.callCabal2nix "generic-lens" generic-lens-src {

16+ inspection-testing = null;

17+ });

18+ wai = super.wai;

19+ servant-reflex = pkgs.haskell.lib.appendConfigureFlag

20+ (self.callPackage ../. {}) "-fExample";

21+ };

22+ };

23+

24+in ghcjsPackages.servant-reflex

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/testdriver.nixnew file+3

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

1+{ reflexPlatform }:

3+reflexPlatform.ghc.callPackage ../testdriver/default.nix {}

nix/testresults.nix+9−4

@@ -4,14 +4,19 @@ reflexPlatform.nixpkgs.pkgs.runCommand "runWebdriveTest.sh" {} ''

44 echo About to phantom

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

66 sleep 3

7− echo About to Server

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

8+ echo About to server

9+ cd ${testserver} && ./back -q --no-access-log --no-error-log &

910 sleep 3

11+

1012 ${curl}/bin/curl localhost:8000

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

14+

1215 echo About to testdrive

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

16+ ${testdriver}/bin/spec

1417 echo Done

18+ mkdir $out

19+ echo Done > $out/out.txt

1520 trap "exit" INT TERM

1621 trap "kill 0" EXIT

17− ''

22+ ''

nix/testserver.nix+24−8

@@ -1,9 +1,25 @@

1−servant-reflex: self: super:

1+{ servant-reflex, reflexPlatform }:

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

3+let

4+ ghcPackages = reflexPlatform.ghc.override {

5+ overrides = self: super: {

6+ snap = reflexPlatform.lib.doJailbreak (self.callCabal2nix "snap" ../../snap {});

7+ hspec-snap = reflexPlatform.lib.doJailbreak (super.hspec-snap);

8+ servant-snap = reflexPlatform.lib.doJailbreak (super.servant-snap);

9+ skylighting = reflexPlatform.lib.dontCheck super.skylighting;

10+ testserver = (self.callPackage ../testserver/default.nix {}).overrideDerivation (old:

11+ { postInstall = ''

12+ echo "SOURCE IS: $src"

13+ echo "ls IS: $ls"

14+ echo "EXAMPLE IS: ${servant-reflex}"

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

16+ mkdir $out/static

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

18+ '';

19+ }

20+ );

21+ heist = reflexPlatform.lib.doJailbreak super.heist;

22+ };

23+ };

24+

25+in ghcPackages.testserver

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

release.nixnew file+27

@@ -0,0 +1,27 @@

1+{ pkgs ? import <nixpkgs> {}, compiler ? "ghcjs" }:

3+let

4+ reflexPlatform =

5+ import ./nix/reflex-platform.nix {

6+ fetchFromGitHub = pkgs.fetchFromGitHub;

7+ };

9+in rec {

10+

11+ servant-reflex = import ./nix/servant-reflex.nix {

12+ reflexPlatform = reflexPlatform;

13+ compiler = compiler;

14+ };

15+ testserver = import ./nix/testserver.nix

16+ { reflexPlatform = reflexPlatform;

17+ servant-reflex = servant-reflex ;

18+ };

19+ testdriver = import ./nix/testdriver.nix

20+ { reflexPlatform = reflexPlatform;

21+ };

22+ testresults = import ./nix/testresults.nix

23+ { inherit reflexPlatform testserver testdriver;

24+ inherit (pkgs) curl;

25+ phantomjs = pkgs.phantomjs2;

26+ };

27+ }

servant-reflex.cabal+24−24

@@ -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,44 @@ Flag Example

1717

1818library

1919 exposed-modules:

20− Servant.Common.BaseUrl

21− Servant.Common.Req

2220 Servant.Reflex

2321 Servant.Reflex.Multi

22+ Servant.Reflex.RequestAPI

23+ Servant.Reflex.RequestAPI2

24+

25+ other-modules:

26+ Servant.Common.BaseUrl

27+ Servant.Common.Req

2428

2529 hs-source-dirs: src

2630 build-depends:

27− base >= 4.8 && < 5,

31+ base >= 4.8 && < 4.10,

2832 bytestring >= 0.10 && < 0.11,

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

30− containers >= 0.5.6 && < 0.7,

34+ containers >= 0.5.6 && < 0.6,

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

32− exceptions >= 0.8 && < 0.11,

36+ exceptions >= 0.8 && < 0.9,

37+ generic-lens,

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

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

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

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

40+ http-media >= 0.6 && < 0.8,

3641 jsaddle >= 0.8 && < 0.10,

42+ lens,

3743 mtl >= 2.2.1 && < 2.3,

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

39− reflex >= 0.5 && < 0.9,

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

45+ reflex >= 0.5 && < 0.6,

46+ -- Temporary

47+ reflex-dom,

48+

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

4150 safe >= 0.3.9 && < 0.4,

42− servant >= 0.16 && < 0.18,

51+ servant >= 0.8 && < 0.13,

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

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

4554 text >= 1.2 && < 1.3,

4655 transformers >= 0.4 && < 0.6

4756

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

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

4958

5059 default-language: Haskell2010

5160

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

5463 buildable: True

5564 else

5665 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

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

6767 default-language: Haskell2010

6868 main-is: Example.hs

6969 other-modules: API

shell.nix+3−1

@@ -1 +1,3 @@

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

1+{ compiler ? "ghcjs" }:

3+(import ./release.nix { inherit compiler; }).servant-reflex.env

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

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

8585 where pathWidget :: m (Dynamic t BaseUrl)

8686 pathWidget = do

8787 text "Url base path"

88− t <- inputElement def

88+ t <- textInput (def {_textInputConfig_attributes =

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

8990 return $ BasePath <$> value t

9091 fullUrlWidget :: m (Dynamic t BaseUrl)

9192 fullUrlWidget = do

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

93− srv <- inputElement def

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

9495 text ":"

95− prt <- inputElement def

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

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

97− path <- inputElement def

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

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

src/Servant/Common/Req.hs+3−25

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

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

@@ -245,7 +236,7 @@ reqToReflexRequest reqMeth reqHost req =

245236 , _xhrRequestConfig_user = Nothing

246237 , _xhrRequestConfig_password = Nothing

247238 , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

248− , _xhrRequestConfig_sendData = mempty

239+ , _xhrRequestConfig_sendData = ""

249240 , _xhrRequestConfig_withCredentials = False

250241 }

251242 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

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

336327

337328

338329

339−type XhrPayload = ByteString

330+type XhrPayload = T.Text

340331bytesToPayload :: BL.ByteString -> XhrPayload

341−bytesToPayload = BL.toStrict

332+bytesToPayload = TE.decodeUtf8 . BL.toStrict

342333

343334

344335performRequestsCT

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

403394 else ResponseFailure tag errMsg xhr

404395 in respPayld

405396

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−

418397

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

420399note e = maybe (Left e) Right

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

428407

429408escape :: T.Text -> T.Text

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

431−

src/Servant/Reflex.hs+71−123

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

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

51+ BasicAuthData, BuildHeadersTo(..),

52+ Capture, contentType, Header,

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

54+ MimeRender(..), MimeUnrender,

5855 NoContent, QueryFlag, QueryParam,

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

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,

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

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

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,

src/Servant/Reflex/RequestAPI.hsnew file+567

@@ -0,0 +1,567 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE InstanceSigs #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE OverloadedStrings #-}

11+{-# LANGUAGE PolyKinds #-}

12+{-# LANGUAGE RankNTypes #-} -- Temporary

13+{-# LANGUAGE ScopedTypeVariables #-}

14+{-# LANGUAGE TupleSections #-}

15+{-# LANGUAGE TypeApplications #-}

16+{-# LANGUAGE TypeFamilies #-}

17+{-# LANGUAGE TypeOperators #-}

18+{-# LANGUAGE UndecidableInstances #-}

19+

20+module Servant.Reflex.RequestAPI where

21+

22+import Control.Arrow (first, second)

23+import Control.Lens

24+import Data.Generics.Product

25+import Data.Proxy

26+import Data.CaseInsensitive (mk)

27+import qualified Data.List as L

28+import qualified Data.Map as M

29+import Data.Maybe (catMaybes)

30+import Data.Semigroup ((<>))

31+import qualified Data.Set as Set

32+import qualified Data.Text.Encoding as E

33+import Data.Text (Text)

34+import qualified Data.Text as T

35+import qualified Data.ByteString.Lazy as BL

36+import GHC.Generics

37+import GHC.TypeLits (KnownSymbol, symbolVal)

38+import Reflex hiding (HList(..))

39+import Language.Javascript.JSaddle (MonadJSM)

40+import Servant.API hiding (HList(..))

41+import Servant.Common.Req hiding (QueryPart(..))

42+import Servant.Common.BaseUrl

43+

44+import Reflex.Dom hiding (HList(..))

45+

46+import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)

47+

48+{-

49+TODO:

50+ - [x] :<|>

51+ - [x] Verb content

52+ - [x] Verb nocontent

53+ - [x] Verb (Headers content)

54+ - [x] Verb (Headers nocontent)

55+ - [ ] Stream

56+ - [X] Capture :> ...

57+ - [ ] Capture' :> ...

58+ - [x] CaptureAll :> ...

59+ - [x] QueryParam :> ...

60+ - [x] QueryParams :> ...

61+ - [x] QueryFlag :> ...

62+ - [x] ReqBody :> ...

63+ - [ ] Header' :> ...

64+ - [x] Header :> ...

65+ - [x] Summary :> ...

66+ - [x] Description :> ...

67+ - [x] path :> ...

68+ - [ ] RemoteHost :> ...

69+ - [x] IsSecure :> ...

70+ - [x] Vault :> ...

71+ - [ ] WithNamedContext :> ...

72+ - [ ] AuthenticatedRequest :> ...

73+ - [x] BasicAuth :> ...

74+ - [ ] EmptyClient :> ...

75+ - [ ] EmptyClient

76+ - [ ] HttpVersion :> ...

77+-}

78+data HList xs where

79+ HNil :: HList '[]

80+ HCons :: x -> HList xs -> HList (x ': xs)

81+

82+clientR :: forall t m layout f . (HasClientR t m (Seal layout) f, Applicative f, Reflex t)

83+ => Proxy layout -> Proxy (m :: * -> *) -> Proxy t -> Proxy f

84+ -> Dynamic t BaseUrl -> ClientR t m (Seal layout) f

85+clientR _ mP tP fP url =

86+ clientRWithRoute (Proxy :: Proxy (Seal layout)) mP fP undefined url undefined

87+

88+-- | A class for generating top-level the API client function

89+class HasClientR t (m :: * -> *) api (f :: * -> *) where

90+ type ClientR t m api f :: *

91+ clientRWithRoute :: Proxy api -> Proxy m -> Proxy f

92+ -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl

93+ -> ClientOptions -> ClientR t m api f

94+

95+-- instance EndpointR t m Raw f where

96+-- type EInputs t m Raw f = '[XhrRequest T.Text]

97+-- type EOutput t m Raw f = XhrResponse

98+

99+-- mkReq (HCons (XhrRequest method url conf) NHil) =

100+-- ReqR method

101+

102+

103+-- | A class for generating endpoint-level API client functions

104+-- We need two separate type classes because the needs of endpoints

105+-- and top-level clients are incompatible

106+--

107+-- Endpoints need to accumulate a list of their input types from

108+-- the API definition (the @EInputs@ associated type) when building

109+-- up a function from a sequence of @:>@ combinators. But for

110+-- sequences of @:<|>@ combinators, such a listing doesn't make

111+-- sense. So, we use one class for endpoint-level recursion and

112+-- another for collecting endpoints into the top-level API

113+class EndpointR t m api f where

114+

115+ type EInputs t m api f :: [*]

116+ type EOutput t m api f :: *

117+

118+ mkReq :: HList (EInputs t m api f) -> ReqR

119+ getResp :: XhrResponse -> EOutput t m api f

120+

121+

122+------------------------------------------------------------------------------

123+-- | :<|> APIs

124+instance {-# OVERLAPPING #-}

125+ (HasClientR t m (layoutLeft) f,

126+ HasClientR t m (layoutRight) f

127+ ) => HasClientR t m (layoutLeft :<|> layoutRight) f where

128+ type ClientR t m (layoutLeft :<|> layoutRight) f =

129+ ClientR t m layoutLeft f :<|> ClientR t m layoutRight f

130+ clientRWithRoute _ tP mP _ url opts =

131+ clientRWithRoute (Proxy @layoutLeft) tP mP undefined url opts

132+ :<|>

133+ clientRWithRoute (Proxy @layoutRight) tP mP undefined url opts

134+

135+#if MIN_VERSION_servant (0,13,0)

136+-- TODO: Untested

137+instance HasClientR t m EmptyClient f where

138+ type ClientR t m api f = EmptyClient

139+ clientRWithRoute _ _ _ _ _ _ = EmptyClient

140+#endif

141+

142+

143+class ToTuple xs where

144+ type Tuple xs :: *

145+ toTuple :: xs -> Tuple xs

146+ fromTuple :: Tuple xs -> xs

147+

148+data Sealed a

149+data SealedRaw

150+

151+type family Seal a where

152+ Seal (a :<|> b) = Seal a :<|> Seal b

153+ Seal Raw = SealedRaw

154+ Seal a = Sealed a

155+

156+

157+-- | Turn a single Endpoint into a client, by turning the input HList

158+-- into a tuple

159+instance {-# OVERLAPPING #-} forall t m layout f .(EndpointR t m layout f,

160+ ToTuple (HList (EInputs t m layout f)),

161+ Monad m

162+ , Traversable f

163+ , SupportsServantReflex t m

164+ ) => HasClientR t (m :: * -> *) (Sealed layout) (f :: * -> *) where

165+ type ClientR t m (Sealed layout) f =

166+ Event t (f (Tuple (HList (EInputs t m layout f))))

167+ -> m (Event t (f (EOutput t m layout f)))

168+ clientRWithRoute _ mP fP dReq url opts (reqs :: Event t (f (Tuple (HList (EInputs t m layout f ))))) = do

169+ let reqTuples = fmap (fromTuple @(HList (EInputs t m layout f ))) <$> reqs

170+

171+ -- TODO: replace these 2 lines w/ the next 2. The trace is for library debugging

172+ reqRs = traceEventWith (concat . fmap ((<> "\n") . show)) $ fmap (mkReq @t @m @layout @f) <$> reqTuples

173+ reqs' = ffor (attachPromptlyDyn url reqRs) $ \(bUrl, rs) -> mkXhrRequest bUrl <$> rs

174+ -- reqs' = ffor (attachPromptlyDyn url reqTuples) $ \(bUrl, inputs) ->

175+ -- mkXhrRequest bUrl . mkReq @t @m @layout @f <$> inputs

176+ resps <- performRequestsAsync $ reqs'

177+ return (fmap (getResp @t @m @layout @f) <$> resps)

178+

179+

180+instance (SupportsServantReflex t m, Traversable f) => HasClientR t m SealedRaw f where

181+ type ClientR t m SealedRaw f = Event t (f (XhrRequest T.Text)) -> m (Event t (f XhrResponse))

182+ clientRWithRoute _ mP fP dReq url opts reqs = performRequestsAsync reqs

183+

184+

185+instance {-# OVERLAPPING #-}(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m, Applicative f

186+ ) => EndpointR t m (Verb method status cts' a) f where

187+ type EInputs t m (Verb method status cts' a) f = '[]

188+ type EOutput t m (Verb method status cts' a) f = Either String a

189+

190+ mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)

191+ getResp resp = case _xhrResponse_response resp of

192+ Just (XhrResponseBody_ArrayBuffer x) -> mimeUnrender (Proxy @ct) (BL.fromStrict x)

193+

194+instance {-# OVERLAPPING #-}(ReflectMethod method, SupportsServantReflex t m, Applicative f

195+ ) => EndpointR t m (Verb method status cts' NoContent) f where

196+ type EInputs t m (Verb method status cts' NoContent) f = '[]

197+ type EOutput t m (Verb method status cts' NoContent) f = Either String NoContent

198+

199+ mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)

200+ getResp resp = Right NoContent -- TODO: Should EOutput be `NoContent` rather than Either... ?

201+

202+

203+instance {-# OVERLAPPING #-}

204+ (MimeUnrender ct a,

205+ BuildHeadersTo hs,

206+ ReflectMethod method, cts' ~ (ct ': cts),

207+ SupportsServantReflex t m,

208+ Applicative f,

209+ BuildHeaderKeysTo hs

210+ ) => EndpointR t m (Verb method status cts' (Headers hs a)) f where

211+ type EInputs t m (Verb method status cts' (Headers hs a)) f = '[]

212+ type EOutput t m (Verb method status cts' (Headers hs a)) f = Either String (Headers hs a)

213+

214+ mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR $ E.decodeUtf8 $ reflectMethod (Proxy @method)

215+ getResp resp = case _xhrResponse_response resp of

216+ Just (XhrResponseBody_ArrayBuffer x) ->

217+ let hs = buildHeadersTo

218+ . fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)

219+ . M.toList

220+ $ _xhrResponse_headers resp

221+ in fmap (flip Headers (hs)) $ mimeUnrender (Proxy @ct) (BL.fromStrict x)

222+

223+

224+instance {-# OVERLAPPING #-}(MimeUnrender ct a,

225+ BuildHeadersTo hs,

226+ BuildHeaderKeysTo hs,

227+ ReflectMethod method,

228+ SupportsServantReflex t m,

229+ Applicative f

230+ ) => EndpointR t m (Verb method status cts' (Headers hs NoContent)) f where

231+ type EInputs t m (Verb method status cts' (Headers hs NoContent)) f = '[]

232+ type EOutput t m (Verb method status cts' (Headers hs NoContent)) f = Either String (Headers hs NoContent)

233+

234+ mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)

235+ getResp resp = case _xhrResponse_response resp of

236+ Just (XhrResponseBody_ArrayBuffer x) ->

237+ let hs = buildHeadersTo

238+ . fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)

239+ . M.toList

240+ $ _xhrResponse_headers resp

241+ in Right (Headers NoContent hs)

242+

243+

244+instance (SupportsServantReflex t m,

245+ ToHttpApiData a,

246+ EndpointR t m sublayout f,

247+ Applicative f

248+ ) => EndpointR t m (Capture capture a :> sublayout) f where

249+

250+ type EInputs t m (Capture capture a :> sublayout) f = a ': EInputs t m sublayout f

251+ type EOutput t m (Capture capture a :> sublayout) f = EOutput t m sublayout f

252+

253+ mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (toUrlPiece a:)) x $

254+ mkReq @t @m @sublayout @f xs

255+

256+ getResp = getResp @t @m @sublayout @f

257+

258+instance (SupportsServantReflex t m,

259+ ToHttpApiData a,

260+ EndpointR t m sublayout f,

261+ Applicative f

262+ ) => EndpointR t m (CaptureAll capture a :> sublayout) f where

263+

264+ type EInputs t m (CaptureAll capture a :> sublayout) f = [a] ': EInputs t m sublayout f

265+ type EOutput t m (CaptureAll capture a :> sublayout) f = EOutput t m sublayout f

266+

267+ mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (fmap toUrlPiece a <>)) x $

268+ mkReq @t @m @sublayout @f xs

269+

270+ getResp = getResp @t @m @sublayout @f

271+

272+

273+instance (SupportsServantReflex t m,

274+ KnownSymbol sym,

275+ EndpointR t m sublayout f,

276+ Applicative f

277+ ) => EndpointR t m (sym :> sublayout) f where

278+

279+ type EInputs t m (sym :> sublayout) f = EInputs t m sublayout f

280+ type EOutput t m (sym :> sublayout) f = EOutput t m sublayout f

281+

282+ mkReq r = over (field @"reqRPathParts") (T.pack (symbolVal (Proxy @sym)) :) $ mkReq @t @m @sublayout @f r

283+

284+ getResp = getResp @t @m @sublayout @f

285+

286+instance (SupportsServantReflex t m,

287+ ToHttpApiData a,

288+ EndpointR t m sublayout f,

289+ KnownSymbol sym,

290+ Applicative f

291+ ) => EndpointR t m (QueryParam sym a :> sublayout) f where

292+

293+ type EInputs t m (QueryParam sym a :> sublayout) f = Maybe a ': EInputs t m sublayout f

294+ type EOutput t m (QueryParam sym a :> sublayout) f = EOutput t m sublayout f

295+

296+ mkReq (HCons x xs) = over (field @"reqRParams") ((T.pack $ symbolVal (Proxy @sym),

297+ QueryPartParam $ fmap (toQueryParam) x) : ) $

298+ mkReq @t @m @sublayout @f xs

299+

300+

301+ getResp = getResp @t @m @sublayout @f

302+

303+instance (SupportsServantReflex t m,

304+ ToHttpApiData a,

305+ EndpointR t m sublayout f,

306+ KnownSymbol sym,

307+ Applicative f

308+ ) => EndpointR t m (QueryParams sym a :> sublayout) f where

309+

310+ type EInputs t m (QueryParams sym a :> sublayout) f = [a] ': EInputs t m sublayout f

311+ type EOutput t m (QueryParams sym a :> sublayout) f = EOutput t m sublayout f

312+

313+ mkReq (HCons x xs) =

314+ let newParams = (T.pack (symbolVal (Proxy @sym)), QueryPartParams (toQueryParam <$> x))

315+ in over (field @"reqRParams") (newParams :) $ mkReq @t @m @sublayout @f xs

316+

317+ getResp = getResp @t @m @sublayout @f

318+

319+instance (SupportsServantReflex t m,

320+ EndpointR t m sublayout f,

321+ KnownSymbol sym,

322+ Applicative f

323+ ) => EndpointR t m (QueryFlag sym :> sublayout) f where

324+

325+ type EInputs t m (QueryFlag sym :> sublayout) f = Bool ': EInputs t m sublayout f

326+ type EOutput t m (QueryFlag sym :> sublayout) f = EOutput t m sublayout f

327+

328+ mkReq (HCons x xs) =

329+ let newParam = (T.pack (symbolVal (Proxy @sym)), QueryPartFlag x)

330+ in over (field @"reqRParams") (newParam :) $ mkReq @t @m @sublayout @f xs

331+

332+ getResp = getResp @t @m @sublayout @f

333+

334+instance (SupportsServantReflex t m,

335+ EndpointR t m sublayout f,

336+ MimeRender ct a,

337+ Applicative f

338+ ) => EndpointR t m (ReqBody (ct ': cts) a :> sublayout) f where

339+

340+

341+ type EInputs t m (ReqBody (ct ': cts) a :> sublayout) f = a ': EInputs t m sublayout f

342+ type EOutput t m (ReqBody (ct ': cts) a :> sublayout) f = EOutput t m sublayout f

343+

344+ mkReq (HCons x xs) =

345+ set (field @"reqRBody") (Just (mimeRender (Proxy @ct) x, T.pack (show (contentType (Proxy @ct))))) $ mkReq @t @m @sublayout @f xs

346+

347+ getResp = getResp @t @m @sublayout @f

348+

349+

350+instance (SupportsServantReflex t m,

351+ EndpointR t m sublayout f,

352+ KnownSymbol sym,

353+ ToHttpApiData a,

354+ Applicative f

355+ ) => EndpointR t m (Header sym a :> sublayout) f where

356+

357+

358+ type EInputs t m (Header sym a :> sublayout) f = a ': EInputs t m sublayout f

359+ type EOutput t m (Header sym a :> sublayout) f = EOutput t m sublayout f

360+

361+ mkReq (HCons x xs) =

362+ over (field @"reqRHeaders")

363+ -- ((symbolVal (Proxy @sym), (mimeRender (Proxy @a) x)) :)

364+ ((T.pack $ symbolVal (Proxy @sym), E.decodeUtf8 $ toHeader x) :)

365+ $ mkReq @t @m @sublayout @f xs

366+

367+ getResp = getResp @t @m @sublayout @f

368+

369+#if MIN_VERSION_servant(0,13,0)

370+-- TODO: Untested

371+instance (SupportsServantReflex t m,

372+ EndpointR t m sublayout f,

373+ KnownSymbol sym,

374+ ToHttpApiData a,

375+ Applicative f

376+ ) => EndpointR t m (Summary desc :> sublayout) f where

377+

378+ type EInputs t m (Summary desc :> sublayout) f = EInputs t m sublayout f

379+ type EOutput t m (Summary desc :> sublayout) f = EOutput t m sublayout f

380+

381+ mkReq = mkReq @t @m @sublayout @f

382+

383+ getResp = getResp @t @m @sublayout @f

384+#endif

385+

386+

387+#if MIN_VERSION_servant(0,13,0)

388+-- TODO: Untested

389+instance (SupportsServantReflex t m,

390+ EndpointR t m sublayout f,

391+ KnownSymbol sym,

392+ ToHttpApiData a,

393+ Applicative f

394+ ) => EndpointR t m (Description desc :> sublayout) f where

395+

396+ type EInputs t m (Descriptiok desc :> sublayout) f = EInputs t m sublayout f

397+ type EOutput t m (Description desc :> sublayout) f = EOutput t m sublayout f

398+

399+ mkReq = mkReq @t @m @sublayout @f

400+

401+ getResp = getResp @t @m @sublayout @f

402+#endif

403+

404+instance (SupportsServantReflex t m,

405+ EndpointR t m sublayout f,

406+ KnownSymbol sym,

407+ ToHttpApiData a,

408+ Applicative f

409+ ) => EndpointR t m (IsSecure :> sublayout) f where

410+

411+

412+ type EInputs t m (IsSecure :> sublayout) f = EInputs t m sublayout f

413+ type EOutput t m (IsSecure :> sublayout) f = EOutput t m sublayout f

414+

415+ mkReq = mkReq @t @m @sublayout @f

416+

417+ getResp = getResp @t @m @sublayout @f

418+

419+instance (SupportsServantReflex t m,

420+ EndpointR t m sublayout f,

421+ KnownSymbol sym,

422+ ToHttpApiData a,

423+ Applicative f

424+ ) => EndpointR t m (Vault :> sublayout) f where

425+

426+

427+ type EInputs t m (Vault :> sublayout) f = EInputs t m sublayout f

428+ type EOutput t m (Vault :> sublayout) f = EOutput t m sublayout f

429+

430+ mkReq = mkReq @t @m @sublayout @f

431+

432+ getResp = getResp @t @m @sublayout @f

433+

434+instance (SupportsServantReflex t m,

435+ EndpointR t m sublayout f,

436+ Applicative f

437+ ) => EndpointR t m (BasicAuth realm usr :> sublayout) f where

438+

439+ type EInputs t m (BasicAuth realm usr :> sublayout) f = BasicAuthData ': EInputs t m sublayout f

440+ type EOutput t m (BasicAuth realm usr :> sublayout) f = EOutput t m sublayout f

441+

442+ mkReq (HCons x xs) =

443+ set (field @"reqRAuthData") (Just x) $ mkReq @t @m @sublayout @f xs

444+

445+ getResp = getResp @t @m @sublayout @f

446+

447+

448+instance ToTuple (HList '[]) where

449+ type Tuple (HList '[]) = ()

450+ toTuple _ = ()

451+ fromTuple _ = HNil

452+

453+instance ToTuple (HList '[a]) where

454+ type Tuple (HList '[a]) = a

455+ toTuple (HCons a HNil) = a

456+ fromTuple a = HCons a HNil

457+

458+instance ToTuple (HList '[a,b]) where

459+ type Tuple (HList '[a,b]) = (a,b)

460+ toTuple (HCons a (HCons b HNil)) = (a,b)

461+ fromTuple (a,b) = HCons a (HCons b HNil)

462+

463+instance ToTuple (HList '[a,b,c]) where

464+ type Tuple (HList '[a,b,c]) = (a,b,c)

465+ toTuple (HCons a (HCons b (HCons c HNil))) = (a,b,c)

466+ fromTuple (a,b,c) = HCons a (HCons b (HCons c HNil))

467+

468+type MyAPI = Header "hi" Int :> Capture "hello" Int :> Capture "hello2" Bool :> Get '[JSON] (Headers '[Header "hi" Int] Int)

469+ :<|> Get '[JSON] Bool

470+

471+type MyAPI2 = Raw

472+

473+

474+m :: forall t m.MonadWidget t m => m ()

475+m = do

476+ let (a :<|> b) = clientR (Proxy @MyAPI) (Proxy :: Proxy m) (Proxy :: Proxy t)

477+ (Proxy @[]) undefined

478+ btn <- button "Hello"

479+ resA <- a (fmap (:[]) ((2, 5,True) <$ btn))

480+ resB <- b (fmap (:[]) (() <$ btn))

481+ display =<< holdDyn "waiting" (leftmost [show <$> resB ])

482+ -- [show <$> resA

483+ -- , show <$> resB

484+ -- ])

485+

486+ let rawR = clientR (Proxy @MyAPI2) (Proxy @m) (Proxy @t) (Proxy @[]) undefined

487+ return ()

488+

489+data ReqR = ReqR

490+ { reqRMethod :: T.Text

491+ , reqRPathParts :: [T.Text]

492+ , reqRParams :: [(T.Text, QueryPart)]

493+ , reqRBody :: Maybe (BL.ByteString, T.Text)

494+ , reqRHeaders :: [(T.Text, T.Text)]

495+ , reqRRespHeaders :: XhrResponseHeaders

496+ , reqRAuthData :: Maybe BasicAuthData

497+ } deriving (Generic)

498+

499+instance Show ReqR where

500+ show (ReqR m pp ps b hs hs' a) = concat $ L.intersperse "\n" [

501+ "ReqR {"

502+ , ("reqRMethod = " <> show m)

503+ , ("reqRPathParts = " <> show pp)

504+ , ("reqRParams = " <> show ps)

505+ , ("reqRBody = " <> show b)

506+ , ("reqRHeaders = " <> show hs)

507+ , ("reqRRespHeaders = " <> show hs')

508+ , ("reqRAuthData = " <> maybe "Nothing" (const "Just <<redacted>>") a)

509+ ]

510+

511+emptyReqR :: T.Text -> ReqR

512+emptyReqR method = ReqR method [] [] Nothing [] (OnlyHeaders mempty) Nothing

513+

514+data QueryPart = QueryPartParam (Maybe Text)

515+ | QueryPartParams [Text]

516+ | QueryPartFlag Bool

517+ deriving (Show)

518+

519+mkXhrRequest :: BaseUrl -> ReqR -> XhrRequest T.Text

520+mkXhrRequest reqHost req =

521+ let path = T.intercalate "/" $ reqRPathParts req

522+

523+ queryPartString :: (Text, QueryPart) -> Maybe Text

524+ queryPartString (pName, qp) = case qp of

525+

526+ QueryPartParam Nothing -> Nothing

527+ QueryPartParam (Just a) -> Just (pName <> "=" <> escape a)

528+

529+ QueryPartParams ps -> Just . T.intercalate "&"

530+ $ fmap (\p -> pName <> "=" <> escape p)

531+ ps

532+

533+ QueryPartFlag True -> Just pName

534+ QueryPartFlag False -> Nothing

535+

536+ (</>) :: Text -> Text -> Text

537+ x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y

538+ | otherwise = x <> "/" <> y

539+

540+ queryString = T.intercalate "&" . catMaybes . map queryPartString $ reqRParams req

541+ url = showBaseUrl reqHost </> path <> if T.null queryString then "" else (T.cons '?' queryString)

542+

543+ (headers, body) =

544+ let headers0 = M.fromList $ reqRHeaders req

545+ in case reqRBody req of

546+ Nothing -> (headers0, "")

547+ Just (rb,ct) -> (M.insert "Content-Type" ct headers0,

548+ E.decodeUtf8 $ BL.toStrict rb)

549+

550+ xhrReqConfig = def

551+ { _xhrRequestConfig_headers = headers

552+ , _xhrRequestConfig_user = E.decodeUtf8 . basicAuthUsername <$> reqRAuthData req

553+ , _xhrRequestConfig_password = E.decodeUtf8 . basicAuthPassword <$> reqRAuthData req

554+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

555+ , _xhrRequestConfig_sendData = body

556+ , _xhrRequestConfig_responseHeaders = reqRRespHeaders req

557+ , _xhrRequestConfig_withCredentials = False

558+ }

559+ xhrReq = XhrRequest (reqRMethod req) url xhrReqConfig

560+ in xhrReq

561+

562+transformExample :: MonadWidget t m => ((Int, Char) -> Performable m Bool) -> Event t (Int, Char) -> m (Event t Bool)

563+transformExample f = \triggers -> performEvent (f <$> triggers)

564+-- transformExample = undefined -- let x = performEvent :: _ in undefined

565+

566+transform :: MonadWidget t m => forall a. (inp -> IO outp) -> (Event t inp -> m (Event t outp))

567+transform = undefined

testdriver/default.nixnew file+16

@@ -0,0 +1,16 @@

1+{ mkDerivation, base, hspec, hspec-webdriver, stdenv, text

2+, webdriver

3+}:

4+mkDerivation {

5+ pname = "testdriver";

6+ version = "0.2";

7+ src = ./.;

8+ isLibrary = false;

9+ isExecutable = true;

10+ executableHaskellDepends = [

11+ base hspec hspec-webdriver text webdriver

12+ ];

13+ description = "Selenium test driver for Servant reflex";

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

15+ hydraPlatforms = stdenv.lib.platforms.none;

16+}

testdriver/shell.nixnew file+1

@@ -0,0 +1 @@

1+(import ../release3.nix {}).testdriver.env

testdriver/test/Servant/ReflexSpec.hs−1

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

testserver/API.hs+4−1

@@ -31,6 +31,7 @@ instance FromJSON Answer where

3131-- | API spec for server, client, and docs

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

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

34+ :<|> "dblint" :> Capture "anint" Int :> Get '[JSON] Int

3435 :<|> "sayhi" :> QueryParam "username" Text

3536 :> QueryParams "greetings" Text

3637 :> QueryFlag "gusto"

@@ -39,7 +40,9 @@ type API = "getunit" :> Get '[JSON] ()

3940 :> Post '[JSON] Double

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

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

42− :> Post '[JSON] Answer

43+ :> Header "qnum" Int

44+ :> Header "is-favorite" Bool

45+ :> Post '[JSON] (Headers '[Header "anum" Int, Header "was-favorite" Bool] Answer)

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

4447 :<|> Raw

4548

testserver/Main.hs+17−18

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

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)

@@ -20,16 +19,15 @@ import Data.Text hiding (head, length, map,

2019import qualified Data.Text as T

2120import qualified Data.Text.IO as T

2221import GHC.Generics

23−import Servant.Server.Internal.SnapShims

24−import Snap.Core

22+import Snap.Core hiding (addHeader)

2523import Snap.Http.Server

2624

2725import Servant

28−import Servant.Server

26+import Servant.Server ()

27+import System.Directory

2928-- import Snap.Util.FileServe

30−import System.Environment (lookupEnv)

3129import API

32−import Snap

30+import Snap hiding (addHeader)

3331

3432-- * Example

3533

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

4341testApi :: Proxy API

4442testApi = Proxy

4543

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

44+data App = App

4745

4846-- Server-side handlers.

4947--

@@ -52,9 +50,8 @@ data App = App { appStaticDir :: String }

5250--

5351-- Each handler runs in the 'ExceptT ServantErr IO' monad.

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

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

56− :<|> multi :<|> qna :<|> serveSecret

57− :<|> statics

53+server = return () :<|> return 100 :<|> dblint :<|> sayhi :<|> dbl

54+ :<|> multi :<|> qna :<|> serveSecret :<|> 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)

@@ -66,22 +63,20 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl

6663 | otherwise = T.intercalate ", " (L.init greetings)

6764 <> ", and " <> L.last greetings <> ", "

6865 return . modifier $ greetPart <> n

66+ dblint = return . (* 2)

6967 dbl x = if x `elem` [4,13]

7068 then throwError $ err500 { errBody = "No unlucky numbers please" }

7169 else return $ x * 2

7270 multi = return . bool "Box unchecked" "Box Checked"

73− qna q = do

71+ qna q nm fav = do

7472 liftIO $ do

7573 putStrLn $ "qna got: " ++ show q

7674 T.putStrLn $ unQuestion q

77− return $ Answer $ unQuestion q

75+ return $ addHeader (fromMaybe 10 nm) $ addHeader (fromMaybe False fav) $ (Answer $ unQuestion q)

7876 serveSecret _ = do

7977 req <- getRequest

8078 liftIO $ putStrLn (show req)

8179 return 101

82− statics = do

83− staticDir <- reader appStaticDir

84− serveDirectory staticDir

8580

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

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

@@ -91,12 +86,16 @@ test = serveSnapWithContext testApi

9186

9287initApp :: SnapletInit App App

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

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

89+ liftIO $ print =<< listDirectory "."

90+ liftIO $ print =<< listDirectory "static"

9591 addRoutes [("", test)

9692 ,("", serveDirectory "static")

9793 ]

98− return (App staticDir)

94+ return App

9995

10096-- Put this all to work!

10197main :: IO ()

102−main = serveSnaplet mempty initApp

98+main = commandLineConfig emptyConfig >>= \cfg -> print cfg >> serveSnaplet cfg initApp

99+-- main = serveSnaplet (defaultConfig { accessLog = "/tmp/log/testserver-access.log"

100+-- , errorLog = "/tmp/log/testserver-error.log"

101+-- }) initApp

testserver/default.nixnew file+14

@@ -0,0 +1,14 @@

1+{ mkDerivation, aeson, base, servant, servant-snap, snap, snap-core

2+, snap-server, stdenv, text

3+}:

4+mkDerivation {

5+ pname = "testserver";

6+ version = "0.1.0.0";

7+ src = ./.;

8+ isLibrary = false;

9+ isExecutable = true;

10+ executableHaskellDepends = [

11+ aeson base servant servant-snap snap snap-core snap-server text

12+ ];

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

14+}

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/shell.nixnew file+1

@@ -0,0 +1 @@

1+(import ../release.nix {}).testserver.env

testserver/testserver.cabal+5−5

@@ -19,13 +19,13 @@ 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

24+ , directory >= 1.2 && < 1.4

2525 , snap >= 1.0 && < 1.2

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

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

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

28− , servant >= 0.16 && < 0.18

28+ , servant >= 0.8 && < 0.12

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

3030 , text >= 1.0 && < 1.3

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