f6d3b8b...master · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

on master help sign in

35 files changed+1438−783

since splitsnapshots

unifiedsplit

.gitignore+3

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

66*.webapp

77*.stats

88out

9+/.stack-work/

10+TAGS

11+dist-newstyle

.gitmodules−15

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

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

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

1−sudo: required

2−

3−before_cache:

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

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

6−

7−addons:

8− apt:

9− - phantomjs

10−

11−matrix:

12− include:

13− - env: CABALVER=1.24 GHCVER=7.10.3

14− compiler: ": #GHC 7.10.3"

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

16− - env: CABALVER=1.24 GHCVER=8.0.1

17− compiler: ": #GHC 8.0.1"

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

19−

20−

1+language: nix

2+nix: 2.3.6

3+sudo: require

214

225before_install:

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

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

277

28−install:

29− - cabal --version

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

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

8+before_script:

9+ - sudo systemctl restart nix-daemon.service

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

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

4712

4813script:

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

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

51− - ./build.sh

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"

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

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

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

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

ChangeLog.mdnew file+60

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

1+0.3.5

2+-----

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

5+ - Require servant >= 0.16

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

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

9+0.3.4

10+-----

11+

12+Add selenium-based test suite

13+

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+114−28

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

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

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

6−

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.

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

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

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

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

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

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

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

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

1014

1115

1216## Example

1317

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

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

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

1520

1621```haskell

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

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

2429 :<|> Raw

2530```

2631

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

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

33+an `XhrRequest`.

2834

2935```haskell

3036

@@ -33,16 +39,26 @@ type API = "getint" :> Get '[JSON] Int

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

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

3541 (Proxy :: Proxy m)

42+ (Proxy :: Proxy ())

3643 (constDyn (BasePath "/"))

3744```

3845

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.

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

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

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

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

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

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

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

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

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

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

4056

4157```haskell

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

4359 getint :: MonadWidget t m

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

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

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

4662

4763 sayhi :: MonadWidget t m

4864 => Dynamic t (QParam Text)

@@ -53,15 +69,21 @@ These client functions are computed from your API type. They manage serializatio

5369 -- ^ Flag for capitalizing the response

5470 -> Event t ()

5571 -- ^ Trigger the XHR Request

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

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

5773

5874 doubleit :: MonadWidget t m

5975 => Dynamic t (Either Text Double)

6076 -> Event t ()

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

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

6278```

6379

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:

80+`ReqResult tag a` is defined in

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

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

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

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

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

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

6587

6688```haskell

6789 -- ... continued ...

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

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

80102```

81103

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

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

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

83106

84107```haskell

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

@@ -102,37 +125,100 @@ This example builds some input fields to enter API parameters, buttons to trigge

102125 display =<< holdDyn Nothing outputDouble

103126```

104127

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.

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

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

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

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

132+the respective authors of these fabulous libraries.

106133

107134

108135## Building the library and test server

109136

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:

111−

112−

113−First build the library:

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

138+ghcjs-compiled frontend

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

140+ghc-compiled backend

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

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

143+manages the frontend build as a dependency.

114144

115145```

116−git submodule update --init --recursive

117−./build.sh

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

118147```

119148

120−Then build the test server:

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

121150

122151```

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

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

124153```

125154

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

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

157+under the Network tab.

126158

127−## Running the example site

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

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

128161

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

130162

163+## Tagging requests

164+

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

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

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

168+relationship by tagging the requests.

169+

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

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

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

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

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

175+

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

131200```

132−cd testserver

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

134−```

135201

136−And simply browse to `localhost:8001`

202+## Simultaneous requests

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

137217

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

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

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

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

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

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

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

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

build.shdeleted−3

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

1−#!/usr/bin/env bash

2−

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

default.nixnew file+21

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

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

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

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

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

5+, transformers

6+}:

7+mkDerivation {

8+ pname = "servant-reflex";

9+ version = "0.3.6";

10+ src = ./.;

11+ isLibrary = true;

12+ isExecutable = true;

13+ libraryHaskellDepends = [

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

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

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

17+ text transformers

18+ ];

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

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

21+}

deps/http-api-datadeleted−1

Submodule changed.

deps/reflexdeleted−1

Submodule changed.

deps/reflex-domdeleted−1

Submodule changed.

deps/servantdeleted−1

Submodule changed.

deps/servant-snapdeleted−1

Submodule changed.

exec/API.hs+29−4

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

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeOperators #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeOperators #-}

45module API where

6−import Data.Text (Text)

7−import Servant.API

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+

830

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

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

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

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

1739 :> Post '[JSON] Double

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

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

42+ :> Post '[JSON] Answer

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

1944 :<|> Raw

2045

2146type GET = Get '[JSON] ()

exec/Example.hs+92−30

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

1+{-# LANGUAGE DataKinds #-}

12{-# LANGUAGE FlexibleContexts #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE OverloadedStrings #-}

45{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE RecursiveDo #-}

57{-# LANGUAGE ScopedTypeVariables #-}

79module Main where

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

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

1416import Data.Text (Text)

1517import qualified Data.Text as T

18+import qualified Data.Text.Encoding as T

19+import GHC.TypeLits

1620import Servant.API

1721import API

1822import Data.Proxy

1923import Text.Read (readMaybe)

20−import Reflex.Dom

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

25+import Reflex.Dom (mainWidget)

2126------------------------------------------------------------------------------

2227import Servant.Reflex

2328import Servant.Reflex.Multi

@@ -41,15 +46,36 @@ runMulti :: forall t m. (SupportsServantReflex t m,

4146runMulti = do

4247 url <- baseUrlWidget

4348 el "br" blank

44− let (_ :<|> _ :<|> _ :<|> dbl :<|> _ :<|> _ ) =

45− clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) url

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

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

51+

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

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

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

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

54+

5055 b <- button "Run dbl multi"

51− r <- dbl [num,num2] b

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

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

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

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

59+

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

61+ display lastInd

62+

63+ divClass "demo-group" $ do

64+ nms <- fmap (fmap T.words . value) $ divClass "" $ do

65+ text "Names"

66+ textInput def

67+ grts <- fmap (fmap T.words . value) $ divClass "" $ do

68+ text "Greetings"

69+ textInput def

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

71+ b <- button "Go"

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

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

74+

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

76+ fmap reqSuccess <$> r')

77+

78+

5379 return ()

5480

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

@@ -58,8 +84,10 @@ run :: forall t m. (SupportsServantReflex t m,

5884 MonadFix m,

5985 PostBuild t m,

6086 MonadHold t m) => m ()

61−run = do

87+run = mdo

6288

89+ reqCount <- count $ leftmost

90+ [() <$ unitBtn, () <$ intBtn, () <$ sayHiClicks, () <$ dblBtn, () <$ mpGo]

6391 -- Allow user to choose the url target for the request

6492 -- (alternatively we could just `let url = constDyn (BasePath "/")`)

6593 url <- baseUrlWidget

@@ -69,25 +97,31 @@ run = do

6997 el "br" (return ())

7098

7199 -- Name the computed API client functions

73− client api (Proxy :: Proxy m) url

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

74105

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

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

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

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

78111

79− unitResponse <- getUnit unitBtn

80− intResponse :: Event t (ReqResult Int) <- getInt intBtn

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

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

81114

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

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

83116

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

85− leftmost [fmapMaybe response unitResponse

86− ,fmapMaybe response intResponse

118+ leftmost [fmapMaybe response (unitResponse)

119+ ,fmapMaybe response (intResponse)

87120 ]

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

122+ return (unitBtn, intBtn)

89123

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

124+ sayHiClicks <- elClass "div" "demo-group" $ do

91125

92126 text "Name"

93127 el "br" $ return ()

@@ -105,36 +139,64 @@ run = do

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

106140

107141 el "br" $ return ()

108− sayhiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"

109− let triggers = leftmost [sayhiClicks, () <$ updated inp]

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

143+ let triggers = leftmost [sayHiClicks, () <$ updated inp]

110144

111− resp <- sayhi checkedName greetings gusto triggers

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

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

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

114− , fmapMaybe reqFailure resp])

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

148+ , fmapMaybe reqFailure (resp)])

149+ return sayHiClicks

115150

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

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

117152 text "A Double to double"

118153 el "br" $ return ()

119154 dblinp <- fmap value $ divClass "double-input" $ textInput def

120155 (dblBtn) <- divClass "double-button" $ button "Double it"

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

122− dblinp) dblBtn

123− divClass "double-errors" $ dynText =<<

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

157+ dblinp) (tag (current reqCount) dblBtn)

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

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

125160 el "br" (return ())

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

127162 holdDyn "No number yet" (fmap tShow $

128− fmapMaybe reqSuccess dblResp)

163+ fmapMaybe reqSuccess (dblResp))

164+ return dblBtn

129165

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

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

131167 text "Multi-part path"

132168 b <- value <$> checkbox False def

133169 mpGo <- button "Test"

134− multiResp <- multi b mpGo

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

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

136172 fmapMaybe reqSuccess $

137− multiResp)

173+ (multiResp))

174+ return mpGo

175+

176+ return ()

177+

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+

138200

139201showXhrResponse :: XhrResponse -> Text

140202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

nix/nix.confnew file+3

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

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

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

3+trusted-users = travis

nix/reflex-platform.nixnew file+7

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

1+let

2+ rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;

3+in import (builtins.fetchTarball

4+ {

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

6+ sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;

7+ }) {}

nix/servant-snap.nixnew file+7

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

1+# Servant-snap is marked broken in nixpkgs

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

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

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

5+ rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";

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

7+}) {}

nix/testresults.nixnew file+17

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

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

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

4+ echo About to phantom

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

6+ sleep 3

7+ echo About to Server

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

9+ sleep 3

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

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

12+ echo About to testdrive

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

14+ echo Done

15+ trap "exit" INT TERM

16+ trap "kill 0" EXIT

17+ ''

nix/testserver.nixnew file+9

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

1+servant-reflex: self: super:

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

4+ postInstall = ''

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

6+ mkdir $out/static

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

8+ '';

9+})

overrides-ghc.nixdeleted−18

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

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

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

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

2−let

3−

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

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

6− cabal2nixResult = reflex-platform.cabal2nixResult;

7−

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+36−19

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

11Name: servant-reflex

2−Version: 0.2.1

3−Synopsis: Servant reflex API generator

4−Description: Servant reflex API generator

5−License: AllRightsReserved

2+Version: 0.3.6

3+Synopsis: servant API generator for reflex apps

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

5+License: BSD3

66License-file: LICENSE.md

77Author: Greg Hale, Doug Beardsley

88Maintainer: imalsogreg@gmail.com

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

1111Build-type: Simple

1212Cabal-version: >=1.10

1313

14+Flag Example

15+ description: Enable example

16+ default: False

17+

1418library

1519 exposed-modules:

16− Servant.Reflex

17− Servant.Reflex.Multi

18−

19− other-modules:

2020 Servant.Common.BaseUrl

2121 Servant.Common.Req

22+ Servant.Reflex

23+ Servant.Reflex.Multi

2224

2325 hs-source-dirs: src

2426 build-depends:

25− base >= 4.8 && < 4.10,

27+ base >= 4.8 && < 5,

2628 bytestring >= 0.10 && < 0.11,

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

28− containers >= 0.5.6 && < 0.6,

30+ containers >= 0.5.6 && < 0.7,

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

30− exceptions >= 0.8 && < 0.9,

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

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

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

32+ exceptions >= 0.8 && < 0.11,

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

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

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

36+ jsaddle >= 0.8 && < 0.10,

3437 mtl >= 2.2.1 && < 2.3,

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

36− reflex >= 0.5 && < 0.6,

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

39+ reflex >= 0.5 && < 0.9,

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

3841 safe >= 0.3.9 && < 0.4,

39− servant >= 0.5 && < 0.9,

42+ servant >= 0.16 && < 0.19,

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

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

4145 text >= 1.2 && < 1.3,

4246 transformers >= 0.4 && < 0.6

4347

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

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

4549

4650 default-language: Haskell2010

4751

4852executable example

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

53+ if flag(Example)

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

5067 default-language: Haskell2010

5168 main-is: Example.hs

5269 other-modules: API

shell.nixnew file+1

@@ -0,0 +1 @@

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

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

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

11{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE DeriveDataTypeable #-}

34{-# LANGUAGE DeriveGeneric #-}

45{-# LANGUAGE FlexibleContexts #-}

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

2021) where

2122

2223import Control.Monad (join)

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

24+-- import Control.Monad.IO.Class (MonadIO)

2425import Control.Monad.Fix (MonadFix)

2526import Data.Monoid ((<>))

2627import Data.Text (Text)

2728import qualified Data.Text as T

2829import GHC.Generics

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

2931import Reflex

30−import Reflex.Dom

32+import Reflex.Dom.Core

3133import Text.Read

3234

33−

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

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

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

37+#else

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

39+#endif

3540

3641-- | URI scheme to use

3742data Scheme =

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

8489 where pathWidget :: m (Dynamic t BaseUrl)

8590 pathWidget = do

8691 text "Url base path"

87− t <- textInput (def {_textInputConfig_attributes =

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

92+ t <- inputElement def

8993 return $ BasePath <$> value t

9094 fullUrlWidget :: m (Dynamic t BaseUrl)

9195 fullUrlWidget = do

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

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

97+ srv <- inputElement def

9498 text ":"

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

99+ prt <- inputElement def

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

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

101+ path <- inputElement def

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

src/Servant/Common/Req.hs+212−131

@@ -1,61 +1,119 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

31{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveFunctor #-}

43{-# LANGUAGE FlexibleContexts #-}

54{-# LANGUAGE GADTs #-}

65{-# LANGUAGE OverloadedStrings #-}

76{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE RankNTypes #-}

88{-# LANGUAGE ScopedTypeVariables #-}

99{-# LANGUAGE TupleSections #-}

1010

11−{-# LANGUAGE EmptyCase #-}

1211module Servant.Common.Req where

1312

1413-------------------------------------------------------------------------------

15−import Control.Concurrent

1614import Control.Applicative (liftA2, liftA3)

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

16+import Control.Concurrent

17+import Control.Monad (join)

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

19+import Data.Bifunctor (first)

20+import qualified Data.ByteString.Builder as Builder

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

22+import Data.ByteString (ByteString)

1923import qualified Data.Map as Map

20−import Data.Maybe (catMaybes)

24+import Data.Maybe (catMaybes, fromMaybe)

25+import Data.Functor.Compose

2126import Data.Monoid ((<>))

2227import Data.Proxy (Proxy(..))

2328import Data.Text (Text)

2429import qualified Data.Text as T

2530import qualified Data.Text.Encoding as TE

26−import Data.Traversable

27−import Reflex.Dom

28−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl, SupportsServantReflex)

31+import Data.Traversable (forM)

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

33+import qualified Network.URI as N

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

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

36+ SupportsServantReflex)

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

3038import Web.HttpApiData (ToHttpApiData(..))

3139-------------------------------------------------------------------------------

3240import Servant.API.BasicAuth

3341

3442

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'

72+

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

79+reqSuccess _ = Nothing

3580

36−data ReqResult a = ResponseSuccess a XhrResponse

37− | ResponseFailure Text XhrResponse

38− | RequestFailure Text

3981

40−instance Functor ReqResult where

41− fmap f (ResponseSuccess a xhr) = ResponseSuccess (f a) xhr

42− fmap _ (ResponseFailure r x) = ResponseFailure r x

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

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

86+reqSuccess' _ = Nothing

87+

88+

89+------------------------------------------------------------------------------

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

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

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

93+reqFailure (RequestFailure _ s) = Just s

94+reqFailure _ = Nothing

4495

45−reqSuccess :: ReqResult a -> Maybe a

46−reqSuccess (ResponseSuccess x _) = Just x

47−reqSuccess _ = Nothing

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

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

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

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

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

101+reqFailure' _ = Nothing

48102

49−reqFailure :: ReqResult a -> Maybe Text

50−reqFailure (ResponseFailure s _) = Just s

51−reqFailure (RequestFailure s) = Just s

52−reqFailure _ = Nothing

53103

54−response :: ReqResult a -> Maybe XhrResponse

55−response (ResponseSuccess _ x) = Just x

56−response (ResponseFailure _ x) = Just x

57−response _ = Nothing

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

58110

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

59117

60118-------------------------------------------------------------------------------

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

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

68126 | QParamInvalid Text

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

70128

129+

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

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

73132qParamToQueryPart QNone = Right Nothing

74133qParamToQueryPart (QParamInvalid e) = Left e

75134

135+

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

77137 | QueryPartParams (Dynamic t [Text])

78138 | QueryPartFlag (Dynamic t Bool)

@@ -105,10 +165,10 @@ addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . t

105165reqToReflexRequest

106166 :: forall t. Reflex t

107167 => Text

108− -> Req t

109168 -> Dynamic t BaseUrl

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

111−reqToReflexRequest reqMeth req reqHost =

169+ -> Req t

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

171+reqToReflexRequest reqMeth reqHost req =

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

113173 t = sequence $ reverse $ reqPathParts req

114174

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

119179 urlParts = fmap sequence t

120180

121181 urlPath :: Dynamic t (Either Text Text)

122− urlPath = (fmap.fmap) (T.intercalate "/") urlParts

182+ urlPath = (fmap.fmap)

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

184+ urlParts

123185

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

125187 queryPartString (pName, qp) = case qp of

126188 QueryPartParam p -> ffor p $ \case

127189 Left e -> Just (Left e)

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

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

129191 Right Nothing -> Nothing

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

131193 if null pStrings

132194 then Nothing

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

195+ else Just . Right

196+ . T.intercalate "&"

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

134198 QueryPartFlag fl -> ffor fl $ \case

135199 True -> Just $ Right pName

136200 False -> Nothing

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

165229 Right $ XhrRequestConfig

166230 { _xhrRequestConfig_sendData = bytesToPayload bBytes

167231 , _xhrRequestConfig_headers =

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

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

169233 , _xhrRequestConfig_user = Nothing

170234 , _xhrRequestConfig_password = Nothing

171− , _xhrRequestConfig_responseType = Nothing

235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

172236 , _xhrRequestConfig_withCredentials = False

173237 , _xhrRequestConfig_responseHeaders = def

174238 }

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

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

181245 , _xhrRequestConfig_user = Nothing

182246 , _xhrRequestConfig_password = Nothing

183− , _xhrRequestConfig_responseType = Nothing

184− , _xhrRequestConfig_sendData = ""

247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

248+ , _xhrRequestConfig_sendData = mempty

185249 , _xhrRequestConfig_withCredentials = False

186250 }

187251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

@@ -208,40 +272,57 @@ reqToReflexRequest reqMeth req reqHost =

208272displayHttpRequest :: Text -> Text

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

210274

211−-- | This function actually performs the request.

212−performRequests :: forall t m f.(SupportsServantReflex t m, Traversable f)

275+-- | This function performs the request

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

213277 => Text

214− -> f (Req t)

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

215279 -> Dynamic t BaseUrl

216− -> Event t ()

217− -> m (Event t (f (Either Text XhrResponse)))

218−performRequests reqMeth rs reqHost trigger = do

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

220− let reqs = tagPromptlyDyn xhrReqs trigger

221− resps <- performSomeRequestsAsync reqs

222− return resps

223−

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

280+ -> ClientOptions

281+ -> Event t tag

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

283+performRequests reqMeth rs reqHost opts trigger = do

284+ let xhrReqs =

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

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

287+

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

289+ reqs = attachPromptlyDynWith

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

291+

292+ resps <- performSomeRequestsAsync opts reqs

293+ return $ getCompose <$> resps

294+

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

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

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

225298performSomeRequestsAsync

226299 :: (MonadIO (Performable m),

300+ MonadJSM (Performable m),

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

227302 HasWebView (Performable m),

303+#endif

228304 PerformEvent t m,

229305 TriggerEvent t m,

230306 Traversable f,

231− IsXhrPayload a)

232− => Event t (f (Either Text (XhrRequest a)))

307+ IsXhrPayload a,

308+ Show a

309+ )

310+ => ClientOptions

311+ -> Event t (f (Either Text (XhrRequest a)))

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

234−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return

313+performSomeRequestsAsync opts =

314+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

235315

236316

237317------------------------------------------------------------------------------

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

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

240320performSomeRequestsAsync'

241− :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)

242− => (XhrRequest b -> (a -> IO ()) -> Performable m XMLHttpRequest)

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

322+ => ClientOptions

323+ -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)

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

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

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

245326 rs <- hrs

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

247328 Left e -> do

@@ -249,98 +330,92 @@ performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb ->

249330 return resp

250331 Right r' -> do

251332 resp <- liftIO newEmptyMVar

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

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

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

253335 return resp

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

255337 return ()

256338

257339

258340

259−-- | This function actually performs the request.

260−performRequest :: forall t m .(SupportsServantReflex t m)

261− => Text

262− -> (Req t)

263− -> Dynamic t BaseUrl

264− -> Event t ()

265− -> m (Event t (XhrResponse), Event t Text)

266−performRequest reqMeth req reqHost trigger = do

267−

268− let xhrReq = reqToReflexRequest reqMeth req reqHost

269− let reqs = tagPromptlyDyn xhrReq trigger

270− okReqs = fmapMaybe (either (const Nothing) Just) reqs

271− badReqs = fmapMaybe (either Just (const Nothing)) reqs

272−

273− resps <- performRequestAsync okReqs

274−

275− return (resps, badReqs)

276−

277−

278−#ifdef ghcjs_HOST_OS

279−type XhrPayload = String

280−bytesToPayload :: BL.ByteString -> XhrPayload

281−bytesToPayload = BL.unpack

282−#else

283−type XhrPayload = T.Text

341+type XhrPayload = ByteString

284342bytesToPayload :: BL.ByteString -> XhrPayload

285−bytesToPayload = T.pack . BL.unpack

286−#endif

343+bytesToPayload = BL.toStrict

287344

288−performRequestNoBody :: forall t m .(SupportsServantReflex t m)

289− => Text

290− -> Req t

291− -> Dynamic t BaseUrl

292− -> Event t () -> m (Event t (ReqResult NoContent))

293−performRequestNoBody reqMeth req reqHost trigger = do

294− (resp, badReq) <- performRequest reqMeth req reqHost trigger

295− return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]

296−

297−performRequestsNoBody :: forall t m f .(SupportsServantReflex t m, Traversable f)

298− => Text

299− -> f (Req t)

300− -> Dynamic t BaseUrl

301− -> Event t () -> m (Event t (f (ReqResult NoContent)))

302−performRequestsNoBody reqMeth reqs reqHost trigger = do

303− resp <- performRequests reqMeth reqs reqHost trigger

304− return $ (fmap . fmap) aux resp

305− where

306− aux (Right x) = ResponseSuccess NoContent x

307− aux (Left e) = RequestFailure e

308− -- return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]

309−

310−

311−

312−performRequestCT :: (SupportsServantReflex t m,

313− MimeUnrender ct a)

314− => Proxy ct -> Text -> Req t -> Dynamic t BaseUrl

315− -> Event t () -> m (Event t (ReqResult a))

316−performRequestCT ct reqMeth req reqHost trigger = do

317− (resp, badReq) <- performRequest reqMeth req reqHost trigger

318− let decodes = ffor resp $ \xhr ->

319− ((mimeUnrender ct . BL.fromStrict . TE.encodeUtf8)

320− =<< note "No body text" (_xhrResponse_responseText xhr), xhr)

321− reqs = ffor decodes $ \case

322− (Right a, r) -> ResponseSuccess a r

323− (Left e, r) -> ResponseFailure (T.pack e) r

324− return $ leftmost [reqs, fmap RequestFailure badReq]

325345

326346performRequestsCT

327347 :: (SupportsServantReflex t m,

328348 MimeUnrender ct a, Traversable f)

329349 => Proxy ct

330350 -> Text

331− -> f (Req t)

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

352+ -> Dynamic t BaseUrl

353+ -> ClientOptions

354+ -> Event t tag

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

356+performRequestsCT ct reqMeth reqs reqHost opts trigger = do

357+ resps <- performRequests reqMeth reqs reqHost opts trigger

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

359+ first T.pack .

360+ mimeUnrender ct $

361+ BL.fromStrict x

362+ decodeResp _ = Left "No body"

363+ return $ fmap

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

365+ Left e -> RequestFailure t e

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

367+ )

368+ resps

369+

370+

371+performRequestsNoBody

372+ :: (SupportsServantReflex t m,

373+ Traversable f)

374+ => Text

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

332376 -> Dynamic t BaseUrl

333− -> Event t ()

334− -> m (Event t (f (ReqResult a)))

335−performRequestsCT ct reqMeth reqs reqHost trigger = do

336− resps <- performRequests reqMeth reqs reqHost trigger

337− return $ ffor resps $ \eithXhrs -> ffor eithXhrs $ \eithXhr -> case eithXhr of

338− Left e -> RequestFailure e

339− Right x -> case _xhrResponse_responseText x of

340− Nothing -> ResponseFailure "No body text" x

341− Just bod -> case mimeUnrender ct . BL.fromStrict . TE.encodeUtf8 $ bod of

342− Left e -> ResponseFailure (T.pack e) x

343− Right a -> ResponseSuccess a x

377+ -> ClientOptions

378+ -> Event t tag

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

380+performRequestsNoBody reqMeth reqs reqHost opts trigger = do

381+ resps <- performRequests reqMeth reqs reqHost opts trigger

382+ let decodeResp = const $ Right NoContent

383+ return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of

384+ Left e -> RequestFailure tag e

385+ Right g -> evalResponse decodeResp (tag,g)

386+

387+

388+------------------------------------------------------------------------------

389+evalResponse

390+ :: (XhrResponse -> Either Text a)

391+ -> (tag, XhrResponse)

392+ -> ReqResult tag a

393+evalResponse decode (tag, xhr) =

394+ let status = _xhrResponse_status xhr

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

396+ errMsg = fromMaybe

397+ ("Empty response with error code " <>

398+ T.pack (show $ _xhrResponse_status xhr))

399+ (_xhrResponse_responseText xhr)

400+ respPayld = if okStatus

401+ then either

402+ (\e -> ResponseFailure tag e xhr)

403+ (\v -> ResponseSuccess tag v xhr)

404+ (decode xhr)

405+ else ResponseFailure tag errMsg xhr

406+ in respPayld

407+

408+------------------------------------------------------------------------------

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

410+-- response 'Event's,

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

412+fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess

413+

414+------------------------------------------------------------------------------

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

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

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

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

344419

345420

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

@@ -349,3 +424,9 @@ note e = maybe (Left e) Right

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

350425fmapL _ (Right a) = Right a

351426fmapL f (Left e) = Left (f e)

427+

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

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

430+

431+escape :: T.Text -> T.Text

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

src/Servant/Reflex.hs+286−190

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

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE InstanceSigs #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TupleSections #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−{-# LANGUAGE MultiParamTypeClasses #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7+{-# LANGUAGE InstanceSigs #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE OverloadedStrings #-}

10+{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE Rank2Types #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE TupleSections #-}

14+{-# LANGUAGE TypeFamilies #-}

15+{-# LANGUAGE TypeOperators #-}

16+{-# LANGUAGE UndecidableInstances #-}

17+

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

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

20+#endif

1521

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

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

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

1925-- API.

2026module Servant.Reflex

2127 ( client

28+ , clientWithOpts

29+ , clientWithOptsAndResultHandler

30+ , clientWithRoute

31+ , clientWithRouteAndResultHandler

2232 , BuildHeaderKeysTo(..)

2333 , toHeaders

24− , HasClient(..)

34+ , HasClient

35+ , Client

2536 , module Servant.Common.Req

2637 , module Servant.Common.BaseUrl

2738 ) where

2839

2940------------------------------------------------------------------------------

3041import Control.Applicative

42+import qualified Data.CaseInsensitive as CI

43+import Data.Functor.Identity

44+import qualified Data.Map as Map

3145import Data.Monoid ((<>))

32−import qualified Data.Set as Set

33−import qualified Data.Text.Encoding as E

34−import Data.CaseInsensitive (mk)

3546import Data.Proxy (Proxy (..))

36−import qualified Data.Map as Map

47+import qualified Data.Set as Set

3748import Data.Text (Text)

3849import qualified Data.Text as T

50+import qualified Data.Text.Encoding as E

51+import GHC.Exts (Constraint)

3952import GHC.TypeLits (KnownSymbol, symbolVal)

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

41− BasicAuthData, BuildHeadersTo(..),

42− Capture, contentType, Header,

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

44− MimeRender(..), MimeUnrender,

45− NoContent, QueryFlag, QueryParam,

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

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

54+ BasicAuthData, BuildHeadersTo (..),

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

56+ HttpVersion, IsSecure,

57+ MimeRender (..), MimeUnrender,

58+ NoContent, QueryFlag, QueryParam',

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

4760 RemoteHost, ReqBody,

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

49−

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

51− XhrRequest(..),

52− XhrResponseHeaders(..),

53− XhrResponse(..), ffor, fmapMaybe,

54− leftmost, performRequestAsync,

55− tagPromptlyDyn )

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

62+ contentType)

63+import Servant.API.Description (Summary)

64+import qualified Servant.Auth as Auth

65+

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

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

68+ XhrResponseHeaders (..),

69+ attachPromptlyDynWith, constDyn, ffor,

70+ fmapMaybe, leftmost,

71+ performRequestsAsync)

5672------------------------------------------------------------------------------

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

5874 showBaseUrl,

5975 SupportsServantReflex)

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

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

77+ defaultClientOptions,

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

6179 QueryPart(..), addHeader, authData,

62− defReq, prependToPathParts,

63− performRequestCT,

80+ defReq, evalResponse, prependToPathParts,

81+ -- performRequestCT,

6482 performRequestsCT,

65− performRequestNoBody,

83+ -- performRequestNoBody,

6684 performRequestsNoBody,

6785 performSomeRequestsAsync,

6886 qParamToQueryPart, reqBody,

6987 reqSuccess, reqFailure,

70− reqMethod, respHeaders, response,

71− qParams)

88+ reqMethod, respHeaders,

89+ response,

90+ reqTag,

91+ qParams, withCredentials)

92+

7293

7394-- * Accessing APIs as a Client

7495

@@ -80,30 +101,77 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),

80101-- > myApi :: Proxy MyApi

81102-- > myApi = Proxy

82103-- >

83−-- > getAllBooks :: Event t () -> m (Event t (Either XhrError ((),[Book])))

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

85−-- -> m (Event t (Either XhrError (Book,Book)))

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

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

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

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

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

88−client :: (HasClient t m layout)

89− => Proxy layout -> Proxy m -> Dynamic t BaseUrl -> Client t m layout

90−client p q baseurl = clientWithRoute p q defReq baseurl

109+client

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

126+clientWithOpts 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

91141

92142

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

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

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

96−class HasClient t m layout where

97− type Client t m layout :: *

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

99−

100−

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

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

103−

104− clientWithRoute Proxy q req baseurl =

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

106− clientWithRoute (Proxy :: Proxy b) q req baseurl

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

147+ type Client t m layout tag :: *

148+ clientWithRoute

149+ :: Proxy layout

150+ -> Proxy m

151+ -> Proxy tag

152+ -> Req t

153+ -> Dynamic t BaseUrl

154+ -> ClientOptions

155+ -> Client t m layout tag

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

157+

158+ clientWithRouteAndResultHandler

159+ :: Proxy layout

160+ -> Proxy m

161+ -> Proxy tag

162+ -> Req t

163+ -> Dynamic t BaseUrl

164+ -> ClientOptions

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

166+ -> Client t m layout tag

167+

168+

169+instance (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

171+

172+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =

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

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

107175

108176

109177-- Capture. Example:

@@ -114,21 +182,19 @@ instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where

114182-- > getBook :: SupportsServantReflex t m

115183-- => Dynamic t BaseUrl

116184-- -> Dynamic t (Maybe Text)

117−-- -> Event t ()

118−-- -> m (Event t (Either XhrError (Text, Book)))

185+-- -> Event t l

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

119187-- > getBook = client myApi (constDyn host)

120188

121−instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout)

122− => HasClient t m (Capture capture a :> sublayout) where

189+instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout tag)

190+ => HasClient t m (Capture capture a :> sublayout) tag where

123191

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

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

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

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

126194

127− clientWithRoute Proxy q req baseurl val =

128− clientWithRoute (Proxy :: Proxy sublayout)

129− q

130− (prependToPathParts p req)

131− baseurl

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

196+ clientWithRouteAndResultHandler

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

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

133199

134200

@@ -136,50 +202,52 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout)

136202instance {-# OVERLAPPABLE #-}

137203 -- Note [Non-Empty Content Types]

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

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

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

141− Event t () -> m (Event t (ReqResult a))

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

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

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

142208 -- TODO how to access input types here?

143209 -- ExceptT ServantError IO a

144− clientWithRoute Proxy _ req baseurl =

145− performRequestCT (Proxy :: Proxy ct) method req' baseurl

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

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

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

147213 req' = req { reqMethod = method }

148214

149215

150−

151−

152216-- -- VERB (No content) --

153217instance {-# OVERLAPPING #-}

154218 (ReflectMethod method, SupportsServantReflex t m) =>

155− HasClient t m (Verb method status cts NoContent) where

156− type Client t m (Verb method status cts NoContent) =

157− Event t () -> m (Event t (ReqResult NoContent))

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

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

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

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

159223 -- ExceptT ServantError IO NoContent

160− clientWithRoute Proxy _ req baseurl =

161− performRequestNoBody method req baseurl

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

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

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

163227

164228

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

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

166230toHeaders r =

167− let toBS = E.encodeUtf8

168− hdrs = maybe []

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

231+ let hdrs = maybe []

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

170233 (Map.toList $ _xhrResponse_headers xhr))

171234 (response r)

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

173236

237+

174238class BuildHeaderKeysTo hs where

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

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

176240

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

178242 where buildHeaderKeysTo _ = []

179243

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

181− => BuildHeaderKeysTo '[(Header h v) ': xs] where

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

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

246+ buildHeaderKeysTo _ =

247+ let

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

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

250+

183251

184252-- HEADERS Verb (Content) --

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

@@ -191,13 +259,13 @@ instance {-# OVERLAPPABLE #-}

191259 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

192260 ReflectMethod method, cts' ~ (ct ': cts),

193261 SupportsServantReflex t m

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

195− type Client t m (Verb method status cts' (Headers ls a)) =

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

197− clientWithRoute Proxy _ req baseurl = do

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

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

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

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

199− resp <- performRequestCT (Proxy :: Proxy ct) method req' baseurl

200− return $ (fmap . fmap) toHeaders resp

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

268+ wrap $ toHeaders <$> resp

201269 where req' = req { respHeaders =

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

203271 }

@@ -207,13 +275,13 @@ instance {-# OVERLAPPABLE #-}

207275instance {-# OVERLAPPABLE #-}

208276 ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,

209277 SupportsServantReflex t m

210− ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where

211− type Client t m (Verb method status cts (Headers ls NoContent))

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

213− clientWithRoute Proxy _ req baseurl = do

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

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

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

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

215− resp <- performRequestNoBody method req' baseurl

216− return $ (fmap . fmap) toHeaders resp

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

284+ wrap $ toHeaders <$> resp

217285 where req' = req {respHeaders =

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

219287 }

@@ -234,17 +302,17 @@ instance {-# OVERLAPPABLE #-}

234302-- > -- then you can just use "viewRefer" to query that endpoint

235303-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments

236304instance (KnownSymbol sym, ToHttpApiData a,

237− HasClient t m sublayout, SupportsServantReflex t m)

238− => HasClient t m (Header sym a :> sublayout) where

305+ HasClient t m sublayout tag, SupportsServantReflex t m)

306+ => HasClient t m (Header sym a :> sublayout) tag where

239307

240− type Client t m (Header sym a :> sublayout) =

241− Dynamic t (Either Text a) -> Client t m sublayout

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

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

242310

243− clientWithRoute Proxy q req baseurl eVal =

244− clientWithRoute (Proxy :: Proxy sublayout)

245− q

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

247− baseurl

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

312+ clientWithRouteAndResultHandler

313+ (Proxy :: Proxy sublayout) q t

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

315+ baseurl opts wrap

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

249317

250318

@@ -252,14 +320,26 @@ instance (KnownSymbol sym, ToHttpApiData a,

252320

253321-- | Using a 'HttpVersion' combinator in your API doesn't affect the client

254322-- functions.

255−instance HasClient t m sublayout

256− => HasClient t m (HttpVersion :> sublayout) where

323+instance HasClient t m sublayout tag

324+ => HasClient t m (HttpVersion :> sublayout) tag where

257325

258− type Client t m (HttpVersion :> sublayout) =

259− Client t m sublayout

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

327+ Client t m sublayout tag

328+

329+ clientWithRouteAndResultHandler Proxy =

330+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

331+

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

333+-- functions.

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

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

336+

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

338+ Client t m sublayout tag

339+

340+ clientWithRouteAndResultHandler Proxy =

341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

260342

261− clientWithRoute Proxy q =

262− clientWithRoute (Proxy :: Proxy sublayout) q

263343

264344

265345

@@ -289,16 +369,16 @@ instance HasClient t m sublayout

289369-- > -- then you can just use "getBooksBy" to query that endpoint.

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

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

292−instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

293− => HasClient t m (QueryParam sym a :> sublayout) where

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

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

294374

295− type Client t m (QueryParam sym a :> sublayout) =

296− Dynamic t (QParam a) -> Client t m sublayout

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

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

297377

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

299− clientWithRoute Proxy q req baseurl mparam =

300− clientWithRoute (Proxy :: Proxy sublayout) q

301− (req {qParams = paramPair : qParams req}) baseurl

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

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

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

302382

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

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

@@ -336,18 +416,18 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

336416-- > -- 'getBooksBy []' for all books

337417-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'

338418-- > -- to get all books by Asimov and Heinlein

339−instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

340− => HasClient t m (QueryParams sym a :> sublayout) where

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

420+ => HasClient t m (QueryParams sym a :> sublayout) tag where

341421

342− type Client t m (QueryParams sym a :> sublayout) =

343− Dynamic t [a] -> Client t m sublayout

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

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

344424

345− clientWithRoute Proxy q req baseurl paramlist =

346− clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl

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

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

347427

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

349429 pname = symbolVal (Proxy :: Proxy sym)

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

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

351431 paramlist

352432

353433

@@ -376,14 +456,14 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

376456-- > -- 'getBooksBy True' to only get _already published_ books

377457

378458-- TODO Bring back

379−instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)

380− => HasClient t m (QueryFlag sym :> sublayout) where

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

460+ => HasClient t m (QueryFlag sym :> sublayout) tag where

381461

382− type Client t m (QueryFlag sym :> sublayout) =

383− Dynamic t Bool -> Client t m sublayout

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

463+ Dynamic t Bool -> Client t m sublayout tag

384464

385− clientWithRoute Proxy q req baseurl flag =

386− clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl

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

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

387467

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

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

@@ -391,36 +471,27 @@ instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)

391471

392472

393473

394−-- | Pick a 'Method' and specify where the server you want to query is. You get

395−-- back the full `Response`.

396−-- TODO redo

397−instance SupportsServantReflex t m => HasClient t m Raw where

398− type Client t m Raw = Dynamic t (Either Text (XhrRequest ()))

399− -> Event t ()

400− -> m (Event t (ReqResult ()))

474+-- | Send a raw 'XhrRequest ()' directly to 'baseurl'

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

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

477+ -> Event t tag

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

401479

402− -- clientWithRoute :: Proxy Raw -> Proxy m -> Req -> BaseUrl -> Client t m Raw

403− clientWithRoute _ _ _ baseurl xhrs triggers = do

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

405− Left e -> Left e

406− Right jx -> Right $ jx {_xhrRequest_url = path

407− <> _xhrRequest_url jx})

408− xhrs

409− (showBaseUrl <$> baseurl)

410− reqs = tagPromptlyDyn xhrs' triggers

411− okReq = fmapMaybe hush reqs

412− badReq = fmapMaybe tattle reqs

413− resps <- performRequestAsync okReq

414− return $ leftmost [fmap (ResponseSuccess () ) resps

415− ,fmap RequestFailure badReq]

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

416481

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

483+ Left e -> Left e

484+ Right jx -> Right $ jx { _xhrRequest_url = path <> _xhrRequest_url jx }

485+ ) xhrs (showBaseUrl <$> baseurl)

486+ xhrs'' = attachPromptlyDynWith (flip (,)) xhrs' triggers :: Event t (tag, Either Text (XhrRequest ()))

487+ badReq = fmapMaybe (\(t,x) -> either (Just . (t,)) (const Nothing) x) xhrs'' :: Event t (tag, Text)

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

417489

490+ resps <- performRequestsAsync okReq

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

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

493+ ]

418494

419−hush :: Either e a -> Maybe a

420−hush = either (const Nothing) Just

421−

422−tattle :: Either e a -> Maybe e

423−tattle = either Just (const Nothing)

424495

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

426497-- the corresponding querying function will automatically take

@@ -442,14 +513,14 @@ tattle = either Just (const Nothing)

442513-- > where host = BaseUrl Http "localhost" 8080

443514-- > -- then you can just use "addBook" to query that endpoint

444515

445−instance (MimeRender ct a, HasClient t m sublayout, Reflex t)

446− => HasClient t m (ReqBody (ct ': cts) a :> sublayout) where

516+instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)

517+ => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where

447518

448− type Client t m (ReqBody (ct ': cts) a :> sublayout) =

449− Dynamic t (Either Text a) -> Client t m sublayout

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

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

450521

451− clientWithRoute Proxy q req baseurl body =

452− clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl

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

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

453524 where req' = req { reqBody = bodyBytesCT }

454525 ctProxy = Proxy :: Proxy ct

455526 ctString = T.pack $ show $ contentType ctProxy

@@ -460,47 +531,46 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)

460531

461532

462533-- | Make the querying function append @path@ to the request path.

463−instance (KnownSymbol path, HasClient t m sublayout, Reflex t) => HasClient t m (path :> sublayout) where

464− type Client t m (path :> sublayout) = Client t m sublayout

534+instance (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

465536

466− clientWithRoute Proxy q req baseurl =

467− clientWithRoute (Proxy :: Proxy sublayout) q

468− (prependToPathParts (pure (Right $ T.pack p)) req)

469− baseurl

537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =

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

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

470540

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

472542

473543

474−instance HasClient t m api => HasClient t m (Vault :> api) where

475− type Client t m (Vault :> api) = Client t m api

544+instance 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

476546

477− clientWithRoute Proxy q req baseurl =

478− clientWithRoute (Proxy :: Proxy api) q req baseurl

547+ clientWithRouteAndResultHandler Proxy =

548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

479549

480550

481−instance HasClient t m api => HasClient t m (RemoteHost :> api) where

482− type Client t m (RemoteHost :> api) = Client t m api

551+instance 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

483553

484− clientWithRoute Proxy q req baseurl =

485− clientWithRoute (Proxy :: Proxy api) q req baseurl

554+ clientWithRouteAndResultHandler Proxy =

555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

486556

487557

488558

489−instance HasClient t m api => HasClient t m (IsSecure :> api) where

490− type Client t m (IsSecure :> api) = Client t m api

559+instance 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

491561

492− clientWithRoute Proxy q req baseurl =

493− clientWithRoute (Proxy :: Proxy api) q req baseurl

562+ clientWithRouteAndResultHandler Proxy =

563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

494564

495565

496−instance (HasClient t m api, Reflex t)

497− => HasClient t m (BasicAuth realm usr :> api) where

566+instance (HasClient t m api tag, Reflex t)

567+ => HasClient t m (BasicAuth realm usr :> api) tag where

498568

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

500− -> Client t m api

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

570+ -> Client t m api tag

501571

502− clientWithRoute Proxy q req baseurl authdata =

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

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

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

504574 where

505575 req' = req { authData = Just authdata }

506576

@@ -526,3 +596,29 @@ non-empty lists, but is otherwise more specific, no instance will be overall

526596more specific. This in turn generally means adding yet another instance (one

527597for empty and one for non-empty lists).

528598-}

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

src/Servant/Reflex/Multi.hs+263−190

@@ -1,328 +1,401 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE InstanceSigs #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TupleSections #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE UndecidableInstances #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE InstanceSigs #-}

147{-# 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

1535

16−module Servant.Reflex.Multi

17− ( clientA

1836 , HasClientMulti(..)

1937 ) where

2038

2139------------------------------------------------------------------------------

22−import Control.Applicative

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

24−import qualified Data.Set as Set

25−import qualified Data.Text.Encoding as E

26−import Data.CaseInsensitive (mk)

40+import Control.Applicative (liftA2)

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

2742import Data.Proxy (Proxy (..))

28−import qualified Data.Map as Map

43+import qualified Data.Set as Set

2944import Data.Text (Text)

3045import qualified Data.Text as T

46+import qualified Data.Text.Encoding as E

3147import GHC.TypeLits (KnownSymbol, symbolVal)

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

33− BasicAuthData, BuildHeadersTo(..),

34− Capture, contentType, Header,

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

36− MimeRender(..), MimeUnrender,

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

49+ BasicAuthData, BuildHeadersTo (..),

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

51+ HttpVersion, IsSecure,

52+ MimeRender (..), MimeUnrender,

3753 NoContent, QueryFlag, QueryParam,

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

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

3955 RemoteHost, ReqBody,

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

41−

42−import Reflex.Dom (Dynamic, Event, Reflex,

43− XhrRequest(..),

44− XhrResponseHeaders(..),

45− XhrResponse(..), ffor, fmapMaybe,

46− leftmost, performRequestAsync,

47− tagPromptlyDyn )

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

57+ contentType)

58+import Servant.API.Description (Summary)

59+

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

61+ XhrRequest (..),

62+ XhrResponseHeaders (..),

63+ attachPromptlyDynWith, constDyn)

64+------------------------------------------------------------------------------

65+import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),

66+ SupportsServantReflex)

67+import Servant.Common.Req (ClientOptions,

68+ QParam (..), QueryPart (..), Req,

69+ ReqResult (..), addHeader, authData,

70+ defReq,

71+ defaultClientOptions,

72+ performRequestsCT,

73+ performRequestsNoBody,

74+ performSomeRequestsAsync,

75+ prependToPathParts, qParamToQueryPart,

76+ qParams, reqBody, reqFailure,

77+ reqMethod, reqSuccess, reqSuccess',

78+ respHeaders, response, withCredentials)

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

80+

81+

82+------------------------------------------------------------------------------

83+clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)

84+ => Proxy layout -> Proxy m -> Proxy f -> Proxy tag

85+ -> Dynamic t BaseUrl -> ClientMulti t m layout f tag

86+clientA p q f tag baseurl =

87+ clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl

88+ defaultClientOptions

89+

90+

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

99+

100+------------------------------------------------------------------------------

101+class HasClientMulti t m layout f (tag :: *) where

102+ type ClientMulti t m layout f tag :: *

103+ clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag

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

105+ -> ClientOptions -> ClientMulti t m layout f tag

106+

107+

108+------------------------------------------------------------------------------

109+instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>

110+ HasClientMulti t m (a :<|> b) f tag where

111+ type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>

112+ ClientMulti t m b f tag

113+ clientWithRouteMulti Proxy q f tag reqs baseurl opts =

114+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>

115+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts

116+

117+

48118------------------------------------------------------------------------------

49−import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,

50− showBaseUrl,

51− SupportsServantReflex)

52−import Servant.Common.Req (Req, ReqResult(..), QParam(..),

53− QueryPart(..), addHeader, authData,

54− defReq, prependToPathParts,

55− performRequestCT,

56− performRequestsCT,

57− performRequestNoBody,

58− performRequestsNoBody,

59− performSomeRequestsAsync,

60− qParamToQueryPart, reqBody,

61− reqSuccess, reqFailure,

62− reqMethod, respHeaders, response,

63− qParams)

64−import Servant.Reflex (BuildHeaderKeysTo(..), toHeaders)

65−

66−clientA :: (HasClientMulti t m layout f, Applicative f)

67− => Proxy layout -> Proxy m -> Proxy f -> Dynamic t BaseUrl -> ClientMulti t m layout f

68−clientA p q f baseurl = clientWithRouteMulti p q f (pure defReq) baseurl

69−

70−class HasClientMulti t m layout f where

71− type ClientMulti t m layout f :: *

72− clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> f (Req t) -> Dynamic t BaseUrl -> ClientMulti t m layout f

73−

74−instance (HasClientMulti t m a f, HasClientMulti t m b f) => HasClientMulti t m (a :<|> b) f where

75− type ClientMulti t m (a :<|> b) f = ClientMulti t m a f :<|> ClientMulti t m b f

76− clientWithRouteMulti Proxy q f reqs baseurl =

77− clientWithRouteMulti (Proxy :: Proxy a) q f reqs baseurl :<|>

78− clientWithRouteMulti (Proxy :: Proxy b) q f reqs baseurl

79−

80−

81−instance (SupportsServantReflex t m, ToHttpApiData a, HasClientMulti t m sublayout f, Applicative f)

82− => HasClientMulti t m (Capture capture a :> sublayout) f where

83−

84− type ClientMulti t m (Capture capture a :> sublayout) f =

85− f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f

86−

87− clientWithRouteMulti l q f reqs baseurl vals = clientWithRouteMulti (Proxy :: Proxy sublayout) q f reqs' baseurl

119+instance (SupportsServantReflex t m,

120+ ToHttpApiData a,

121+ HasClientMulti t m sublayout f tag,

122+ Applicative f)

123+ => HasClientMulti t m (Capture capture a :> sublayout) f tag where

124+

125+ type ClientMulti t m (Capture capture a :> sublayout) f tag =

126+ f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag

127+

128+ clientWithRouteMulti _ q f tag reqs baseurl opts vals =

129+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts

88130 where

89− reqs' = prependToPathParts <$> ps <*> reqs

131+ reqs' = (prependToPathParts <$> ps <*>) <$> reqs

90132 ps = (fmap . fmap . fmap) toUrlPiece vals

91133

134+

135+------------------------------------------------------------------------------

92136-- VERB (Returning content) --

93137instance {-# OVERLAPPABLE #-}

94138 -- Note [Non-Empty Content Types]

95− (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts),

139+ (MimeUnrender ct a,

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

96141 SupportsServantReflex t m,

97142 Applicative f,

98143 Traversable f

99− ) => HasClientMulti t m (Verb method status cts' a) f where

144+ ) => HasClientMulti t m (Verb method status cts' a) f tag where

100145

101− type ClientMulti t m (Verb method status cts' a) f =

102− Event t () -> m (Event t (f (ReqResult a)))

146+ type ClientMulti t m (Verb method status cts' a) f tag =

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

103148

104− clientWithRouteMulti _ _ f reqs baseurl =

105− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl

149+ clientWithRouteMulti _ _ _ _ reqs baseurl opts =

150+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts

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

107− reqs' = (\r -> r { reqMethod = method }) <$> reqs

152+ reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs

108153

154+

155+------------------------------------------------------------------------------

109156-- -- VERB (No content) --

110157instance {-# OVERLAPPING #-}

111158 (ReflectMethod method, SupportsServantReflex t m, Traversable f) =>

112− HasClientMulti t m (Verb method status cts NoContent) f where

113− type ClientMulti t m (Verb method status cts NoContent) f =

114− Event t () -> m (Event t (f (ReqResult NoContent)))

159+ HasClientMulti t m (Verb method status cts NoContent) f tag where

160+ type ClientMulti t m (Verb method status cts NoContent) f tag =

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

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

116163 -- ExceptT ServantError IO NoContent

117− clientWithRouteMulti Proxy _ _ req baseurl =

118− performRequestsNoBody method req baseurl

164+ clientWithRouteMulti Proxy _ _ _ req baseurl opts =

165+ performRequestsNoBody method req baseurl opts

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

120167

168+

169+------------------------------------------------------------------------------

121170instance {-# OVERLAPPABLE #-}

122171 -- Note [Non-Empty Content Types]

123172 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

124173 ReflectMethod method, cts' ~ (ct ': cts),

125174 SupportsServantReflex t m,

126175 Traversable f

127− ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f where

128− type ClientMulti t m (Verb method status cts' (Headers ls a)) f =

129− Event t () -> m (Event t (f (ReqResult (Headers ls a))))

130− clientWithRouteMulti Proxy _ _ reqs baseurl = do

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

178+ Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))

179+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do

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

132− resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl

133− return $ (fmap . fmap) toHeaders <$> resp

134− where reqs' = ffor reqs $ \r -> r { respHeaders =

135− OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))

136− }

181+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))

182+ return $ fmap toHeaders <$> resp

183+ where

184+ reqs' = fmap (\r ->

185+ r { respHeaders =

186+ OnlyHeaders (Set.fromList

187+ (buildHeaderKeysTo (Proxy :: Proxy ls)))

188+ }) <$> reqs

137189

138190

191+------------------------------------------------------------------------------

139192instance {-# OVERLAPPABLE #-}

140193 ( BuildHeadersTo ls,

141194 BuildHeaderKeysTo ls,

142195 ReflectMethod method,

143196 SupportsServantReflex t m,

144197 Traversable f

145− ) => HasClientMulti t m (Verb method status cts (Headers ls NoContent)) f where

146− type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f

147− = Event t () -> m (Event t (f (ReqResult (Headers ls NoContent))))

148− clientWithRouteMulti Proxy _ _ reqs baseurl = do

198+ ) => HasClientMulti t m (Verb method status

199+ cts (Headers ls NoContent)) f tag where

200+ 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))))

202+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do

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

150− resp <- performRequestsNoBody method reqs' baseurl

151− return $ (fmap . fmap) toHeaders <$> resp

152− where reqs' = ffor reqs $ \req ->

204+ resp <- performRequestsNoBody method reqs' baseurl opts triggers

205+ return $ fmap toHeaders <$> resp

206+ where reqs' = fmap (\req ->

153207 req {respHeaders = OnlyHeaders (Set.fromList

154208 (buildHeaderKeysTo (Proxy :: Proxy ls)))

155− }

209+ }) <$> reqs

156210

157211

212+------------------------------------------------------------------------------

158213instance (KnownSymbol sym,

159214 ToHttpApiData a,

160− HasClientMulti t m sublayout f,

215+ HasClientMulti t m sublayout f tag,

161216 SupportsServantReflex t m,

162217 Traversable f,

163218 Applicative f)

164− => HasClientMulti t m (Header sym a :> sublayout) f where

219+ => HasClientMulti t m (Header sym a :> sublayout) f tag where

165220

166− type ClientMulti t m (Header sym a :> sublayout) f =

167− f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f

221+ type ClientMulti t m (Header sym a :> sublayout) f tag =

222+ f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag

168223

169− clientWithRouteMulti Proxy f q reqs baseurl eVals =

224+ clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =

170225 clientWithRouteMulti (Proxy :: Proxy sublayout) f

171− q

226+ q tag

172227 reqs'

173− baseurl

228+ baseurl opts

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

175− reqs' = (\eVal req -> Servant.Common.Req.addHeader hname eVal req)

176− <$> eVals <*> reqs

230+ reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)

231+ <$> eVals <*>) <$> reqs

232+

177233

234+------------------------------------------------------------------------------

235+instance HasClientMulti t m sublayout f tag

236+ => HasClientMulti t m (HttpVersion :> sublayout) f tag where

178237

179−instance HasClientMulti t m sublayout f

180− => HasClientMulti t m (HttpVersion :> sublayout) f where

238+ type ClientMulti t m (HttpVersion :> sublayout) f tag =

239+ ClientMulti t m sublayout f tag

181240

182− type ClientMulti t m (HttpVersion :> sublayout) f =

183− ClientMulti t m sublayout f

241+ clientWithRouteMulti Proxy q f tag =

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

184243

185− clientWithRouteMulti Proxy q f =

186− clientWithRouteMulti (Proxy :: Proxy sublayout) q f

187244

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

188251

189−instance (KnownSymbol sym, ToHttpApiData a, HasClientMulti t m sublayout f, Reflex t, Traversable f, Applicative f)

190− => HasClientMulti t m (QueryParam sym a :> sublayout) f where

252+ clientWithRouteMulti Proxy q f tag =

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

191254

192− type ClientMulti t m (QueryParam sym a :> sublayout) f =

193− f (Dynamic t (QParam a)) -> ClientMulti t m sublayout f

255+

256+------------------------------------------------------------------------------

257+instance (KnownSymbol sym,

258+ ToHttpApiData a,

259+ HasClientMulti t m sublayout f tag,

260+ Reflex t,

261+ Applicative f)

262+ => HasClientMulti t m (QueryParam sym a :> sublayout) f tag where

263+

264+ type ClientMulti t m (QueryParam sym a :> sublayout) f tag =

265+ Dynamic t (f (QParam a)) -> ClientMulti t m sublayout f tag

194266

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

196268 -- TODO: Check the above comment

197− clientWithRouteMulti Proxy q f reqs baseurl mparams =

198− clientWithRouteMulti (Proxy :: Proxy sublayout) q f

199− reqs' baseurl

269+ clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =

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

271+ reqs' baseurl opts

200272

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

202274 p prm = QueryPartParam $ fmap qParamToQueryPart prm

203275 paramPair mp = (T.pack pname, p mp)

204− reqs' = (\param req -> req {qParams = paramPair param : qParams req})

276+ -- reqs' = (\params reqs -> (\req param -> req {qParams = paramPair param : qParams req}) <$> reqs <*> params)

277+ -- <$> mparams <*> reqs

278+ reqs' = liftA2 (\(pr :: QParam a) (r :: Req t) -> r { qParams = paramPair (constDyn pr) : qParams r })

205279 <$> mparams <*> reqs

206280

207281

208282instance (KnownSymbol sym,

209283 ToHttpApiData a,

210− HasClientMulti t m sublayout f,

284+ HasClientMulti t m sublayout f tag,

211285 Reflex t,

212− Traversable f,

213286 Applicative f)

214− => HasClientMulti t m (QueryParams sym a :> sublayout) f where

287+ => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where

215288

216− type ClientMulti t m (QueryParams sym a :> sublayout) f =

217− f (Dynamic t [a]) -> ClientMulti t m sublayout f

289+ type ClientMulti t m (QueryParams sym a :> sublayout) f tag =

290+ Dynamic t (f [a]) -> ClientMulti t m sublayout f tag

218291

219− clientWithRouteMulti Proxy q f reqs baseurl paramlists =

220− clientWithRouteMulti (Proxy :: Proxy sublayout) q f reqs' baseurl

292+ clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =

293+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts

221294

222− where req' l r = r { qParams = (T.pack pname, params' l) : qParams r }

295+ where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }

223296 pname = symbolVal (Proxy :: Proxy sym)

224297 params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)

225298 l

226− reqs' = req' <$> paramlists <*> reqs

299+ reqs' = liftA2 req' <$> paramlists <*> reqs

227300

228301

229302instance (KnownSymbol sym,

230− HasClientMulti t m sublayout f,

303+ HasClientMulti t m sublayout f tag,

231304 Reflex t,

232− Traversable f,

233305 Applicative f)

234− => HasClientMulti t m (QueryFlag sym :> sublayout) f where

306+ => HasClientMulti t m (QueryFlag sym :> sublayout) f tag where

235307

236− type ClientMulti t m (QueryFlag sym :> sublayout) f =

237− f (Dynamic t Bool) -> ClientMulti t m sublayout f

308+ type ClientMulti t m (QueryFlag sym :> sublayout) f tag =

309+ Dynamic t (f Bool) -> ClientMulti t m sublayout f tag

238310

239− clientWithRouteMulti Proxy q f reqs baseurl flags =

240− clientWithRouteMulti (Proxy :: Proxy sublayout) q f reqs' baseurl

311+ clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =

312+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts

241313

242− where req' f req = req { qParams = thisPair f : qParams req }

314+ where req' f req = req { qParams = thisPair (constDyn f) : qParams req }

243315 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)

244316 pName = symbolVal (Proxy :: Proxy sym)

245− reqs' = req' <$> flags <*> reqs

317+ reqs' = liftA2 req' <$> flags <*> reqs

246318

247319

248320instance (SupportsServantReflex t m,

249− Traversable f) => HasClientMulti t m Raw f where

250− type ClientMulti t m Raw f = f (Dynamic t (Either Text (XhrRequest ())))

251− -> Event t ()

252− -> m (Event t (f (ReqResult ())))

253−

254− clientWithRouteMulti Proxy Proxy Proxy oldReqs baseurl (rawReqs) triggers = do

255− resps <- performSomeRequestsAsync (tagPromptlyDyn (sequence rawReqs) triggers )

256− return $ (fmap . fmap) aux resps

321+ Traversable f, Applicative f) => HasClientMulti t m Raw f tag where

322+ type ClientMulti t m Raw f tag = f (Dynamic t (Either Text (XhrRequest ())))

323+ -> Event t tag

324+ -> m (Event t (f (ReqResult tag ())))

325+

326+ clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do

327+ let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))

328+ rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers

329+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''

330+ return resps

257331 where

258− aux (Right r) = ResponseSuccess () r

259− aux (Left e) = RequestFailure e

332+ aux (tag, Right r) = ResponseSuccess tag () r

333+ aux (tag, Left e) = RequestFailure tag e

260334

261335

262336instance (MimeRender ct a,

263− HasClientMulti t m sublayout f,

337+ HasClientMulti t m sublayout f tag,

264338 Reflex t,

265− Traversable f,

266339 Applicative f)

267− => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f where

340+ => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where

268341

269− type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f =

270− f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f

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

343+ Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag

271344

272− clientWithRouteMulti Proxy q f reqs baseurl bodies =

273− clientWithRouteMulti (Proxy :: Proxy sublayout) q f reqs' baseurl

274− where req' b r = r { reqBody = bodyBytesCT b }

345+ clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

346+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts

347+ where req' b r = r { reqBody = bodyBytesCT (constDyn b) }

275348 ctProxy = Proxy :: Proxy ct

276349 ctString = T.pack $ show $ contentType ctProxy

277350 bodyBytesCT b = Just $ (fmap . fmap)

278351 (\b' -> (mimeRender ctProxy b', ctString))

279352 b

280− reqs' = req' <$> bodies <*> reqs

353+ reqs' = liftA2 req' <$> bodies <*> reqs

281354

282355

283356instance (KnownSymbol path,

284− HasClientMulti t m sublayout f,

357+ HasClientMulti t m sublayout f tag,

285358 Reflex t,

286− Functor f) => HasClientMulti t m (path :> sublayout) f where

287− type ClientMulti t m (path :> sublayout) f = ClientMulti t m sublayout f

359+ Functor f) => HasClientMulti t m (path :> sublayout) f tag where

360+ type ClientMulti t m (path :> sublayout) f tag = ClientMulti t m sublayout f tag

288361

289− clientWithRouteMulti Proxy q f reqs baseurl =

290− clientWithRouteMulti (Proxy :: Proxy sublayout) q f

291− (prependToPathParts (pure (Right $ T.pack p)) <$> reqs)

362+ clientWithRouteMulti Proxy q f tag reqs baseurl =

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

364+ (fmap (prependToPathParts (pure (Right $ T.pack p))) <$> reqs)

292365 baseurl

293366

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

295368

296369

297−instance HasClientMulti t m api f => HasClientMulti t m (Vault :> api) f where

298− type ClientMulti t m (Vault :> api) f = ClientMulti t m api f

370+instance HasClientMulti t m api f tag => HasClientMulti t m (Vault :> api) f tag where

371+ type ClientMulti t m (Vault :> api) f tag = ClientMulti t m api f tag

299372

300− clientWithRouteMulti Proxy q f reqs baseurl =

301− clientWithRouteMulti (Proxy :: Proxy api) q f reqs baseurl

373+ clientWithRouteMulti Proxy q f tag reqs baseurl =

374+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

302375

303376

304−instance HasClientMulti t m api f => HasClientMulti t m (RemoteHost :> api) f where

305− type ClientMulti t m (RemoteHost :> api) f = ClientMulti t m api f

377+instance HasClientMulti t m api f tag => HasClientMulti t m (RemoteHost :> api) f tag where

378+ type ClientMulti t m (RemoteHost :> api) f tag = ClientMulti t m api f tag

306379

307− clientWithRouteMulti Proxy q f reqs baseurl =

308− clientWithRouteMulti (Proxy :: Proxy api) q f reqs baseurl

380+ clientWithRouteMulti Proxy q f tag reqs baseurl =

381+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

309382

310383

311−instance HasClientMulti t m api f => HasClientMulti t m (IsSecure :> api) f where

312− type ClientMulti t m (IsSecure :> api) f = ClientMulti t m api f

384+instance HasClientMulti t m api f tag => HasClientMulti t m (IsSecure :> api) f tag where

385+ type ClientMulti t m (IsSecure :> api) f tag = ClientMulti t m api f tag

313386

314− clientWithRouteMulti Proxy q f reqs baseurl =

315− clientWithRouteMulti (Proxy :: Proxy api) q f reqs baseurl

387+ clientWithRouteMulti Proxy q f tag reqs baseurl =

388+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

316389

317390

318−instance (HasClientMulti t m api f, Reflex t, Traversable f, Applicative f)

319− => HasClientMulti t m (BasicAuth realm usr :> api) f where

391+instance (HasClientMulti t m api f tag, Reflex t, Applicative f)

392+ => HasClientMulti t m (BasicAuth realm usr :> api) f tag where

320393

321− type ClientMulti t m (BasicAuth realm usr :> api) f = f (Dynamic t (Maybe BasicAuthData))

322− -> ClientMulti t m api f

394+ type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))

395+ -> ClientMulti t m api f tag

323396

324− clientWithRouteMulti Proxy q f reqs baseurl authdatas =

325− clientWithRouteMulti (Proxy :: Proxy api) q f reqs' baseurl

397+ clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =

398+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts

326399 where

327− req' a r = r { authData = Just a }

328− reqs' = req' <$> authdatas <*> reqs

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

401+ reqs' = liftA2 req' <$> authdatas <*> reqs

stack.yamlnew file+56

@@ -0,0 +1,56 @@

1+flags: {}

2+extra-package-dbs: []

3+packages:

4+- '.'

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+2−1

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

99import Data.Foldable

1010import Test.WebDriver.Commands.Wait

1111import Test.Hspec.WebDriver

12+import Test.Hspec.WebDriver (chromeCaps)

1213

1314

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

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

2829spec = do

2930 describe "servant-reflex tests" $ do

3031

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

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

3233

3334 it "opens the page" $ runWD $

3435 openPage "http://localhost:8000"

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

@@ -1 +0,0 @@

1−../exec/API.hs

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeOperators #-}

5+module API where

7+import Data.Aeson

8+import Data.Aeson.Types (typeMismatch)

9+import Data.Text (Text)

10+import Servant.API

11+

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

13+

14+instance ToJSON Question where

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

16+

17+instance FromJSON Question where

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

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

20+

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

22+

23+instance ToJSON Answer where

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

25+

26+instance FromJSON Answer where

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

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

29+

30+

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

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

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

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

35+ :> QueryParams "greetings" Text

36+ :> QueryFlag "gusto"

37+ :> Get '[JSON] Text

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

39+ :> Post '[JSON] Double

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

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

42+ :> Post '[JSON] Answer

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

44+ :<|> Raw

45+

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

47+

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

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

50+type ComprehensiveAPI =

51+ GET :<|>

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

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

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

55+ HttpVersion :> GET :<|>

56+ IsSecure :> GET :<|>

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

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

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

60+-- Raw :<|>

61+ RemoteHost :> GET :<|>

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

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

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

65+ Vault :> GET :<|>

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

67+ Verb 'POST 204 '[JSON] Int

68+-- This one isn't in scope

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

testserver/Main.hs+39−14

@@ -2,27 +2,34 @@

22{-# LANGUAGE DeriveGeneric #-}

33{-# LANGUAGE OverloadedStrings #-}

44{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE TypeApplications #-}

56{-# LANGUAGE TypeFamilies #-}

67{-# LANGUAGE TypeOperators #-}

9+import Control.Monad.IO.Class (liftIO)

10+import Control.Monad.Reader (reader)

811import Data.Aeson

912import Data.Bool

10−import Data.Char (toUpper)

11−import qualified Data.List as L

13+import Data.Char (toUpper)

14+import qualified Data.List as L

15+import Data.Maybe (fromMaybe)

1216import Data.Monoid

1317import Data.Proxy

14−import Data.Text hiding (length, null, map, head, toUpper)

15−import qualified Data.Text as T

18+import Data.Text hiding (head, length, map,

19+ null, toUpper)

20+import qualified Data.Text as T

21+import qualified Data.Text.IO as T

1622import GHC.Generics

17−import Snap.Http.Server

18−import Snap.Core

1923import Servant.Server.Internal.SnapShims

24+import Snap.Core

25+import Snap.Http.Server

2026

21−import Servant -- hiding (serveDirectory)

27+import Servant

2228import Servant.Server

2329-- import Snap.Util.FileServe

30+import System.Environment (lookupEnv)

2431import API

25−import Snap

32+import Snap

2633

2734-- * Example

2835

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

3643testApi :: Proxy API

3744testApi = Proxy

3845

39−data App = App

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

4047

4148-- Server-side handlers.

4249--

@@ -44,8 +51,10 @@ data App = App

4451-- that represents the API, are glued together using :<|>.

4552--

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

47−server :: Server API (Handler App App)

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

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

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

57+ :<|> statics

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

5059 sayhi nm greetings withGusto = case nm of

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

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

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

5968 return . modifier $ greetPart <> n

60− dbl x = return $ x * 2

69+ dbl x = if x `elem` [4,13]

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

71+ else return $ x * 2

6172 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

6285

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

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

6588test :: Handler App App ()

66−test = serveSnap testApi server

89+test = serveSnapWithContext testApi

90+ (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server

6791

6892initApp :: SnapletInit App App

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

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

7095 addRoutes [("", test)

7196 ,("", serveDirectory "static")

7297 ]

73− return App

98+ return (App staticDir)

7499

75100-- Put this all to work!

76101main :: IO ()

testserver/run-wd-tests.shdeleted−5

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

1−#!/usr/bin/env bash

2−

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

4−phantomjs --webdriver=127.0.0.1:4444 &

5−dist/build/spec/spec

testserver/testserver.cabal+17−16

@@ -1,31 +1,32 @@

1−-- Initial back.cabal generated by cabal init. For further documentation,

1+-- Initial back.cabal generated by cabal init. For further documentation,

22-- see http://haskell.org/cabal/users-guide/

44name: testserver

55version: 0.1.0.0

6−-- synopsis:

7−-- description:

6+-- synopsis:

7+-- description:

88license: BSD3

99license-file: LICENSE

1010author: Greg Hale

1111maintainer: imalsogreg@gmail.com

12−-- copyright:

13−-- category:

12+-- copyright:

13+-- category:

1414build-type: Simple

15−-- extra-source-files:

15+-- extra-source-files:

1616cabal-version: >=1.10

1717

1818executable back

1919 main-is: Main.hs

20− -- other-modules:

21− -- other-extensions:

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

23− , base >=4.8 && <4.10

24− , snap >= 1.0 && < 1.1

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

20+ -- other-modules:

21+ -- other-extensions:

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

23+ , base >=4.8 && < 5

24+ , mtl

25+ , snap >= 1.0 && < 1.2

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

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

27− , servant >= 0.7.1 && < 0.9

28− , servant-snap >= 0.7 && < 0.8

29− , text >= 1.2 && < 1.3

30− -- hs-source-dirs:

28+ , servant >= 0.16 && < 0.18

29+ , servant-snap >= 0.8 && < 0.9

30+ , text >= 1.0 && < 1.3

31+ -- hs-source-dirs:

3132 default-language: Haskell2010

testserver/tr.nixdeleted−32

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

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

2−let

3−

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

5− cabal2nixResult = reflex-platform.cabal2nixResult;

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

7−in

8−reflex-platform.ghc.override {

9− overrides = self: super: {

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

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

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

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

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

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

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

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

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

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

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

21−

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

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

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

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

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

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

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

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

30−

31− };

32−}

travis.nixnew file+70

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

1+{

2+ nativeCompiler ? "ghc",

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

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

6+ jsCompiler ? "ghcjs"

7+ # ^ Choose a GHCJS for compiling the frontend

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

10+}:

11+

12+let

13+

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

15+

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

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

18+

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

20+ overrides = self: super: {

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

22+ servant = dontCheck super.servant;

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

24+ servant-reflex = lib.appendConfigureFlag

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

26+ };

27+ };

28+

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

30+ overrides = self: super: {

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

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

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

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

35+ };

36+ };

37+

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

39+ { inherit reflexPlatform;

40+ inherit (ghcPkgs) testserver testdriver;

41+ inherit (reflexPlatform.nixpkgs) curl;

42+ phantomjs = reflexPlatform.nixpkgs.phantomjs2;

43+ };

44+

45+in

46+ rec {

47+

48+ inherit reflexPlatform ghcPkgs ghcjsPkgs;

49+

50+ build = ghcjsPkgs.servant-reflex;

51+ buildGhc = ghcPkgs.servant-reflex;

52+ testserver = ghcPkgs.testserver;

53+ testdriver = ghcPkgs.testdriver;

54+ inherit testresults;

55+

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

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

58+

59+ packages = p: [

60+ build

61+ ];

62+

63+ shellHook = ''

64+ cabal configure --ghcjs -f Example

65+ cabal build

66+ exec/toSite.sh

67+ exit $?

68+ '';

69+ };

70+ }