master..c9de020 · servant-reflex

git.iko.soy/servant-reflex

on c9de020 help sign in

.gitignore−3

since splitsnapshots

unifiedsplit

@@ -6,6 +6,3 @@ log

6*.webapp

7*.stats

8out

9−/.stack-work/

10−TAGS

11−dist-newstyle

.gitmodules+15

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

1+[submodule "deps/reflex-dom"]

2+ path = deps/reflex-dom

3+ url = https://github.com/reflex-frp/reflex-dom.git

4+[submodule "deps/reflex"]

5+ path = deps/reflex

6+ url = https://github.com/reflex-frp/reflex.git

7+[submodule "deps/http-api-data"]

8+ path = deps/http-api-data

9+ url = https://github.com/fizruk/http-api-data

10+[submodule "deps/servant"]

11+ path = deps/servant

12+ url = https://github.com/haskell-servant/servant

13+[submodule "deps/servant-snap"]

14+ path = deps/servant-snap

15+ url = https://github.com/haskell-servant/servant-snap

.travis.yml+58−12

@@ -1,17 +1,63 @@

1−language: nix

1+sudo: required

2−nix: 2.3.6

3−sudo: require

3+before_cache:

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

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

7+addons:

8+ apt:

9+ - phantomjs

10+

11+matrix:

12+ include:

13+ - env: CABALVER=1.24 GHCVER=7.10.3

14+ compiler: ": #GHC 7.10.3"

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

16+ - env: CABALVER=1.24 GHCVER=8.0.1

17+ compiler: ": #GHC 8.0.1"

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

19+

20+

5before_install:

22before_install:

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

23+ - openssl aes-256-cbc -K $encrypted_3c89d919c82e_key -iv $encrypted_3c89d919c82e_iv -in deploy_key.enc -out deploy_key -d

24+ - unset CC

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

26+ - git submodule update --init --recursive

8−before_script:

28+install:

9− - sudo systemctl restart nix-daemon.service

29+ - cabal --version

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

30+ - BENCH=${BENCH---enable-benchmarks}

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

31+ - TEST=${TEST---enable-tests}

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

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

34+ then

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

36+ $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;

37+ fi

38+ - travis_retry cabal update -v

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

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

41+ - reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal configure && cabal build"

42+ - reflex-platform/work-on ghc ./testdriver --command "cd testdriver && cabal configure && cabal build"

43+ - cd testserver && dist/build/back/back -p 8000 &

44+ - sleep 3

45+ - phantomjs --webdriver=127.0.0.1:4444 &

46+ - sleep 3

13script:

48script:

14− - nix-build travis.nix -A build

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

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

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

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

51+ - ./build.sh

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

52+ - testdriver/dist/build/spec/spec

53+

54+cache:

55+ directories:

56+ - /nix

57+ - $HOME/.cabal/packages

58+ - $HOME/.cabal/store

59+

60+env:

61+ global:

62+ - ENCRYPTION_LABEL: "3c89d919c82e"

63+ - COMMIT_AUTHOR_EMAIL: "imalsogreg@gmail.com"

ChangeLog.mddeleted−60

@@ -1,60 +0,0 @@

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−

14−0.3.3

15−-----

16−

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

18−

19−

20−0.3.2

21−-----

22−

23−- **Addition of 'Servant.Reflex.Common.Req.ClientOpts'** which

24−allows the users to apply a final adjustment to Requests before

25−thery are sent, such as setting the 'withCredentials' flag

26−or print the Request to the console for debugging

27−[PR #47](https://github.com/imalsogreg/servant-reflex/pull/47)

28−

29−0.3

30−---

31−

32−- **Addition of the 'Servant.Reflex.Multi' module** which allows the user

33−to choose some '(Applicative f, Traversable f) => f' for collecting

34−endpoint parameters. The traversable instance is used for passing

35−multiple 'XhrRequest's in response to a single event trigger. The

36−Applicative instance is used to combine parameters. For example,

37−'Capture "id" Name :> QueryParam "greeting" Text :> Get '[JSON] Text'

38−will generate a client function:

39−`Dynamic t (f Name) -> Dynamic t (f greeting) -> Event t tag ->

40− m (Event t (f (ReqResult tag Text)))`

41−Calling that function with 'f' chosen to be list ('[]'), this call

42−`clientFun

43−(constDyn ["Greg", "Bernie"])

44−(constDyn ["Greetings", "Hey"])

45−trigger`

46−would produce four XhrRequests per 'trigger' event, one for each

47−combination of possible parameters, and one response event

48−would carry a list of the four responses.

49−A 'zip-wise' combination of the parameters can be chosen with

50−a different applicative wrapper: 'ZipList'

51−

52−- **Event tags**. A new type parameter lets users choose a payload

53−value to attach to outgoing requests at the point of triggering,

54−and which is embedded in the response, allowing individual

55−request-response pairs to be followed. The response's tag has been

56−added to each constructor `ReqResult tag a` type.

57−

58−- **Improved Unicode support** Thanks to Schell Scivally

59−(https://github.com/schell) for identifying and fixing a UTF-8

60−encoding bug!

README.md+28−114

@@ -2,21 +2,16 @@

3[![Build Status](https://travis-ci.org/imalsogreg/servant-reflex.svg?branch=master)](https://travis-ci.org/imalsogreg/servant-reflex)

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

5+## The problem `servant-reflex` solves

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.

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.

16## Example

12## Example

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

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:

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

21```haskell

16```haskell

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

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

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

29 :<|> Raw

24 :<|> Raw

30```

25```

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

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

33−an `XhrRequest`.

35```haskell

29```haskell

@@ -39,26 +33,16 @@ an `XhrRequest`.

39 -- servant-reflex computes FRP functions for each API endpoint

33 -- servant-reflex computes FRP functions for each API endpoint

40 let (getint :<|> sayhi :<|> doubleit :<|> _) = client (Proxy :: Proxy API)

34 let (getint :<|> sayhi :<|> doubleit :<|> _) = client (Proxy :: Proxy API)

41 (Proxy :: Proxy m)

35 (Proxy :: Proxy m)

42− (Proxy :: Proxy ())

43 (constDyn (BasePath "/"))

36 (constDyn (BasePath "/"))

44```

37```

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

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

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.

57```haskell

41```haskell

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

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

59 getint :: MonadWidget t m

43 getint :: MonadWidget t m

60 => Event t () -- ^ Trigger the XHR Request

44 => Event t () -- ^ Trigger the XHR Request

61− -> m (Event t (ReqResult () Int)) -- ^ Consume the answer

45+ -> m (Event t (ReqResult Int)) -- ^ Consume the answer

63 sayhi :: MonadWidget t m

47 sayhi :: MonadWidget t m

64 => Dynamic t (QParam Text)

48 => Dynamic t (QParam Text)

@@ -69,21 +53,15 @@ parameter is a trigger event for the XHR request. The return value

69 -- ^ Flag for capitalizing the response

53 -- ^ Flag for capitalizing the response

70 -> Event t ()

54 -> Event t ()

71 -- ^ Trigger the XHR Request

55 -- ^ Trigger the XHR Request

72− -> m (Event t (ReqResult () Text))

56+ -> m (Event t (ReqResult Text))

74 doubleit :: MonadWidget t m

58 doubleit :: MonadWidget t m

75 => Dynamic t (Either Text Double)

59 => Dynamic t (Either Text Double)

76 -> Event t ()

60 -> Event t ()

77− -> m (Event t (ReqResult () Double))

61+ -> m (Event t (ReqResult Double))

78```

62```

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)

64+`ReqResult 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:

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:

88```haskell

66```haskell

89 -- ... continued ...

67 -- ... continued ...

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

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

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

102```

80```

103

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

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

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

106

107```haskell

84```haskell

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

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

@@ -125,100 +102,37 @@ trigger the API calls, and text elements to show the results:

125 display =<< holdDyn Nothing outputDouble

102 display =<< holdDyn Nothing outputDouble

126```

103```

127

104

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

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

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.

133

106

134

107

135## Building the library and test server

108## Building the library and test server

136

109

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

110+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:

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

143−manages the frontend build as a dependency.

144

111

145−```

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

147−```

148

112

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

113+First build the library:

150

114

151```

115```

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

116+git submodule update --init --recursive

117+./build.sh

153```

118```

154

119

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

120+Then build the test server:

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

157−under the Network tab.

158−

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

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

161

121

122+```

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

124+```

162

125

163−## Tagging requests

164

126

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

127+## Running the example site

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.

169

128

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

129+The server must be run from the directory where static assets live:

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:

175

130

176−```haskell

177− ...

178− inp <- textInput def

179−

180− -- Convert the raw text into an `Either Text Double`

181− let inpNum = maybe (Left "No Parse") Right . readMaybe . T.unpack <$> value inp

182− go <- button "Double It"

183−

184− -- Call 'doubleIt' with triggers that coincide with good input parses

185− rs <- doubleIt inpNum (fforMaybe (tagPromptlyDyn inpNum go) $ \case

186− Left _ -> Nothing

187− Right a -> Just a

188− )

189−

190− -- Accumulate good responses in a map

191− doubleTable <- foldDyn (<>) mempty $ ffor rs $ \case

192− ResponseSuccess tag v _ -> tag =: v

193− _ -> mempty

194−

195− el "table" $ do

196− listWithKey doubleTable $ \k dv -> el "tr" $ do

197− el "td" $ text (T.pack $ show k)

198− el "td" $ dynText (T.pack . show <$> dv)

199− ...

200```

131```

201−

132+cd testserver

202−## Simultaneous requests

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

203−

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:

208−

209−```haskell

210−sayHi

211− :: Dynamic t (f (QParam Text))

212− -> Dynamic t (f [Text])

213− -> Dynamic t (f Bool)

214− -> Event t tag

215− -> m (Event t (f (ReqResult tag Text)))

216```

134```

217

135

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

136+And simply browse to `localhost:8001`

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

137+

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

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

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

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

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

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

build.shnew file+3

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

1+#!/usr/bin/env bash

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

default.nixdeleted−21

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

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

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

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

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

5−, transformers

6−}:

7−mkDerivation {

8− pname = "servant-reflex";

9− version = "0.3.6";

10− src = ./.;

11− isLibrary = true;

12− isExecutable = true;

13− libraryHaskellDepends = [

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

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

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

17− text transformers

18− ];

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

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

21−}

deps/http-api-datanew file+1

Submodule changed.

deps/reflexnew file+1

Submodule changed.

deps/reflex-domnew file+1

Submodule changed.

deps/servantnew file+1

Submodule changed.

deps/servant-snapnew file+1

Submodule changed.

exec/API.hs+4−29

@@ -1,32 +1,10 @@

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE TypeOperators #-}

2+{-# LANGUAGE TypeOperators #-}

5module API where

4module API where

7−import Data.Aeson

8−import Data.Aeson.Types (typeMismatch)

9−import Data.Text (Text)

6+import Data.Text (Text)

10−import Servant.API

7+import Servant.API

11−

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

13−

14−instance ToJSON Question where

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

16−

17−instance FromJSON Question where

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

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

20−

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

22−

23−instance ToJSON Answer where

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

25−

26−instance FromJSON Answer where

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

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

29−

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

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

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

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

@@ -38,9 +16,6 @@ type API = "getunit" :> Get '[JSON] ()

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

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

39 :> Post '[JSON] Double

17 :> Post '[JSON] Double

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

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

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

42− :> Post '[JSON] Answer

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

44 :<|> Raw

19 :<|> Raw

46type GET = Get '[JSON] ()

21type GET = Get '[JSON] ()

exec/Example.hs+20−58

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

1−{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

@@ -15,14 +14,11 @@ import Control.Monad.Fix (MonadFix)

15import Data.Monoid (First(..), (<>))

14import Data.Monoid (First(..), (<>))

16import Data.Text (Text)

15import Data.Text (Text)

17import qualified Data.Text as T

16import qualified Data.Text as T

18−import qualified Data.Text.Encoding as T

19−import GHC.TypeLits

20import Servant.API

17import Servant.API

21import API

18import API

22import Data.Proxy

19import Data.Proxy

23import Text.Read (readMaybe)

20import Text.Read (readMaybe)

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

21+import Reflex.Dom

25−import Reflex.Dom (mainWidget)

26------------------------------------------------------------------------------

22------------------------------------------------------------------------------

27import Servant.Reflex

23import Servant.Reflex

28import Servant.Reflex.Multi

24import Servant.Reflex.Multi

@@ -46,18 +42,17 @@ runMulti :: forall t m. (SupportsServantReflex t m,

46runMulti = do

42runMulti = do

47 url <- baseUrlWidget

43 url <- baseUrlWidget

48 el "br" blank

44 el "br" blank

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

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

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

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

51−

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

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

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

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

54−

49+ -- dynText =<< holdDyn "waiting" (T.pack . show <$> num)

50+ -- numLabeled :: Event t (First Int, Double) <- zipListWithEvent (,) (First . Just <$> [0..]) num

55 b <- button "Run dbl multi"

51 b <- button "Run dbl multi"

56− reqCount :: Dynamic t Int <- count b

52+ reqCount <- count b

57 r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)

53 r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)

58− dynText =<< holdDyn "Waiting" (T.pack . show . fmap reqSuccess <$> r)

54+ dynText =<< holdDyn "Waiting" (T.pack . show . fmapMaybe reqSuccess .snd <$> r)

59−

60− lastInd <- holdDyn [] $ fmap reqTag <$> r

55+ lastInd <- holdDyn Nothing (Just . fst <$> r)

61 display lastInd

56 display lastInd

63 divClass "demo-group" $ do

58 divClass "demo-group" $ do

@@ -69,13 +64,8 @@ runMulti = do

69 textInput def

64 textInput def

70 gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def

65 gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def

71 b <- button "Go"

66 b <- button "Go"

72− r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)

67+ r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts) (constDyn [True, False]) (1 <$ b)

73− (constDyn [True, False]) (1 <$ b)

74−

75− dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .

68+ dynText =<< holdDyn "Waiting" (T.pack . show . fmap (fmapMaybe reqSuccess) <$> r')

76− fmap reqSuccess <$> r')

77−

78−

79 return ()

69 return ()

81run :: forall t m. (SupportsServantReflex t m,

71run :: forall t m. (SupportsServantReflex t m,

@@ -97,26 +87,21 @@ run = mdo

97 el "br" (return ())

87 el "br" (return ())

99 -- Name the computed API client functions

89 -- Name the computed API client functions

100− let tweakRequest = ClientOptions $ \r -> do

101− return $ r & withCredentials .~ True

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

103− :<|> multi :<|> qna :<|> secret :<|> doRaw) =

104− clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest

91+ client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url

105−

106− c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now

107

108 (unitBtn, intBtn) <- elClass "div" "demo-group" $ do

93 (unitBtn, intBtn) <- elClass "div" "demo-group" $ do

109 unitBtn <- divClass "unit-button" $ button "Get unit"

94 unitBtn <- divClass "unit-button" $ button "Get unit"

110 intBtn <- divClass "int-button" $ button "Get int"

95 intBtn <- divClass "int-button" $ button "Get int"

111

112 unitResponse <- getUnit $ tag (current reqCount) unitBtn

97 unitResponse <- getUnit $ tag (current reqCount) unitBtn

113− intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn

98+ intResponse :: Event t (Int, ReqResult Int) <- getInt $ tag (current reqCount) intBtn

114

115− score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))

100+ score <- foldDyn (+) 0 (fmapMaybe reqSuccess (snd <$> intResponse))

116

101

117 r <- holdDyn "Waiting" $ fmap showXhrResponse $

102 r <- holdDyn "Waiting" $ fmap showXhrResponse $

118− leftmost [fmapMaybe response (unitResponse)

103+ leftmost [fmapMaybe response (snd <$> unitResponse)

119− ,fmapMaybe response (intResponse)

104+ ,fmapMaybe response (snd <$> intResponse)

120 ]

105 ]

121 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score

106 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score

122 return (unitBtn, intBtn)

107 return (unitBtn, intBtn)

@@ -144,8 +129,8 @@ run = mdo

144

129

145 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)

130 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)

146 divClass "greeting-response" $ dynText =<<

131 divClass "greeting-response" $ dynText =<<

147− holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)

132+ holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (snd <$> resp)

148− , fmapMaybe reqFailure (resp)])

133+ , fmapMaybe reqFailure (snd <$> resp)])

149 return sayHiClicks

134 return sayHiClicks

150

135

151 dblBtn <- elClass "div" "demo-group" $ do

136 dblBtn <- elClass "div" "demo-group" $ do

@@ -156,11 +141,11 @@ run = mdo

156 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $

141 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $

157 dblinp) (tag (current reqCount) dblBtn)

142 dblinp) (tag (current reqCount) dblBtn)

158 divClass "double-errors" $ dynText =<<

143 divClass "double-errors" $ dynText =<<

159− holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))

144+ holdDyn "(no errors)" (fmapMaybe reqFailure (snd <$> dblResp))

160 el "br" (return ())

145 el "br" (return ())

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

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

162 holdDyn "No number yet" (fmap tShow $

147 holdDyn "No number yet" (fmap tShow $

163− fmapMaybe reqSuccess (dblResp))

148+ fmapMaybe reqSuccess (snd <$> dblResp))

164 return dblBtn

149 return dblBtn

165

150

166 mpGo <- elClass "div" "demo-group" $ do

151 mpGo <- elClass "div" "demo-group" $ do

@@ -170,34 +155,11 @@ run = mdo

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

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

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

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

172 fmapMaybe reqSuccess $

157 fmapMaybe reqSuccess $

173− (multiResp))

158+ (snd <$> multiResp))

174 return mpGo

159 return mpGo

175

160

176 return ()

161 return ()

177

162

178− el "br" $ return ()

179−

180− elClass "div" "demo-group" $ do

181− text "JSON Unicode encoding test"

182− txt <- value <$> textInput def

183− ev <- fmap (1 <$) $ button "Question"

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

185− rr <- qna dQ ev

186− el "p" $

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

188−

189− divClass "demo-group" $ do

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

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

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

193− <$> fmap T.encodeUtf8 un

194− <*> fmap T.encodeUtf8 pw

195− b <- button "Get secret"

196− r <- secret (Just <$> ba) (0 <$ b)

197− res <- holdDyn Nothing (reqSuccess <$> r)

198− display res

199−

200−

201showXhrResponse :: XhrResponse -> Text

163showXhrResponse :: XhrResponse -> Text

202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

164showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

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

165 T.unlines ["stat: " <> tShow stat

nix/nix.confdeleted−3

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

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

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

3−trusted-users = travis

nix/reflex-platform.nixdeleted−7

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

1−let

2− rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;

3−in import (builtins.fetchTarball

4− {

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

6− sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;

7− }) {}

nix/servant-snap.nixdeleted−7

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

1−# Servant-snap is marked broken in nixpkgs

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

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

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

5− rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";

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

7−}) {}

nix/testresults.nixdeleted−17

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

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

2−

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

4− echo About to phantom

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

6− sleep 3

7− echo About to Server

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

9− sleep 3

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

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

12− echo About to testdrive

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

14− echo Done

15− trap "exit" INT TERM

16− trap "kill 0" EXIT

17− ''

nix/testserver.nixdeleted−9

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

1−servant-reflex: self: super:

2−

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

4− postInstall = ''

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

6− mkdir $out/static

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

8− '';

9−})

overrides-ghc.nixnew file+18

@@ -0,0 +1,18 @@

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

2+let

3+ pkgs = import <nixpkgs> {};

4+ c2n = reflex-platform.cabal2nixResult;

5+in reflex-platform.ghc.override {

6+ overrides = self: super: {

7+ servant-snap = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap) {});

8+ snap = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap) {});

9+ snap-server = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-server) {});

10+ io-streams = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams) {});

11+ io-streams-haproxy = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});

12+ heist = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});

13+ xmlhtml = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});

14+ snap-core = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-core) {});

15+ servant = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant/servant) {});

16+ http-api-data = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/http-api-data) {});

17+ };

18+}

overrides.nixnew file+14

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

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

2+let

4+ nixpkgs = (import <nixpkgs> {});

5+ dontCheck = nixpkgs.pkgs.haskell.lib.dontCheck;

6+ cabal2nixResult = reflex-platform.cabal2nixResult;

8+in

9+reflex-platform.ghcjs.override {

10+ overrides = self: super: {

11+ servant = dontCheck (self.callPackage (cabal2nixResult deps/servant/servant) {});

12+ http-api-data = dontCheck (self.callPackage (cabal2nixResult deps/http-api-data) {});

13+ };

14+}

servant-reflex.cabal+19−36

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

1Name: servant-reflex

2−Version: 0.3.6

2+Version: 0.3

3−Synopsis: servant API generator for reflex apps

3+Synopsis: Servant reflex API generator

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

4+Description: Servant reflex API generator

5−License: BSD3

5+License: AllRightsReserved

6License-file: LICENSE.md

7Author: Greg Hale, Doug Beardsley

8Maintainer: imalsogreg@gmail.com

@@ -11,59 +11,42 @@ Category: Web

11Build-type: Simple

12Cabal-version: >=1.10

14−Flag Example

15− description: Enable example

16− default: False

17−

18library

14library

19 exposed-modules:

15 exposed-modules:

20− Servant.Common.BaseUrl

21− Servant.Common.Req

22 Servant.Reflex

16 Servant.Reflex

23 Servant.Reflex.Multi

17 Servant.Reflex.Multi

19+ other-modules:

20+ Servant.Common.BaseUrl

21+ Servant.Common.Req

22+

25 hs-source-dirs: src

23 hs-source-dirs: src

26 build-depends:

24 build-depends:

27− base >= 4.8 && < 5,

25+ base >= 4.8 && < 4.10,

28 bytestring >= 0.10 && < 0.11,

26 bytestring >= 0.10 && < 0.11,

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

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

30− containers >= 0.5.6 && < 0.7,

28+ containers >= 0.5.6 && < 0.6,

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

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

32− exceptions >= 0.8 && < 0.11,

30+ exceptions >= 0.8 && < 0.9,

33− ghcjs-dom >= 0.2 && < 0.10,

31+ ghcjs-dom >= 0.2 && < 0.3,

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

32+ http-api-data >= 0.2 && < 0.4,

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

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

36− jsaddle >= 0.8 && < 0.10,

37 mtl >= 2.2.1 && < 2.3,

34 mtl >= 2.2.1 && < 2.3,

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

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

39− reflex >= 0.5 && < 0.9,

36+ reflex >= 0.5 && < 0.6,

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

37+ reflex-dom == 0.4 && < 0.5,

41 safe >= 0.3.9 && < 0.4,

38 safe >= 0.3.9 && < 0.4,

42− servant >= 0.16 && < 0.18,

39+ servant >= 0.5 && < 0.9,

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

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

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

45 text >= 1.2 && < 1.3,

41 text >= 1.2 && < 1.3,

46 transformers >= 0.4 && < 0.6

42 transformers >= 0.4 && < 0.6

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

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

50 default-language: Haskell2010

46 default-language: Haskell2010

52executable example

48executable example

53− if flag(Example)

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

54− buildable: True

55− else

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

67 default-language: Haskell2010

50 default-language: Haskell2010

68 main-is: Example.hs

51 main-is: Example.hs

69 other-modules: API

52 other-modules: API

shell.nixdeleted−1

@@ -1 +0,0 @@

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

src/Servant/Common/BaseUrl.hs+8−8

@@ -20,19 +20,18 @@ module Servant.Common.BaseUrl (

20) where

22import Control.Monad (join)

23−-- import Control.Monad.IO.Class (MonadIO)

23+import Control.Monad.IO.Class (MonadIO)

24import Control.Monad.Fix (MonadFix)

25import Data.Monoid ((<>))

26import Data.Text (Text)

27import qualified Data.Text as T

28import GHC.Generics

29−import Language.Javascript.JSaddle.Monad (MonadJSM)

30import Reflex

29import Reflex

31−import Reflex.Dom.Core

30+import Reflex.Dom

32import Text.Read

31import Text.Read

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

34+type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadIO (Performable m))

37-- | URI scheme to use

36-- | URI scheme to use

38data Scheme =

37data Scheme =

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

85 where pathWidget :: m (Dynamic t BaseUrl)

84 where pathWidget :: m (Dynamic t BaseUrl)

86 pathWidget = do

85 pathWidget = do

87 text "Url base path"

86 text "Url base path"

88− t <- inputElement def

87+ t <- textInput (def {_textInputConfig_attributes =

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

89 return $ BasePath <$> value t

90 fullUrlWidget :: m (Dynamic t BaseUrl)

91 fullUrlWidget = do

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

93− srv <- inputElement def

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

94 text ":"

95− prt <- inputElement def

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

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

97− path <- inputElement def

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

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

src/Servant/Common/Req.hs+128−199

@@ -1,120 +1,65 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE CPP #-}

3{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE LambdaCase #-}

7−{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TupleSections #-}

11+{-# LANGUAGE EmptyCase #-}

11module Servant.Common.Req where

12module Servant.Common.Req where

13-------------------------------------------------------------------------------

14-------------------------------------------------------------------------------

14−import Control.Applicative (liftA2, liftA3)

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

16import Control.Concurrent

15import Control.Concurrent

16+import Control.Applicative (liftA2, liftA3)

17+import Control.Arrow (second)

17import Control.Monad (join)

18import Control.Monad (join)

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

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

19−import Data.Bifunctor (first)

20−import qualified Data.ByteString.Builder as Builder

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

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

22−import Data.ByteString (ByteString)

23import qualified Data.Map as Map

21import qualified Data.Map as Map

24−import Data.Maybe (catMaybes, fromMaybe)

22+import Data.Maybe (catMaybes)

25import Data.Functor.Compose

23import Data.Functor.Compose

26import Data.Monoid ((<>))

24import Data.Monoid ((<>))

27import Data.Proxy (Proxy(..))

25import Data.Proxy (Proxy(..))

28import Data.Text (Text)

26import Data.Text (Text)

29import qualified Data.Text as T

27import qualified Data.Text as T

30import qualified Data.Text.Encoding as TE

28import qualified Data.Text.Encoding as TE

31−import Data.Traversable (forM)

29+import Data.Traversable

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

33−import qualified Network.URI as N

34−import Reflex.Dom.Core hiding (tag)

30+import Reflex.Dom

35−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

31+import Servant.Common.BaseUrl (BaseUrl, showBaseUrl, SupportsServantReflex)

36− SupportsServantReflex)

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

32import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))

38import Web.HttpApiData (ToHttpApiData(..))

33import Web.HttpApiData (ToHttpApiData(..))

39-------------------------------------------------------------------------------

34-------------------------------------------------------------------------------

40import Servant.API.BasicAuth

35import Servant.API.BasicAuth

43−------------------------------------------------------------------------------

44−-- | The result of a request event

45−data ReqResult tag a

46− = ResponseSuccess tag a XhrResponse

47− -- ^ The succesfully decoded response from a request tagged with 'tag'

48− | ResponseFailure tag Text XhrResponse

49− -- ^ The failure response, which may have failed decoding or had

50− -- a non-successful response code

51− | RequestFailure tag Text

52− -- ^ A failure to construct the request tagged with 'tag' at trigger time

53− deriving (Functor)

54−

55−data ClientOptions = ClientOptions

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

57− -- ^ Aribtrarily modify requests just before they are sent.

58− -- Warning: This escape hatch opens the possibility for your

59− -- requests to diverge from what the server expects, when the

60− -- server is also derived from a servant API

61− }

62−

63−defaultClientOptions :: ClientOptions

64−defaultClientOptions = ClientOptions { optsRequestFixup = return }

65−

66−-- withCredentials :: Lens' (XhrRequest a) Bool

67−withCredentials :: (Show a, Functor f) => (Bool -> f Bool) -> XhrRequest a -> f (XhrRequest a)

68−withCredentials inj r@(XhrRequest _ _ cfg) =

69− let cfg' = (\b -> cfg { _xhrRequestConfig_withCredentials = b}) <$>

70− inj (_xhrRequestConfig_withCredentials cfg)

71− in (\c' -> r {_xhrRequest_config = c' }) <$> cfg'

73−------------------------------------------------------------------------------

74−-- | Simple filter/accessor for successful responses, when you want to

75−-- ignore the error case. For example:

76−-- >> goodResponses <- fmapMaybe reqSuccess <$> clientFun triggers

77−reqSuccess :: ReqResult tag a -> Maybe a

78−reqSuccess (ResponseSuccess _ x _) = Just x

39+data ReqResult a = ResponseSuccess a XhrResponse

79−reqSuccess _ = Nothing

40+ | ResponseFailure Text XhrResponse

41+ | RequestFailure Text

43+instance Functor ReqResult where

44+ fmap f (ResponseSuccess a xhr) = ResponseSuccess (f a) xhr

45+ fmap _ (ResponseFailure r x) = ResponseFailure r x

46+ fmap _ (RequestFailure r) = RequestFailure r

82−------------------------------------------------------------------------------

83−-- | Simple filter/accessor like 'reqSuccess', but keeping the request tag

84−reqSuccess' :: ReqResult tag a -> Maybe (tag,a)

48+reqSuccess :: ReqResult a -> Maybe a

85−reqSuccess' (ResponseSuccess tag x _) = Just (tag,x)

49+reqSuccess (ResponseSuccess x _) = Just x

86−reqSuccess' _ = Nothing

50+reqSuccess _ = Nothing

52+reqFailure :: ReqResult a -> Maybe Text

53+reqFailure (ResponseFailure s _) = Just s

54+reqFailure (RequestFailure s) = Just s

55+reqFailure _ = Nothing

89−------------------------------------------------------------------------------

90−-- | Simple filter/accessor for any failure case

91−reqFailure :: ReqResult tag a -> Maybe Text

57+response :: ReqResult a -> Maybe XhrResponse

92−reqFailure (ResponseFailure _ s _) = Just s

58+response (ResponseSuccess _ x) = Just x

93−reqFailure (RequestFailure _ s) = Just s

94−reqFailure _ = Nothing

95−

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)

59+response (ResponseFailure _ x) = Just x

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

101−reqFailure' _ = Nothing

60+response _ = Nothing

102

103

104−------------------------------------------------------------------------------

105−-- | Simple filter/accessor for the raw XHR response

106−response :: ReqResult tag a -> Maybe XhrResponse

107−response (ResponseSuccess _ _ x) = Just x

108−response (ResponseFailure _ _ x) = Just x

109−response _ = Nothing

110−

111−------------------------------------------------------------------------------

112−-- | Retrieve response tag

113−reqTag :: ReqResult tag a -> tag

114−reqTag (ResponseSuccess tag _ _) = tag

115−reqTag (ResponseFailure tag _ _) = tag

116−reqTag (RequestFailure tag _ ) = tag

117−

118-------------------------------------------------------------------------------

63-------------------------------------------------------------------------------

119-- | You must wrap the parameter of a QueryParam endpoint with 'QParam' to

64-- | You must wrap the parameter of a QueryParam endpoint with 'QParam' to

120-- indicate whether the parameter is valid and present, validly absent, or

65-- indicate whether the parameter is valid and present, validly absent, or

@@ -126,13 +71,11 @@ data QParam a = QParamSome a

126 | QParamInvalid Text

71 | QParamInvalid Text

127 -- ^ Indication that your validation failed (the request isn't valid)

72 -- ^ Indication that your validation failed (the request isn't valid)

128

129−

130qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)

74qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)

131qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)

75qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)

132qParamToQueryPart QNone = Right Nothing

76qParamToQueryPart QNone = Right Nothing

133qParamToQueryPart (QParamInvalid e) = Left e

77qParamToQueryPart (QParamInvalid e) = Left e

134

135−

136data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))

79data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))

137 | QueryPartParams (Dynamic t [Text])

80 | QueryPartParams (Dynamic t [Text])

138 | QueryPartFlag (Dynamic t Bool)

81 | QueryPartFlag (Dynamic t Bool)

@@ -167,7 +110,7 @@ reqToReflexRequest

167 => Text

110 => Text

168 -> Dynamic t BaseUrl

111 -> Dynamic t BaseUrl

169 -> Req t

112 -> Req t

170− -> Dynamic t (Either Text (XhrRequest XhrPayload))

113+ -> (Dynamic t (Either Text (XhrRequest XhrPayload)))

171reqToReflexRequest reqMeth reqHost req =

114reqToReflexRequest reqMeth reqHost req =

172 let t :: Dynamic t [Either Text Text]

115 let t :: Dynamic t [Either Text Text]

173 t = sequence $ reverse $ reqPathParts req

116 t = sequence $ reverse $ reqPathParts req

@@ -179,22 +122,18 @@ reqToReflexRequest reqMeth reqHost req =

179 urlParts = fmap sequence t

122 urlParts = fmap sequence t

180

123

181 urlPath :: Dynamic t (Either Text Text)

124 urlPath :: Dynamic t (Either Text Text)

182− urlPath = (fmap.fmap)

125+ urlPath = (fmap.fmap) (T.intercalate "/") urlParts

183− (T.intercalate "/" . fmap escape)

184− urlParts

185

126

186 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))

127 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))

187 queryPartString (pName, qp) = case qp of

128 queryPartString (pName, qp) = case qp of

188 QueryPartParam p -> ffor p $ \case

129 QueryPartParam p -> ffor p $ \case

189 Left e -> Just (Left e)

130 Left e -> Just (Left e)

190− Right (Just a) -> Just (Right $ pName <> "=" <> escape a)

131+ Right (Just a) -> Just (Right $ pName <> "=" <> a)

191 Right Nothing -> Nothing

132 Right Nothing -> Nothing

192 QueryPartParams ps -> ffor ps $ \pStrings ->

133 QueryPartParams ps -> ffor ps $ \pStrings ->

193 if null pStrings

134 if null pStrings

194 then Nothing

135 then Nothing

195− else Just . Right

196− . T.intercalate "&"

197− $ fmap (\p -> pName <> "=" <> escape p) pStrings

136+ else Just $ Right (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) pStrings))

198 QueryPartFlag fl -> ffor fl $ \case

137 QueryPartFlag fl -> ffor fl $ \case

199 True -> Just $ Right pName

138 True -> Just $ Right pName

200 False -> Nothing

139 False -> Nothing

@@ -229,10 +168,10 @@ reqToReflexRequest reqMeth reqHost req =

229 Right $ XhrRequestConfig

168 Right $ XhrRequestConfig

230 { _xhrRequestConfig_sendData = bytesToPayload bBytes

169 { _xhrRequestConfig_sendData = bytesToPayload bBytes

231 , _xhrRequestConfig_headers =

170 , _xhrRequestConfig_headers =

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

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

233 , _xhrRequestConfig_user = Nothing

172 , _xhrRequestConfig_user = Nothing

234 , _xhrRequestConfig_password = Nothing

173 , _xhrRequestConfig_password = Nothing

235− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

174+ , _xhrRequestConfig_responseType = Nothing

236 , _xhrRequestConfig_withCredentials = False

175 , _xhrRequestConfig_withCredentials = False

237 , _xhrRequestConfig_responseHeaders = def

176 , _xhrRequestConfig_responseHeaders = def

238 }

177 }

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

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

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

245 , _xhrRequestConfig_user = Nothing

184 , _xhrRequestConfig_user = Nothing

246 , _xhrRequestConfig_password = Nothing

185 , _xhrRequestConfig_password = Nothing

247− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

186+ , _xhrRequestConfig_responseType = Nothing

248− , _xhrRequestConfig_sendData = mempty

187+ , _xhrRequestConfig_sendData = ""

249 , _xhrRequestConfig_withCredentials = False

188 , _xhrRequestConfig_withCredentials = False

250 }

189 }

251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

190 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

@@ -272,55 +211,41 @@ reqToReflexRequest reqMeth reqHost req =

272displayHttpRequest :: Text -> Text

211displayHttpRequest :: Text -> Text

273displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

212displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

274

213

275−-- | This function performs the request

214+-- | This function actually performs the request.

276performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)

215performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)

277 => Text

216 => Text

278 -> Dynamic t (f (Req t))

217 -> Dynamic t (f (Req t))

279 -> Dynamic t BaseUrl

218 -> Dynamic t BaseUrl

280− -> ClientOptions

281 -> Event t tag

219 -> Event t tag

282 -> m (Event t (tag, f (Either Text XhrResponse)))

220 -> m (Event t (tag, f (Either Text XhrResponse)))

283−performRequests reqMeth rs reqHost opts trigger = do

221+performRequests reqMeth rs reqHost trigger = do

284− let xhrReqs =

222+ -- let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))

285− join $ (\(fxhr :: f (Req t)) -> sequence $

286− reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs

223+ let xhrReqs = join $ (\(fxhr :: f (Req t)) -> sequence $ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs

287−

288− -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

289− reqs = attachPromptlyDynWith

290− (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger

224+ let reqs = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger

291−

292− resps <- performSomeRequestsAsync opts reqs

225+ resps <- performSomeRequestsAsync reqs

293 return $ getCompose <$> resps

226 return $ getCompose <$> resps

294

227

295−-- | Issues a collection of requests when the supplied Event fires.

228+-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.

296−-- When ALL requests from a given firing complete, the results are

297−-- collected and returned via the return Event.

298performSomeRequestsAsync

229performSomeRequestsAsync

299 :: (MonadIO (Performable m),

230 :: (MonadIO (Performable m),

300− MonadJSM (Performable m),

301 HasWebView (Performable m),

231 HasWebView (Performable m),

302 PerformEvent t m,

232 PerformEvent t m,

303 TriggerEvent t m,

233 TriggerEvent t m,

304 Traversable f,

234 Traversable f,

305− IsXhrPayload a,

235+ IsXhrPayload a)

306− Show a

307− )

308− => ClientOptions

309− -> Event t (f (Either Text (XhrRequest a)))

236+ => Event t (f (Either Text (XhrRequest a)))

310 -> m (Event t (f (Either Text XhrResponse)))

237 -> m (Event t (f (Either Text XhrResponse)))

311−performSomeRequestsAsync opts =

312− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

238+performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return

313

239

314

240

315------------------------------------------------------------------------------

241------------------------------------------------------------------------------

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

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

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

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

318performSomeRequestsAsync'

244performSomeRequestsAsync'

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

245+ :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)

320− => ClientOptions

321− -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)

246+ => (XhrRequest b -> (a -> IO ()) -> Performable m XMLHttpRequest)

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

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

323−performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do

248+performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do

324 rs <- hrs

249 rs <- hrs

325 resps <- forM rs $ \r -> case r of

250 resps <- forM rs $ \r -> case r of

326 Left e -> do

251 Left e -> do

@@ -328,92 +253,103 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs

328 return resp

253 return resp

329 Right r' -> do

254 Right r' -> do

330 resp <- liftIO newEmptyMVar

255 resp <- liftIO newEmptyMVar

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

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

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

333 return resp

257 return resp

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

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

335 return ()

259 return ()

336

260

337

261

338

262

339−type XhrPayload = ByteString

263+-- | This function actually performs the request.

340−bytesToPayload :: BL.ByteString -> XhrPayload

264+performRequest :: forall t m tag .(SupportsServantReflex t m)

341−bytesToPayload = BL.toStrict

265+ => Text

266+ -> (Req t)

267+ -> Dynamic t BaseUrl

268+ -> Event t tag

269+ -> m (Event t (tag, XhrResponse), Event t (tag, Text))

270+performRequest reqMeth req reqHost trigger = do

342

271

272+ let xhrReq = reqToReflexRequest reqMeth reqHost req

273+ let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger

274+ okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) e) reqs

275+ badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) e) reqs

343

276

344−performRequestsCT

277+ resps <- performRequestsAsync okReqs

278+

279+ return (resps, badReqs)

280+

281+

282+#ifdef ghcjs_HOST_OS

283+type XhrPayload = String

284+bytesToPayload :: BL.ByteString -> XhrPayload

285+bytesToPayload = BL.unpack

286+#else

287+type XhrPayload = T.Text

288+bytesToPayload :: BL.ByteString -> XhrPayload

289+bytesToPayload = T.pack . BL.unpack

290+#endif

291+

292+performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)

293+ => Text

294+ -> Req t

295+ -> Dynamic t BaseUrl

296+ -> Event t tag -> m (Event t (tag, ReqResult NoContent))

297+performRequestNoBody reqMeth req reqHost trigger = do

298+ (resp, badReq) <- performRequest reqMeth req reqHost trigger

299+ return $ leftmost [ fmap (ResponseSuccess NoContent) <$> resp, fmap RequestFailure <$> badReq]

300+

301+performRequestsNoBody :: forall t m f tag. (SupportsServantReflex t m, Traversable f)

302+ => Text

303+ -> Dynamic t (f (Req t))

304+ -> Dynamic t BaseUrl

305+ -> Event t tag -> m (Event t (tag, f (ReqResult NoContent)))

306+performRequestsNoBody reqMeth reqs reqHost trigger = do

307+ resp <- performRequests reqMeth reqs reqHost trigger

308+ return $ (fmap . fmap) aux <$> resp

309+ where

310+ aux (Right x) = ResponseSuccess NoContent x

311+ aux (Left e) = RequestFailure e

312+ -- return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]

313+

314+

315+performRequestCT

345 :: (SupportsServantReflex t m,

316 :: (SupportsServantReflex t m,

346− MimeUnrender ct a, Traversable f)

317+ MimeUnrender ct a)

347 => Proxy ct

318 => Proxy ct

348 -> Text

319 -> Text

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

320+ -> Req t

350 -> Dynamic t BaseUrl

321 -> Dynamic t BaseUrl

351− -> ClientOptions

352 -> Event t tag

322 -> Event t tag

353− -> m (Event t (f (ReqResult tag a)))

323+ -> m (Event t (tag, ReqResult a))

354−performRequestsCT ct reqMeth reqs reqHost opts trigger = do

324+performRequestCT ct reqMeth req reqHost trigger = do

355− resps <- performRequests reqMeth reqs reqHost opts trigger

325+ (resp, badReq) <- performRequest reqMeth req reqHost trigger

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

326+ let decodes = ffor resp $ fmap (\xhr ->

357− first T.pack .

358− mimeUnrender ct $

327+ ((mimeUnrender ct . BL.fromStrict . TE.encodeUtf8)

359− BL.fromStrict x

328+ =<< note "No body text" (_xhrResponse_responseText xhr), xhr))

360− decodeResp _ = Left "No body"

329+ reqs = ffor decodes $ fmap (\case

361− return $ fmap

330+ (Right a, r) -> ResponseSuccess a r

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

331+ (Left e, r) -> ResponseFailure (T.pack e) r)

363− Left e -> RequestFailure t e

332+ return $ leftmost [reqs, fmap RequestFailure <$> badReq]

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

333+

365− )

334+performRequestsCT

366− resps

367−

368−

369−performRequestsNoBody

370 :: (SupportsServantReflex t m,

335 :: (SupportsServantReflex t m,

371− Traversable f)

336+ MimeUnrender ct a, Traversable f)

337+ => Proxy ct

372− => Text

338+ -> Text

373 -> Dynamic t (f (Req t))

339 -> Dynamic t (f (Req t))

374 -> Dynamic t BaseUrl

340 -> Dynamic t BaseUrl

375− -> ClientOptions

376 -> Event t tag

341 -> Event t tag

377− -> m (Event t (f (ReqResult tag NoContent)))

342+ -> m (Event t (tag, f (ReqResult a)))

378−performRequestsNoBody reqMeth reqs reqHost opts trigger = do

343+performRequestsCT ct reqMeth reqs reqHost trigger = do

379− resps <- performRequests reqMeth reqs reqHost opts trigger

344+ resps <- performRequests reqMeth reqs reqHost trigger

380− let decodeResp = const $ Right NoContent

345+ return $ fmap (second (fmap reqToResult)) resps

381− return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of

346+ where

382− Left e -> RequestFailure tag e

347+ reqToResult (Left e) = RequestFailure e

383− Right g -> evalResponse decodeResp (tag,g)

348+ reqToResult (Right x) = case _xhrResponse_responseText x of

384−

349+ Nothing -> ResponseFailure "No request body" x

385−

350+ Just bod -> case mimeUnrender ct . BL.fromStrict . TE.encodeUtf8 $ bod of

386−------------------------------------------------------------------------------

351+ Left e -> ResponseFailure (T.pack e) x

387−evalResponse

388− :: (XhrResponse -> Either Text a)

389− -> (tag, XhrResponse)

390− -> ReqResult tag a

391−evalResponse decode (tag, xhr) =

392− let status = _xhrResponse_status xhr

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

394− errMsg = fromMaybe

395− ("Empty response with error code " <>

396− T.pack (show $ _xhrResponse_status xhr))

397− (_xhrResponse_responseText xhr)

398− respPayld = if okStatus

399− then either

400− (\e -> ResponseFailure tag e xhr)

401− (\v -> ResponseSuccess tag v xhr)

352+ Right v -> ResponseSuccess v x

402− (decode xhr)

403− else ResponseFailure tag errMsg xhr

404− in respPayld

405−

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

353

418

354

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

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

@@ -422,10 +358,3 @@ note e = maybe (Left e) Right

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

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

423fmapL _ (Right a) = Right a

359fmapL _ (Right a) = Right a

424fmapL f (Left e) = Left (f e)

360fmapL f (Left e) = Left (f e)

425−

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

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

428−

429−escape :: T.Text -> T.Text

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

431−

src/Servant/Reflex.hs+107−216

@@ -1,23 +1,17 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

2+{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7−{-# LANGUAGE InstanceSigs #-}

6+{-# LANGUAGE InstanceSigs #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE OverloadedStrings #-}

10−{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE PolyKinds #-}

11−{-# LANGUAGE Rank2Types #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE TupleSections #-}

10+{-# LANGUAGE TupleSections #-}

14−{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeFamilies #-}

15−{-# LANGUAGE TypeOperators #-}

12+{-# LANGUAGE TypeOperators #-}

16−{-# LANGUAGE UndecidableInstances #-}

13+{-# LANGUAGE UndecidableInstances #-}

17−

14+{-# LANGUAGE MultiParamTypeClasses #-}

18−#if MIN_VERSION_base(4,9,0)

19−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

20−#endif

22-- #include "overlapping-compat.h"

16-- #include "overlapping-compat.h"

23-- | This module provides 'client' which can automatically generate

17-- | This module provides 'client' which can automatically generate

@@ -25,71 +19,56 @@

25-- API.

19-- API.

26module Servant.Reflex

20module Servant.Reflex

27 ( client

21 ( client

28− , clientWithOpts

29− , clientWithOptsAndResultHandler

30− , clientWithRoute

31− , clientWithRouteAndResultHandler

32 , BuildHeaderKeysTo(..)

22 , BuildHeaderKeysTo(..)

33 , toHeaders

23 , toHeaders

34− , HasClient

24+ , HasClient(..)

35− , Client

36 , module Servant.Common.Req

25 , module Servant.Common.Req

37 , module Servant.Common.BaseUrl

26 , module Servant.Common.BaseUrl

38 ) where

27 ) where

40------------------------------------------------------------------------------

29------------------------------------------------------------------------------

41import Control.Applicative

30import Control.Applicative

42−import qualified Data.CaseInsensitive as CI

43−import Data.Functor.Identity

44−import qualified Data.Map as Map

45import Data.Monoid ((<>))

31import Data.Monoid ((<>))

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

47import qualified Data.Set as Set

32import qualified Data.Set as Set

33+import qualified Data.Text.Encoding as E

34+import Data.CaseInsensitive (mk)

35+import Data.Proxy (Proxy (..))

36+import qualified Data.Map as Map

48import Data.Text (Text)

37import Data.Text (Text)

49import qualified Data.Text as T

38import qualified Data.Text as T

50−import qualified Data.Text.Encoding as E

51−import GHC.Exts (Constraint)

52import GHC.TypeLits (KnownSymbol, symbolVal)

39import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

54− BasicAuthData, BuildHeadersTo (..),

41+ BasicAuthData, BuildHeadersTo(..),

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

42+ Capture, contentType, Header,

56− HttpVersion, IsSecure,

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

57− MimeRender (..), MimeUnrender,

44+ MimeRender(..), MimeUnrender,

58 NoContent, QueryFlag, QueryParam,

45 NoContent, QueryFlag, QueryParam,

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

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

60 RemoteHost, ReqBody,

47 RemoteHost, ReqBody,

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

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

62− contentType)

49+

63−import Servant.API.Description (Summary)

64−import qualified Servant.Auth as Auth

65−

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

50+import Reflex.Dom (Dynamic, Event, Reflex,

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

51+ XhrRequest(..),

68− XhrResponseHeaders (..),

52+ XhrResponseHeaders(..),

69− attachPromptlyDynWith, constDyn, ffor,

53+ XhrResponse(..), attachPromptlyDynWith, ffor, fmapMaybe,

70− fmapMaybe, leftmost,

71− performRequestsAsync)

54+ leftmost, performRequestsAsync,

55+ )

72------------------------------------------------------------------------------

56------------------------------------------------------------------------------

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

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

74 showBaseUrl,

58 showBaseUrl,

75 SupportsServantReflex)

59 SupportsServantReflex)

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

77− defaultClientOptions,

78− Req, ReqResult(..), QParam(..),

60+import Servant.Common.Req (Req, ReqResult(..), QParam(..),

79 QueryPart(..), addHeader, authData,

61 QueryPart(..), addHeader, authData,

80− defReq, evalResponse, prependToPathParts,

62+ defReq, prependToPathParts,

81− -- performRequestCT,

63+ performRequestCT,

82 performRequestsCT,

64 performRequestsCT,

83− -- performRequestNoBody,

65+ performRequestNoBody,

84 performRequestsNoBody,

66 performRequestsNoBody,

85 performSomeRequestsAsync,

67 performSomeRequestsAsync,

86 qParamToQueryPart, reqBody,

68 qParamToQueryPart, reqBody,

87 reqSuccess, reqFailure,

69 reqSuccess, reqFailure,

88− reqMethod, respHeaders,

70+ reqMethod, respHeaders, response,

89− response,

90− reqTag,

91− qParams, withCredentials)

71+ qParams)

92−

94-- * Accessing APIs as a Client

73-- * Accessing APIs as a Client

@@ -103,75 +82,28 @@ import Servant.Common.Req (ClientOptions(..),

103-- >

82-- >

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

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

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

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

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

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

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

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

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

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

109−client

110− :: (HasClient t m layout tag)

88+client :: (HasClient t m layout tag)

111− => Proxy layout

112− -> Proxy m

113− -> Proxy tag

114− -> Dynamic t BaseUrl

115− -> Client t m layout tag

116−client p q t baseurl = clientWithRoute p q t defReq baseurl defaultClientOptions

117−

118−clientWithOpts

119− :: (HasClient t m layout tag)

120− => Proxy layout

121− -> Proxy m

122− -> Proxy tag

123− -> Dynamic t BaseUrl

124− -> ClientOptions

125− -> Client t m layout tag

89+ => Proxy layout -> Proxy m -> Proxy tag -> Dynamic t BaseUrl -> Client t m layout tag

126−clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl

90+client p q t baseurl = clientWithRoute p q t defReq baseurl

127−

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

142

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

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

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

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

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

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

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

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

147 type Client t m layout tag :: *

97 type Client t m layout tag :: *

148− clientWithRoute

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

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

167

168

100

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

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

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

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

171

103

172− clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =

104+ clientWithRoute Proxy q pTag req baseurl =

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

105+ clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>

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

106+ clientWithRoute (Proxy :: Proxy b) q pTag req baseurl

175

107

176

108

177-- Capture. Example:

109-- Capture. Example:

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

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

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

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

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

194

126

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

127+ clientWithRoute Proxy q t req baseurl val =

196− clientWithRouteAndResultHandler

128+ clientWithRoute (Proxy :: Proxy sublayout)

129+ q t

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

130+ (prependToPathParts p req)

131+ baseurl

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

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

199

133

200

134

@@ -204,11 +138,11 @@ instance {-# OVERLAPPABLE #-}

204 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m

138 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m

205 ) => HasClient t m (Verb method status cts' a) tag where

139 ) => HasClient t m (Verb method status cts' a) tag where

206 type Client t m (Verb method status cts' a) tag =

140 type Client t m (Verb method status cts' a) tag =

207− Event t tag -> m (Event t (ReqResult tag a))

141+ Event t tag -> m (Event t (tag, ReqResult a))

208 -- TODO how to access input types here?

142 -- TODO how to access input types here?

209 -- ExceptT ServantError IO a

143 -- ExceptT ServantError IO a

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

144+ clientWithRoute Proxy _ _ req baseurl trigs =

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

145+ performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs

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

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

213 req' = req { reqMethod = method }

147 req' = req { reqMethod = method }

214

148

@@ -218,36 +152,32 @@ instance {-# OVERLAPPING #-}

218 (ReflectMethod method, SupportsServantReflex t m) =>

152 (ReflectMethod method, SupportsServantReflex t m) =>

219 HasClient t m (Verb method status cts NoContent) tag where

153 HasClient t m (Verb method status cts NoContent) tag where

220 type Client t m (Verb method status cts NoContent) tag =

154 type Client t m (Verb method status cts NoContent) tag =

221− Event t tag -> m (Event t (ReqResult tag NoContent))

155+ Event t tag -> m (Event t (tag, ReqResult NoContent))

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

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

223 -- ExceptT ServantError IO NoContent

157 -- ExceptT ServantError IO NoContent

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

158+ clientWithRoute Proxy _ _ req baseurl =

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

159+ performRequestNoBody method req baseurl

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

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

227

161

228

162

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

163+toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)

230toHeaders r =

164toHeaders r =

165+ let toBS = E.encodeUtf8

231− let hdrs = maybe []

166+ hdrs = maybe []

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

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

233 (Map.toList $ _xhrResponse_headers xhr))

168 (Map.toList $ _xhrResponse_headers xhr))

234 (response r)

169 (response r)

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

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

236

171

237−

238class BuildHeaderKeysTo hs where

172class BuildHeaderKeysTo hs where

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

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

240

174

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

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

242 where buildHeaderKeysTo _ = []

176 where buildHeaderKeysTo _ = []

243

177

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

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

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

179+ => 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)

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

250−

251

181

252-- HEADERS Verb (Content) --

182-- HEADERS Verb (Content) --

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

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

@@ -261,11 +191,11 @@ instance {-# OVERLAPPABLE #-}

261 SupportsServantReflex t m

191 SupportsServantReflex t m

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

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

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

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

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

194+ Event t tag -> m (Event t (tag, ReqResult (Headers ls a)))

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

195+ clientWithRoute Proxy _ _ req baseurl = do

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

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

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

197+ resp <- performRequestCT (Proxy :: Proxy ct) method req' baseurl

268− wrap $ toHeaders <$> resp

198+ return $ (fmap . fmap) toHeaders <$> resp

269 where req' = req { respHeaders =

199 where req' = req { respHeaders =

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

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

271 }

201 }

@@ -277,11 +207,11 @@ instance {-# OVERLAPPABLE #-}

277 SupportsServantReflex t m

207 SupportsServantReflex t m

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

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

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

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

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

210+ = Event t tag -> m (Event t (tag, ReqResult (Headers ls NoContent)))

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

211+ clientWithRoute Proxy _ _ req baseurl = do

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

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

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

213+ resp <- performRequestNoBody method req' baseurl

284− wrap $ toHeaders <$> resp

214+ return $ (fmap . fmap) toHeaders <$> resp

285 where req' = req {respHeaders =

215 where req' = req {respHeaders =

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

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

287 }

217 }

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

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

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

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

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

310

240

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

241+ clientWithRoute Proxy q t req baseurl eVal =

312− clientWithRouteAndResultHandler

313− (Proxy :: Proxy sublayout) q t

242+ clientWithRoute (Proxy :: Proxy sublayout)

243+ q t

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

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

315− baseurl opts wrap

245+ baseurl

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

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

317

247

318

248

@@ -326,20 +256,8 @@ instance HasClient t m sublayout tag

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

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

327 Client t m sublayout tag

257 Client t m sublayout tag

328

258

329− clientWithRouteAndResultHandler Proxy =

259+ clientWithRoute Proxy q t =

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)

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

342−

343

261

344

262

345

263

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

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

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

377

295

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

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

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

297+ clientWithRoute Proxy q t req baseurl mparam =

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

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

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

299+ (req {qParams = paramPair : qParams req}) baseurl

382

300

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

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

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

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

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

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

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

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

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

424

342

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

343+ clientWithRoute Proxy q t req baseurl paramlist =

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

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

427

345

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

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

429 pname = symbolVal (Proxy :: Proxy sym)

347 pname = symbolVal (Proxy :: Proxy sym)

430− params' = QueryPartParams $ (fmap . fmap) toQueryParam

348+ params' = QueryPartParams $ (fmap . fmap) (toQueryParam)

431 paramlist

349 paramlist

432

350

433

351

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

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

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

463 Dynamic t Bool -> Client t m sublayout tag

381 Dynamic t Bool -> Client t m sublayout tag

464

382

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

383+ clientWithRoute Proxy q t req baseurl flag =

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

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

467

385

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

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

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

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

@@ -475,9 +393,9 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)

475instance SupportsServantReflex t m => HasClient t m Raw tag where

393instance SupportsServantReflex t m => HasClient t m Raw tag where

476 type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))

394 type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))

477 -> Event t tag

395 -> Event t tag

478− -> m (Event t (ReqResult tag ()))

396+ -> m (Event t (tag, ReqResult ()))

479

397

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

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

481

399

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

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

483 Left e -> Left e

401 Left e -> Left e

@@ -488,9 +406,8 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where

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

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

489

407

490 resps <- performRequestsAsync okReq

408 resps <- performRequestsAsync okReq

409+ return $ leftmost [ fmap (ResponseSuccess ()) <$> resps

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

410+ , fmap (RequestFailure) <$> badReq ]

492− , evalResponse (const $ Right ()) <$> resps

493− ]

494

411

495

412

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

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

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

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

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

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

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

521

438

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

439+ clientWithRoute Proxy q t req baseurl body =

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

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

524 where req' = req { reqBody = bodyBytesCT }

441 where req' = req { reqBody = bodyBytesCT }

525 ctProxy = Proxy :: Proxy ct

442 ctProxy = Proxy :: Proxy ct

526 ctString = T.pack $ show $ contentType ctProxy

443 ctString = T.pack $ show $ contentType ctProxy

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

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

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

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

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

536

453

537− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =

454+ clientWithRoute Proxy q t req baseurl =

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

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

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

456+ (prependToPathParts (pure (Right $ T.pack p)) req)

457+ baseurl

540

458

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

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

542

460

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

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

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

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

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

546

464

547− clientWithRouteAndResultHandler Proxy =

465+ clientWithRoute Proxy q t req baseurl =

548− clientWithRouteAndResultHandler (Proxy :: Proxy api)

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

549

467

550

468

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

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

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

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

553

471

554− clientWithRouteAndResultHandler Proxy =

472+ clientWithRoute Proxy q t req baseurl =

555− clientWithRouteAndResultHandler (Proxy :: Proxy api)

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

556

474

557

475

558

476

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

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

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

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

561

479

562− clientWithRouteAndResultHandler Proxy =

480+ clientWithRoute Proxy q t req baseurl =

563− clientWithRouteAndResultHandler (Proxy :: Proxy api)

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

564

482

565

483

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

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

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

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

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

570 -> Client t m api tag

488 -> Client t m api tag

571

489

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

490+ clientWithRoute Proxy q t req baseurl authdata =

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

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

574 where

492 where

575 req' = req { authData = Just authdata }

493 req' = req { authData = Just authdata }

576

494

@@ -596,30 +514,3 @@ non-empty lists, but is otherwise more specific, no instance will be overall

596more specific. This in turn generally means adding yet another instance (one

514more specific. This in turn generally means adding yet another instance (one

597for empty and one for non-empty lists).

515for empty and one for non-empty lists).

598-}

516-}

599−

600−

601−-- SUPPORT FOR servant-auth --

602−

603−-- For JavaScript clients we should be sending/storing JSON web tokens in a

604−-- way that is inaccessible to JavaScript.

605−--

606−-- For @servant-auth@ this is done with HTTP-only cookies. In a Reflex-DOM

607−-- app this means the @servant-auth@ client should only verify that the API

608−-- supports Cookie-based authentication but do nothing with the token

609−-- directly.

610−

611−-- @HasCookieAuth auths@ is nominally a redundant constraint, but ensures

612−-- we're not trying to rely on cookies when the API does not use them.

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

614−

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

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

617−

618−

619−type family HasCookieAuth xs :: Constraint where

620− HasCookieAuth (Auth.Cookie ': xs) = ()

621− HasCookieAuth (x ': xs) = HasCookieAuth xs

622− HasCookieAuth '[] = CookieAuthNotEnabled

623−

624−class CookieAuthNotEnabled

625−

src/Servant/Reflex/Multi.hs+96−126

@@ -1,82 +1,69 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

2+{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE InstanceSigs #-}

6+{-# LANGUAGE InstanceSigs #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TupleSections #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE UndecidableInstances #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

14{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE OverloadedStrings #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TupleSections #-}

12−{-# LANGUAGE TypeFamilies #-}

13−{-# LANGUAGE TypeOperators #-}

14−{-# LANGUAGE UndecidableInstances #-}

15−

16−module Servant.Reflex.Multi (

17− -- * Compute servant client functions

18− clientA

19− , clientWithOptsA

20− , BaseUrl(..)

21− , Scheme(..)

22−

23− -- * Build QueryParam arguments

24− , QParam(..)

25−

26− -- * Access response data

27− , withCredentials

28−

29− -- * Access response data

30− , ReqResult(..)

31− , reqSuccess

32− , reqSuccess'

33− , reqFailure

34− , response

16+module Servant.Reflex.Multi

17+ ( clientA

36 , HasClientMulti(..)

18 , HasClientMulti(..)

37 ) where

19 ) where

39------------------------------------------------------------------------------

21------------------------------------------------------------------------------

40−import Control.Applicative (liftA2)

22+import Control.Applicative

23+import Control.Arrow (second)

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

24+import Data.Functor.Compose

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

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

43import qualified Data.Set as Set

26import qualified Data.Set as Set

27+import qualified Data.Text.Encoding as E

28+import Data.CaseInsensitive (mk)

29+import Data.Proxy (Proxy (..))

30+import qualified Data.Map as Map

44import Data.Text (Text)

31import Data.Text (Text)

45import qualified Data.Text as T

32import qualified Data.Text as T

46−import qualified Data.Text.Encoding as E

47import GHC.TypeLits (KnownSymbol, symbolVal)

33import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

49− BasicAuthData, BuildHeadersTo (..),

35+ BasicAuthData, BuildHeadersTo(..),

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

36+ Capture, contentType, Header,

51− HttpVersion, IsSecure,

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

52− MimeRender (..), MimeUnrender,

38+ MimeRender(..), MimeUnrender,

53 NoContent, QueryFlag, QueryParam,

39 NoContent, QueryFlag, QueryParam,

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

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

55 RemoteHost, ReqBody,

41 RemoteHost, ReqBody,

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

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

57− contentType)

43+

58−import Servant.API.Description (Summary)

59−

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

44+import Reflex.Dom (Dynamic, Event, Reflex,

61− XhrRequest (..),

45+ XhrRequest(..),

62− XhrResponseHeaders (..),

46+ XhrResponseHeaders(..),

63− attachPromptlyDynWith, constDyn)

47+ XhrResponse(..), constDyn, ffor, fmapMaybe,

48+ leftmost, performRequestAsync, attachPromptlyDynWith,

49+ tagPromptlyDyn )

64------------------------------------------------------------------------------

50------------------------------------------------------------------------------

65−import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),

51+import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,

52+ showBaseUrl,

66− SupportsServantReflex)

53+ SupportsServantReflex)

67−import Servant.Common.Req (ClientOptions,

54+import Servant.Common.Req (Req, ReqResult(..), QParam(..),

68− QParam (..), QueryPart (..), Req,

69− ReqResult (..), addHeader, authData,

55+ QueryPart(..), addHeader, authData,

70− defReq,

56+ defReq, prependToPathParts,

71− defaultClientOptions,

57+ performRequestCT,

72− performRequestsCT,

58+ performRequestsCT,

59+ performRequestNoBody,

73− performRequestsNoBody,

60+ performRequestsNoBody,

74− performSomeRequestsAsync,

61+ performSomeRequestsAsync,

75− prependToPathParts, qParamToQueryPart,

62+ qParamToQueryPart, reqBody,

76− qParams, reqBody, reqFailure,

63+ reqSuccess, reqFailure,

77− reqMethod, reqSuccess, reqSuccess',

78− respHeaders, response, withCredentials)

64+ reqMethod, respHeaders, response,

65+ qParams)

79−import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)

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

82------------------------------------------------------------------------------

69------------------------------------------------------------------------------

@@ -85,24 +72,14 @@ clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)

85 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag

72 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag

86clientA p q f tag baseurl =

73clientA p q f tag baseurl =

87 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl

74 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl

88− defaultClientOptions

89−

91−-- | A version of @client@ that sets the withCredentials flag

92−-- on requests. Use this function for clients of CORS API's

93−clientWithOptsA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)

94− => Proxy layout -> Proxy m -> Proxy f -> Proxy tag

95− -> Dynamic t BaseUrl -> ClientOptions -> ClientMulti t m layout f tag

96−clientWithOptsA p q f tag baseurl opts =

97− clientWithRouteMulti p q f tag

98− (constDyn (pure defReq)) baseurl opts

100------------------------------------------------------------------------------

77------------------------------------------------------------------------------

101class HasClientMulti t m layout f (tag :: *) where

78class HasClientMulti t m layout f (tag :: *) where

102 type ClientMulti t m layout f tag :: *

79 type ClientMulti t m layout f tag :: *

103 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag

80 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag

104 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl

81 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl

105− -> ClientOptions -> ClientMulti t m layout f tag

82+ -> ClientMulti t m layout f tag

106

107

108------------------------------------------------------------------------------

85------------------------------------------------------------------------------

@@ -110,9 +87,9 @@ instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>

110 HasClientMulti t m (a :<|> b) f tag where

87 HasClientMulti t m (a :<|> b) f tag where

111 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>

88 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>

112 ClientMulti t m b f tag

89 ClientMulti t m b f tag

113− clientWithRouteMulti Proxy q f tag reqs baseurl opts =

90+ clientWithRouteMulti Proxy q f tag reqs baseurl =

114− clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>

91+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl :<|>

115− clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts

92+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl

116

117

118------------------------------------------------------------------------------

95------------------------------------------------------------------------------

@@ -125,8 +102,7 @@ instance (SupportsServantReflex t m,

125 type ClientMulti t m (Capture capture a :> sublayout) f tag =

102 type ClientMulti t m (Capture capture a :> sublayout) f tag =

126 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag

103 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag

127

104

128− clientWithRouteMulti _ q f tag reqs baseurl opts vals =

129− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts

105+ clientWithRouteMulti l q f tag reqs baseurl vals = clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

130 where

106 where

131 reqs' = (prependToPathParts <$> ps <*>) <$> reqs

107 reqs' = (prependToPathParts <$> ps <*>) <$> reqs

132 ps = (fmap . fmap . fmap) toUrlPiece vals

108 ps = (fmap . fmap . fmap) toUrlPiece vals

@@ -144,10 +120,10 @@ instance {-# OVERLAPPABLE #-}

144 ) => HasClientMulti t m (Verb method status cts' a) f tag where

120 ) => HasClientMulti t m (Verb method status cts' a) f tag where

145

121

146 type ClientMulti t m (Verb method status cts' a) f tag =

122 type ClientMulti t m (Verb method status cts' a) f tag =

147− Event t tag -> m (Event t (f (ReqResult tag a)))

123+ Event t tag -> m (Event t (tag, f (ReqResult a)))

148

124

149− clientWithRouteMulti _ _ _ _ reqs baseurl opts =

125+ clientWithRouteMulti _ _ f tag reqs baseurl =

150− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts

126+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl

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

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

152 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs

128 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs

153

129

@@ -158,11 +134,11 @@ instance {-# OVERLAPPING #-}

158 (ReflectMethod method, SupportsServantReflex t m, Traversable f) =>

134 (ReflectMethod method, SupportsServantReflex t m, Traversable f) =>

159 HasClientMulti t m (Verb method status cts NoContent) f tag where

135 HasClientMulti t m (Verb method status cts NoContent) f tag where

160 type ClientMulti t m (Verb method status cts NoContent) f tag =

136 type ClientMulti t m (Verb method status cts NoContent) f tag =

161− Event t tag -> m (Event t (f (ReqResult tag NoContent)))

137+ Event t tag -> m (Event t (tag, f (ReqResult NoContent)))

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

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

163 -- ExceptT ServantError IO NoContent

139 -- ExceptT ServantError IO NoContent

164− clientWithRouteMulti Proxy _ _ _ req baseurl opts =

140+ clientWithRouteMulti Proxy _ _ tag req baseurl =

165− performRequestsNoBody method req baseurl opts

141+ performRequestsNoBody method req baseurl

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

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

167

143

168

144

@@ -175,11 +151,11 @@ instance {-# OVERLAPPABLE #-}

175 Traversable f

151 Traversable f

176 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where

152 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where

177 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =

153 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =

178− Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))

154+ Event t tag -> m (Event t (tag, f (ReqResult (Headers ls a))))

179− clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do

155+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do

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

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

181− resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))

157+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl triggers :: m (Event t (tag, f (ReqResult a)))

182− return $ fmap toHeaders <$> resp

158+ return $ (fmap . fmap) toHeaders <$> resp

183 where

159 where

184 reqs' = fmap (\r ->

160 reqs' = fmap (\r ->

185 r { respHeaders =

161 r { respHeaders =

@@ -198,11 +174,11 @@ instance {-# OVERLAPPABLE #-}

198 ) => HasClientMulti t m (Verb method status

174 ) => HasClientMulti t m (Verb method status

199 cts (Headers ls NoContent)) f tag where

175 cts (Headers ls NoContent)) f tag where

200 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag

176 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag

201− = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))

177+ = Event t tag -> m (Event t (tag, f (ReqResult (Headers ls NoContent))))

202− clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do

178+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do

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

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

204− resp <- performRequestsNoBody method reqs' baseurl opts triggers

180+ resp <- performRequestsNoBody method reqs' baseurl triggers

205− return $ fmap toHeaders <$> resp

181+ return $ (fmap . fmap) toHeaders <$> resp

206 where reqs' = fmap (\req ->

182 where reqs' = fmap (\req ->

207 req {respHeaders = OnlyHeaders (Set.fromList

183 req {respHeaders = OnlyHeaders (Set.fromList

208 (buildHeaderKeysTo (Proxy :: Proxy ls)))

184 (buildHeaderKeysTo (Proxy :: Proxy ls)))

@@ -221,11 +197,11 @@ instance (KnownSymbol sym,

221 type ClientMulti t m (Header sym a :> sublayout) f tag =

197 type ClientMulti t m (Header sym a :> sublayout) f tag =

222 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag

198 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag

223

199

224− clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =

200+ clientWithRouteMulti Proxy f q tag reqs baseurl eVals =

225 clientWithRouteMulti (Proxy :: Proxy sublayout) f

201 clientWithRouteMulti (Proxy :: Proxy sublayout) f

226 q tag

202 q tag

227 reqs'

203 reqs'

228− baseurl opts

204+ baseurl

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

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

230 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)

206 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)

231 <$> eVals <*>) <$> reqs

207 <$> eVals <*>) <$> reqs

@@ -242,22 +218,12 @@ instance HasClientMulti t m sublayout f tag

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

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

243

219

244

220

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−

256------------------------------------------------------------------------------

221------------------------------------------------------------------------------

257instance (KnownSymbol sym,

222instance (KnownSymbol sym,

258 ToHttpApiData a,

223 ToHttpApiData a,

259 HasClientMulti t m sublayout f tag,

224 HasClientMulti t m sublayout f tag,

260 Reflex t,

225 Reflex t,

226+ Traversable f,

261 Applicative f)

227 Applicative f)

262 => HasClientMulti t m (QueryParam sym a :> sublayout) f tag where

228 => HasClientMulti t m (QueryParam sym a :> sublayout) f tag where

263

229

@@ -266,9 +232,9 @@ instance (KnownSymbol sym,

266

232

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

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

268 -- TODO: Check the above comment

234 -- TODO: Check the above comment

269− clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =

235+ clientWithRouteMulti Proxy q f tag reqs baseurl mparams =

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

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

271− reqs' baseurl opts

237+ reqs' baseurl

272

238

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

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

274 p prm = QueryPartParam $ fmap qParamToQueryPart prm

240 p prm = QueryPartParam $ fmap qParamToQueryPart prm

@@ -283,33 +249,36 @@ instance (KnownSymbol sym,

283 ToHttpApiData a,

249 ToHttpApiData a,

284 HasClientMulti t m sublayout f tag,

250 HasClientMulti t m sublayout f tag,

285 Reflex t,

251 Reflex t,

252+ Traversable f,

286 Applicative f)

253 Applicative f)

287 => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where

254 => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where

288

255

289 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =

256 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =

290 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag

257 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag

291

258

292− clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =

259+ clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =

293− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts

260+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

294

261

295 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }

262 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }

296 pname = symbolVal (Proxy :: Proxy sym)

263 pname = symbolVal (Proxy :: Proxy sym)

297 params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)

264 params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)

298 l

265 l

299 reqs' = liftA2 req' <$> paramlists <*> reqs

266 reqs' = liftA2 req' <$> paramlists <*> reqs

267+ -- reqs' = req' <$> paramlists <*> reqs

300

268

301

269

302instance (KnownSymbol sym,

270instance (KnownSymbol sym,

303 HasClientMulti t m sublayout f tag,

271 HasClientMulti t m sublayout f tag,

304 Reflex t,

272 Reflex t,

273+ Traversable f,

305 Applicative f)

274 Applicative f)

306 => HasClientMulti t m (QueryFlag sym :> sublayout) f tag where

275 => HasClientMulti t m (QueryFlag sym :> sublayout) f tag where

307

276

308 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =

277 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =

309 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag

278 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag

310

279

311− clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =

280+ clientWithRouteMulti Proxy q f tag reqs baseurl flags =

312− clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts

281+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

313

282

314 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }

283 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }

315 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)

284 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)

@@ -318,32 +287,33 @@ instance (KnownSymbol sym,

318

287

319

288

320instance (SupportsServantReflex t m,

289instance (SupportsServantReflex t m,

321− Traversable f, Applicative f) => HasClientMulti t m Raw f tag where

290+ Traversable f) => HasClientMulti t m Raw f tag where

322 type ClientMulti t m Raw f tag = f (Dynamic t (Either Text (XhrRequest ())))

291 type ClientMulti t m Raw f tag = f (Dynamic t (Either Text (XhrRequest ())))

323 -> Event t tag

292 -> Event t tag

324− -> m (Event t (f (ReqResult tag ())))

293+ -> m (Event t (tag, f (ReqResult ())))

325

294

326− clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do

295+ clientWithRouteMulti _ _ _ _ oldReqs baseurl rawReqs triggers = do

327 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))

296 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))

328 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers

297 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers

329− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''

298+ resps <- fmap (second (fmap aux) . getCompose) <$> performSomeRequestsAsync rawReqs''

330 return resps

299 return resps

331 where

300 where

332− aux (tag, Right r) = ResponseSuccess tag () r

301+ aux (Right r) = ResponseSuccess () r

333− aux (tag, Left e) = RequestFailure tag e

302+ aux (Left e) = RequestFailure e

334

303

335

304

336instance (MimeRender ct a,

305instance (MimeRender ct a,

337 HasClientMulti t m sublayout f tag,

306 HasClientMulti t m sublayout f tag,

338 Reflex t,

307 Reflex t,

308+ Traversable f,

339 Applicative f)

309 Applicative f)

340 => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where

310 => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where

341

311

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

312 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =

343 Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag

313 Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag

344

314

345− clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

315+ clientWithRouteMulti Proxy q f tag reqs baseurl bodies =

346− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts

316+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

347 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }

317 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }

348 ctProxy = Proxy :: Proxy ct

318 ctProxy = Proxy :: Proxy ct

349 ctString = T.pack $ show $ contentType ctProxy

319 ctString = T.pack $ show $ contentType ctProxy

@@ -388,14 +358,14 @@ instance HasClientMulti t m api f tag => HasClientMulti t m (IsSecure :> api) f

388 clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

358 clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

389

359

390

360

391−instance (HasClientMulti t m api f tag, Reflex t, Applicative f)

361+instance (HasClientMulti t m api f tag, Reflex t, Traversable f, Applicative f)

392 => HasClientMulti t m (BasicAuth realm usr :> api) f tag where

362 => HasClientMulti t m (BasicAuth realm usr :> api) f tag where

393

363

394 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))

364 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))

395 -> ClientMulti t m api f tag

365 -> ClientMulti t m api f tag

396

366

397− clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =

367+ clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =

398− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts

368+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl

399 where

369 where

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

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

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

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

stack.yamldeleted−56

@@ -1,56 +0,0 @@

1−flags: {}

2−extra-package-dbs: []

3−packages:

4−- '.'

5−

6−- location:

7− git: https://github.com/reflex-frp/reflex

8− commit: d78ba4318c425ca9b942dc387d7c5c7ab2d2e095

9− extra-dep: true

10−

11−- location:

12− git: https://github.com/mokus0/dependent-sum.git

13− commit: bbc8ad3a81ea7f2b07ce7d036efd56f2e0f7c6ff

14− extra-dep: true

15−

16−- location:

17− git: https://github.com/gtk2hs/gtk2hs.git

18− commit: 21d3a12a82756d04066e5e4198b35097012ee65b

19− subdirs:

20− - cairo

21− - gio

22− - glib

23− - gtk

24− - pango

25− - tools

26− extra-dep: true

27−

28−- location:

29− git: https://github.com/byorgey/hashtables.git

30− commit: 47d9ed261a5aba66a13d3c4da0e391d338b57fc5

31− extra-dep: true

32−

33−- location:

34− git: https://github.com/afcady/reflex-dom.git

35− commit: 39b5ff23f3ae95d77c909ab3ed4bc4bd9e61f600

36− extra-dep: true

37−

38−- location:

39− git: https://github.com/afcady/dependent-sum-template.git

40− commit: 68fc1a90580ea8f20775491cf651eefea422212a

41− extra-dep: true

42−

43−extra-deps:

44−- cpphs-1.20.4

45−- directory-1.2.7.1

46−- ghcjs-dom-0.2.4.0

47−- haskell-src-exts-1.17.1

48−- haskell-src-meta-0.6.0.14

49−- hlint-1.9.35

50−- prim-uniq-0.1.0.1

51−- primitive-0.6.2.0

52−- ref-tf-0.4.0.1

53−- vector-0.12.0.0

54−- webkitgtk3-javascriptcore-0.13.2.0

55−- zenc-0.1.1

56−resolver: lts-8.3

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

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

9import Data.Foldable

10import Test.WebDriver.Commands.Wait

11import Test.Hspec.WebDriver

12−import Test.Hspec.WebDriver (chromeCaps)

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

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

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

29spec = do

28spec = do

30 describe "servant-reflex tests" $ do

29 describe "servant-reflex tests" $ do

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

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

34 it "opens the page" $ runWD $

33 it "opens the page" $ runWD $

35 openPage "http://localhost:8000"

34 openPage "http://localhost:8000"

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

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

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE TypeOperators #-}

4−

5−module API where

6−

7−import Data.Aeson

8−import Data.Aeson.Types (typeMismatch)

9−import Data.Text (Text)

10−import Servant.API

11−

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

13−

14−instance ToJSON Question where

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

16−

17−instance FromJSON Question where

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

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

20−

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

22−

23−instance ToJSON Answer where

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

25−

26−instance FromJSON Answer where

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

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

29−

30−

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

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

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

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

35− :> QueryParams "greetings" Text

36− :> QueryFlag "gusto"

37− :> Get '[JSON] Text

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

39− :> Post '[JSON] Double

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

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

42− :> Post '[JSON] Answer

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

44− :<|> Raw

45−

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

47−

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

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

50−type ComprehensiveAPI =

51− GET :<|>

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

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

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

55− HttpVersion :> GET :<|>

56− IsSecure :> GET :<|>

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

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

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

60−-- Raw :<|>

61− RemoteHost :> GET :<|>

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

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

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

65− Vault :> GET :<|>

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

67− Verb 'POST 204 '[JSON] Int

68−-- This one isn't in scope

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

@@ -0,0 +1 @@

1+../exec/API.hs

testserver/Main.hs+14−39

@@ -2,34 +2,27 @@

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PolyKinds #-}

5−{-# LANGUAGE TypeApplications #-}

6{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeOperators #-}

9−import Control.Monad.IO.Class (liftIO)

10−import Control.Monad.Reader (reader)

11import Data.Aeson

8import Data.Aeson

12import Data.Bool

9import Data.Bool

13−import Data.Char (toUpper)

10+import Data.Char (toUpper)

14−import qualified Data.List as L

11+import qualified Data.List as L

15−import Data.Maybe (fromMaybe)

16import Data.Monoid

12import Data.Monoid

17import Data.Proxy

13import Data.Proxy

18−import Data.Text hiding (head, length, map,

14+import Data.Text hiding (length, null, map, head, toUpper)

19− null, toUpper)

20−import qualified Data.Text as T

15+import qualified Data.Text as T

21−import qualified Data.Text.IO as T

22import GHC.Generics

16import GHC.Generics

23−import Servant.Server.Internal.SnapShims

24−import Snap.Core

25import Snap.Http.Server

17import Snap.Http.Server

18+import Snap.Core

19+import Servant.Server.Internal.SnapShims

27−import Servant

21+import Servant -- hiding (serveDirectory)

28import Servant.Server

22import Servant.Server

29-- import Snap.Util.FileServe

23-- import Snap.Util.FileServe

30−import System.Environment (lookupEnv)

31import API

24import API

32−import Snap

25+import Snap

34-- * Example

27-- * Example

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

43testApi :: Proxy API

36testApi :: Proxy API

44testApi = Proxy

37testApi = Proxy

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

39+data App = App

48-- Server-side handlers.

41-- Server-side handlers.

49--

42--

@@ -51,10 +44,8 @@ data App = App { appStaticDir :: String }

51-- that represents the API, are glued together using :<|>.

44-- that represents the API, are glued together using :<|>.

52--

45--

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

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

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

47+server :: Server API (Handler App App)

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

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

57− :<|> statics

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

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

59 sayhi nm greetings withGusto = case nm of

50 sayhi nm greetings withGusto = case nm of

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

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

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

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

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

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

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

68 return . modifier $ greetPart <> n

59 return . modifier $ greetPart <> n

69− dbl x = if x `elem` [4,13]

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

71− else return $ x * 2

60+ dbl x = return $ x * 2

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

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

73− qna q = do

74− liftIO $ do

75− putStrLn $ "qna got: " ++ show q

76− T.putStrLn $ unQuestion q

77− return $ Answer $ unQuestion q

78− serveSecret _ = do

79− req <- getRequest

80− liftIO $ putStrLn (show req)

81− return 101

82− statics = do

83− staticDir <- reader appStaticDir

84− serveDirectory staticDir

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

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

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

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

88test :: Handler App App ()

65test :: Handler App App ()

89−test = serveSnapWithContext testApi

66+test = serveSnap testApi server

90− (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server

92initApp :: SnapletInit App App

68initApp :: SnapletInit App App

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

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

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

95 addRoutes [("", test)

70 addRoutes [("", test)

96 ,("", serveDirectory "static")

71 ,("", serveDirectory "static")

97 ]

72 ]

98− return (App staticDir)

73+ return App

100-- Put this all to work!

75-- Put this all to work!

101main :: IO ()

76main :: IO ()

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

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

1+#!/usr/bin/env bash

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

4+phantomjs --webdriver=127.0.0.1:4444 &

5+dist/build/spec/spec

testserver/testserver.cabal+16−17

@@ -1,32 +1,31 @@

1−-- Initial back.cabal generated by cabal init. For further documentation,

1+-- Initial back.cabal generated by cabal init. For further documentation,

2-- see http://haskell.org/cabal/users-guide/

4name: testserver

5version: 0.1.0.0

6−-- synopsis:

6+-- synopsis:

7−-- description:

7+-- description:

8license: BSD3

9license-file: LICENSE

10author: Greg Hale

11maintainer: imalsogreg@gmail.com

12−-- copyright:

12+-- copyright:

13−-- category:

13+-- category:

14build-type: Simple

15−-- extra-source-files:

15+-- extra-source-files:

16cabal-version: >=1.10

18executable back

19 main-is: Main.hs

20− -- other-modules:

20+ -- other-modules:

21− -- other-extensions:

21+ -- other-extensions:

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

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

23− , base >=4.8 && < 5

23+ , base >=4.8 && <4.10

24− , mtl

25− , snap >= 1.0 && < 1.2

24+ , snap >= 1.0 && < 1.1

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

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

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

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

28− , servant >= 0.16 && < 0.18

27+ , servant >= 0.7.1 && < 0.9

29− , servant-snap >= 0.8 && < 0.9

28+ , servant-snap >= 0.7 && < 0.8

30− , text >= 1.0 && < 1.3

29+ , text >= 1.2 && < 1.3

31− -- hs-source-dirs:

30+ -- hs-source-dirs:

32 default-language: Haskell2010

31 default-language: Haskell2010

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