master..0d570fd · servant-reflex

git.iko.soy/servant-reflex

43 files changed+646−2539

unifiedsplit

.gitignore−4 .gitmodules+18 .travis.yml−17 ChangeLog.md−60 LICENSE.md−30 README.md−224 build.sh+3 default.nix+14−15 deploy_key.enc deps/reflex+1 deps/reflex-dom+1 deps/reflex-dom-contrib+1 deps/servant+1 deps/servant-snap+1 deps/try-reflex+1 exec/API.hs+4−63 exec/Example.hs+31−205 init-sandbox.sh+40 nix/nix.conf−3 nix/reflex-platform.nix−7 nix/servant-snap.nix−7 nix/testresults.nix−17 nix/testserver.nix−9 overrides.nix+11 servant-reflex.cabal+34−49 shell.nix−1 shell.sh+3 src/Servant/Common/BaseUrl.hs+47−68 src/Servant/Common/Req.hs+186−413 src/Servant/Reflex.hs+217−401 src/Servant/Reflex/Multi.hs−401 stack.yaml−56 testdriver/LICENSE.md−30 testdriver/deploy-code-coverage.sh−65 testdriver/runTestsAndCoverage.sh−59 testdriver/test/Servant/ReflexSpec.hs−94 testdriver/test/Spec.hs−1 testdriver/testdriver.cabal−26 testserver/API.hs+1−69 testserver/Main.hs+21−55 testserver/testserver.cabal+10−18 exec/toSite.sh → toSite.sh−2 travis.nix−70

.gitignore−4

@@ -5,7 +5,3 @@ dist

55log

66*.webapp

77*.stats

8−out

9−/.stack-work/

10−TAGS

11−dist-newstyle

.gitmodules+18

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

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

2+ path = deps/reflex-dom-contrib

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

4+[submodule "deps/try-reflex"]

5+ path = deps/try-reflex

6+ url = git@github.com:ryantrinkle/try-reflex.git

7+[submodule "deps/servant"]

8+ path = deps/servant

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

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

11+ path = deps/servant-snap

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

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

14+ path = deps/reflex-dom

15+ url = https://github.com/ryantrinkle/reflex-dom

16+[submodule "deps/reflex"]

17+ path = deps/reflex

18+ url = https://github.com/ryantrinkle/reflex

.travis.ymldeleted−17

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

1−language: nix

2−nix: 2.3.6

3−sudo: require

4−

5−before_install:

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

7−

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"

12−

13−script:

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.mddeleted−60

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

1−0.3.5

2−-----

3−

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

5− - Require servant >= 0.16

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

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

8−

9−0.3.4

10−-----

11−

12−Add selenium-based test suite

13−

14−0.3.3

15−-----

16−

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

18−

19−

20−0.3.2

21−-----

22−

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

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

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

26−or print the Request to the console for debugging

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

28−

29−0.3

30−---

31−

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

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

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

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

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

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

38−will generate a client function:

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

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

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

42−`clientFun

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

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

45−trigger`

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

47−combination of possible parameters, and one response event

48−would carry a list of the four responses.

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

50−a different applicative wrapper: 'ZipList'

51−

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

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

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

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

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

57−

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

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

60−encoding bug!

LICENSE.mddeleted−30

@@ -1,30 +0,0 @@

2−

4−

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

7−

8− * Redistributions of source code must retain the above copyright

9− notice, this list of conditions and the following disclaimer.

10−

11− * Redistributions in binary form must reproduce the above

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

15−

16− * Neither the name of Greg Hale nor the names of other

17− contributors may be used to endorse or promote products derived

18− from this software without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.mddeleted−224

@@ -1,224 +0,0 @@

1−# servant-reflex

2−

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

4−

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

6−

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.

14−

15−

16−## Example

17−

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:

20−

21−```haskell

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

23− :<|> "sayhi" :> QueryParam "username" Text

24− :> QueryParams "greetings" Text

25− :> QueryFlag "gusto"

26− :> Get '[JSON] Text

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

28− :> Post '[JSON] Double

29− :<|> Raw

30−```

31−

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

33−an `XhrRequest`.

34−

35−```haskell

36−

37− runGUI :: forall t m.MonadWidget t m => do

38−

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

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

41− (Proxy :: Proxy m)

42− (Proxy :: Proxy ())

43− (constDyn (BasePath "/"))

44−```

45−

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.

56−

57−```haskell

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

59− getint :: MonadWidget t m

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

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

62−

63− sayhi :: MonadWidget t m

64− => Dynamic t (QParam Text)

65− -- ^ One input parameter - the 'name', wrapped in 'QParam'

66− -> Dynamic t [Text]

67− -- ^ Another input: list of preferred greetings

68− -> Dynamic t Bool

69− -- ^ Flag for capitalizing the response

70− -> Event t ()

71− -- ^ Trigger the XHR Request

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

73−

74− doubleit :: MonadWidget t m

75− => Dynamic t (Either Text Double)

76− -> Event t ()

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

78−```

79−

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:

87−

88−```haskell

89− -- ... continued ...

90− res :: Event t (ReqResult Double) <- doubleIt xs triggers

91− let ys = fmapMaybe reqSuccess res

92− errs = fmapMaybe reqFailure res

93−

94− -- Green <p> tag showing the last good result

95− elAttr "p" ("style" =: "color:green") $ do

96− text "Last good result: "

97− dynText =<< holdDyn "" (fmap show ys)

98−

99− -- Red <p> tag showing the last error, cleared by a new good value

100− elAttr "p" ("style" =: "color:red") $

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

102−```

103−

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:

106−

107−```haskell

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

109− intButton <- button "Get Int"

110− serverInts <- fmapMaybe resSuccess <$> getint intButton

111− display =<< holdDyn (Just 0) serverInts

112−

113− elClass "div" "hello-demo" $ do

114− nameText <- QParamSome . value <$> textInput def

115− greetings <- (fmap words . value) <$> textInput def

116− withGusto <- checkbox def

117− helloButton <- button "Say hi"

118− hellos <- fmapMaybe resResult <$> sayhi nameText greetings withGusto helloButton

119− display =<< holdDyn Nothing hellos

120−

121− elClass "div" "demo-double" $ do

122− inputDouble <- (fmapMaybe readMaybe) <$> textInput def

123− doubleButton <- button "Double it"

124− outputDouble <- fmapMaybe resSuccess <$> doubleit inputDouble doubleButton

125− display =<< holdDyn Nothing outputDouble

126−```

127−

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.

133−

134−

135−## Building the library and test server

136−

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.

144−

145−```

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

147−```

148−

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

150−

151−```

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

153−```

154−

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.

158−

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

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

161−

162−

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

200−```

201−

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

217−

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.shnew file+3

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

1+#!/bin/sh

3+deps/try-reflex/work-on ./overrides.nix ./. --run "cabal configure --ghcjs ; cabal build"

default.nix+14−15

@@ -1,21 +1,20 @@

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

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

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

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

5−, transformers

1+{ mkDerivation, exceptions, http-types, reflex, reflex-dom,

2+ reflex-dom-contrib, servant

63}:

75mkDerivation {

86 pname = "servant-reflex";

9− version = "0.3.6";

10− src = ./.;

11− isLibrary = true;

7+ version = "0.1";

8+ src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;

129 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

10+ isLibrary = true;

11+ buildDepends = [

12+ exceptions

13+ http-types

14+ reflex

15+ reflex-dom

16+ reflex-dom-contrib

17+ servant

1818 ];

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

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

19+ license = null;

2120}

deploy_key.encdeleted

Binary file not shown.

deps/reflexnew file+1

Submodule changed.

deps/reflex-domnew file+1

Submodule changed.

deps/reflex-dom-contribnew file+1

Submodule changed.

deps/servantnew file+1

Submodule changed.

deps/servant-snapnew file+1

Submodule changed.

deps/try-reflexnew file+1

Submodule changed.

exec/API.hs+4−63

@@ -1,69 +1,10 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE TypeOperators #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

54module API where

7−import Data.Aeson

8−import Data.Aeson.Types (typeMismatch)

9−import Data.Text (Text)

10−import Servant.API

6+import Servant.API

117

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

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

339 :<|> "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

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

exec/Example.hs+31−205

@@ -1,219 +1,45 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE OverloadedStrings #-}

5−{-# LANGUAGE RankNTypes #-}

6−{-# LANGUAGE RecursiveDo #-}

71{-# LANGUAGE ScopedTypeVariables #-}

2+{-# LANGUAGE RankNTypes #-}

94module Main where

105

11−------------------------------------------------------------------------------

12−import Data.Bool

136import Data.Maybe

14−import Control.Monad.Fix (MonadFix)

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

16−import Data.Text (Text)

17−import qualified Data.Text as T

18−import qualified Data.Text.Encoding as T

19−import GHC.TypeLits

207import Servant.API

8+import Servant.Reflex

219import API

2210import Data.Proxy

23−import Text.Read (readMaybe)

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

25−import Reflex.Dom (mainWidget)

26−------------------------------------------------------------------------------

27−import Servant.Reflex

28−import Servant.Reflex.Multi

29−

11+import Reflex.Dom

3012

3113api :: Proxy API

3214api = Proxy

3315

34−main :: IO ()

35−main = mainWidget $ do

36− divClass "example-base" run

37− divClass "example-multi" runMulti

38−

39−

40−runMulti :: forall t m. (SupportsServantReflex t m,

41− DomBuilder t m,

42− DomBuilderSpace m ~ GhcjsDomSpace,

43− MonadFix m,

44− PostBuild t m,

45− MonadHold t m) => m ()

46−runMulti = do

47− url <- baseUrlWidget

48− el "br" blank

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

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

51−

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

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

54−

55− b <- button "Run dbl multi"

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−

79− return ()

80−

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

82− DomBuilder t m,

83− DomBuilderSpace m ~ GhcjsDomSpace,

84− MonadFix m,

85− PostBuild t m,

86− MonadHold t m) => m ()

87−run = mdo

88−

89− reqCount <- count $ leftmost

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

91− -- Allow user to choose the url target for the request

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

93− url <- baseUrlWidget

94− el "br" (return ())

95− dynText $ showBaseUrl <$> url

96−

97− el "br" (return ())

98−

99− -- Name the computed API client functions

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

101− return $ r & withCredentials .~ True

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

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

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

105−

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

107−

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

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

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

111−

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

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

16+url :: BaseUrl

17+url = BaseUrl Http "localhost" 8000 ""

11418

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

116−

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

118− leftmost [fmapMaybe response (unitResponse)

119− ,fmapMaybe response (intResponse)

120− ]

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

122− return (unitBtn, intBtn)

123−

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

125−

126− text "Name"

127− el "br" $ return ()

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

129− let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp

130− el "br" $ return ()

131−

132− text "Greetings (space-separated)"

133− el "br" $ return ()

134− greetings <- fmap (fmap T.words . value) $

135− divClass "greetings-input" $ (textInput def)

136−

137− el "br" $ return ()

138−

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

140−

141− el "br" $ return ()

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

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

144−

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

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

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

148− , fmapMaybe reqFailure (resp)])

149− return sayHiClicks

150−

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

152− text "A Double to double"

153− el "br" $ return ()

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

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

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

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

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

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

160− el "br" (return ())

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

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

163− fmapMaybe reqSuccess (dblResp))

164− return dblBtn

165−

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

167− text "Multi-part path"

168− b <- value <$> checkbox False def

169− mpGo <- button "Test"

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

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

172− fmapMaybe reqSuccess $

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−

200−

201−showXhrResponse :: XhrResponse -> Text

202−showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

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

204− ,"stattxt: " <> tShow stattxt

205− ,"resp: " <> maybe "" showRB rbmay

206− ,"rtext: " <> tShow rtmay

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

208−

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

210−tShow = T.pack . show

211−

212−showRB :: XhrResponseBody -> Text

213−showRB (XhrResponseBody_Default t) = tShow t

214−showRB (XhrResponseBody_Text t) = tShow t

19+main :: IO ()

20+main = mainWidget run

21+

22+run :: forall t m. MonadWidget t m => m ()

23+run = do

24+ let (getUnit :<|> getInt :<|> doRaw) = client api (Proxy :: Proxy m) (constDyn url)

25+ b :: Event t () <- button "Get unit"

26+ b' :: Event t () <- button "Get int"

27+ res :: Event t (Maybe (), XhrResponse) <- getUnit b

28+ res' :: Event t (Maybe Int, XhrResponse) <- getInt b'

29+ r <- holdDyn "Waiting" $ leftmost [fmap (showXhrResponse . snd) res

30+ ,fmap (showXhrResponse . snd) res'

31+ ]

32+ dynText r

33+

34+showXhrResponse :: XhrResponse -> String

35+showXhrResponse (XhrResponse stat stattxt rbmay rtmay) =

36+ unlines ["stat: " ++ show stat

37+ ,"stattxt: " ++ show stattxt

38+ ,"resp: " ++ maybe "" showRB rbmay

39+ ,"rtext: " ++ show rtmay]

40+

41+showRB :: XhrResponseBody -> String

42+showRB (XhrResponseBody_Default t) = show t

43+showRB (XhrResponseBody_Text t) = show t

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

216−showRB (XhrResponseBody_ArrayBuffer t) = tShow t

217−

218−note :: e -> Maybe a -> Either e a

219−note e = maybe (Left e) Right

45+showRB (XhrResponseBody_ArrayBuffer t) = show t

init-sandbox.shnew file+40

@@ -0,0 +1,40 @@

1+#! /bin/sh

3+cabal sandbox init

5+cabal sandbox add-source deps/snaplet-postgresql-simple

7+#! /bin/sh

9+cabal sandbox init

10+

11+echo "Depend on snap-1.0 from github. Move to Hackage version when snap-1.0 is released"

12+cabal sandbox add-source deps/servant-snap/deps/snap/deps/io-streams

13+cabal sandbox add-source deps/servant-snap/deps/snap/deps/io-streams-haproxy

14+cabal sandbox add-source deps/servant-snap/deps/snap/deps/snap-core

15+cabal sandbox add-source deps/servant-snap/deps/snap/deps/snap-server

16+cabal sandbox add-source deps/servant-snap/deps/snap/deps/xmlhtml

17+cabal sandbox add-source deps/servant-snap/deps/snap/deps/heist

18+cabal sandbox add-source deps/servant-snap/deps/snap-loader-static

19+cabal sandbox add-source deps/servant-snap/deps/snap-loader-static

20+cabal sandbox add-source deps/servant-snap/deps/snap

21+cabal sandbox add-source deps/servant-snap/deps/hspec-snap

22+

23+echo "Depend on particular servant branch with (Raw m a) changes"

24+echo "TODO: Move to hackage version when servant-0.5 is released"

25+cabal sandbox add-source deps/servant-snap/deps/servant/servant

26+cabal sandbox add-source deps/servant-snap/deps/servant/servant-docs

27+cabal sandbox add-source deps/servant-snap/deps/servant/servant-client

28+cabal sandbox add-source deps/servant-snap/deps/servant/servant-blaze

29+cabal sandbox add-source deps/servant-snap/deps/servant/servant-js

30+cabal sandbox add-source deps/servant-snap/deps/servant/servant-lucid

31+cabal sandbox add-source deps/servant-snap/deps/servant/servant-mock

32+

33+cabal sandbox add-source deps/servant-snap

34+cabal sandbox add-source deps/reflex

35+cabal sandbox add-source deps/reflex-dom

36+cabal sandbox add-source deps/reflex-dom-contrib

37+

38+cabal sandbox add-source .

39+

40+cd testserver && cabal sandbox init --sandbox=../.cabal-sandbox && cd ..

nix/nix.confdeleted−3

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

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

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

3−trusted-users = travis

nix/reflex-platform.nixdeleted−7

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

1−let

2− rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;

3−in import (builtins.fetchTarball

4− {

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

6− sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;

7− }) {}

nix/servant-snap.nixdeleted−7

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

1−# Servant-snap is marked broken in nixpkgs

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

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

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

5− rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";

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

7−}) {}

nix/testresults.nixdeleted−17

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

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

2−

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

4− echo About to phantom

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

6− sleep 3

7− echo About to Server

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

9− sleep 3

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

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

12− echo About to testdrive

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

14− echo Done

15− trap "exit" INT TERM

16− trap "kill 0" EXIT

17− ''

nix/testserver.nixdeleted−9

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

1−servant-reflex: self: super:

2−

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

4− postInstall = ''

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

6− mkdir $out/static

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

8− '';

9−})

overrides.nixnew file+11

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

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

2+let

3+ pkgs = import <nixpkgs> {};

4+ try-reflex = import deps/try-reflex {};

5+in try-reflex.ghcjs.override {

6+ overrides = self: super: {

7+ self.lens = pkgs.haskell.lib.dontCheck (self.lens);

8+ reflex-dom-contrib = pkgs.haskell.lib.dontCheck (self.callPackage deps/reflex-dom-contrib {});

9+ servant = self.callPackage (try-reflex.cabal2nixResult deps/servant/servant) {};

10+ };

11+}

servant-reflex.cabal+34−49

@@ -1,70 +1,55 @@

11Name: servant-reflex

2−Version: 0.3.6

3−Synopsis: servant API generator for reflex apps

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

5−License: BSD3

6−License-file: LICENSE.md

7−Author: Greg Hale, Doug Beardsley

8−Maintainer: imalsogreg@gmail.com

2+Version: 0.1

3+Synopsis: Servant reflex API generator

4+Description: Servant reflex API generator

5+License: AllRightsReserved

6+License-file: LICENSE

7+Author: Doug Beardsley

8+Maintainer: mightybyte@gmail.com

99Stability: Experimental

1010Category: Web

1111Build-type: Simple

12−Cabal-version: >=1.10

13−

14−Flag Example

15− description: Enable example

16− default: False

12+Cabal-version: >=1.8

1713

1814library

19− exposed-modules:

15+ exposed-modules:

16+ Servant.Reflex

17+

18+ other-modules:

2019 Servant.Common.BaseUrl

2120 Servant.Common.Req

22− Servant.Reflex

23− Servant.Reflex.Multi

2421

2522 hs-source-dirs: src

2623 build-depends:

27− base >= 4.8 && < 5,

24+ base,

2825 bytestring >= 0.10 && < 0.11,

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

30− containers >= 0.5.6 && < 0.7,

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

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,

37− mtl >= 2.2.1 && < 2.3,

26+ containers,

27+ data-default >= 0.5 && < 0.6,

28+ exceptions >= 0.8 && < 0.9,

29+ ghcjs-base,

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

31+ http-api-data >= 0.2 && < 0.3,

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

33+-- http-types >= 0.8 && < 0.9,

34+ mtl,

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

39− reflex >= 0.5 && < 0.9,

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

41− safe >= 0.3.9 && < 0.4,

42− servant >= 0.16 && < 0.18,

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

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

45− text >= 1.2 && < 1.3,

46− transformers >= 0.4 && < 0.6

36+ reflex,

37+ reflex-dom,

38+ safe,

39+ servant >= 0.5 && < 0.6,

40+ string-conversions,

41+ text,

42+ transformers >= 0.4 && < 0.5

4743

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

44+ if impl(ghcjs)

45+ build-depends: ghcjs-base

4946

50− default-language: Haskell2010

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

5148

5249executable example

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

50+ build-depends: reflex, servant-reflex, base, servant, reflex-dom

6751 default-language: Haskell2010

6852 main-is: Example.hs

6953 other-modules: API

7054 hs-source-dirs: exec

55+

shell.nixdeleted−1

@@ -1 +0,0 @@

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

shell.shnew file+3

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

1+#!/bin/sh

3+deps/try-reflex/work-on ./overrides.nix ./.

src/Servant/Common/BaseUrl.hs+47−68

@@ -1,98 +1,77 @@

1−{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveGeneric #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE GADTs #-}

6−{-# LANGUAGE OverloadedStrings #-}

7−{-# LANGUAGE ViewPatterns #-}

8−{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE ViewPatterns #-}

104module Servant.Common.BaseUrl (

115 -- * types

126 BaseUrl (..)

7+ , InvalidBaseUrlException

138 , Scheme (..)

149 -- * functions

15− , baseUrlWidget

10+ , parseBaseUrl

1611 , showBaseUrl

17−

18− -- * constraints

19− , SupportsServantReflex

2012) where

2113

22−import Control.Monad (join)

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

24−import Control.Monad.Fix (MonadFix)

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

26−import Data.Text (Text)

27−import qualified Data.Text as T

14+import Control.Monad.Catch (Exception, MonadThrow, throwM)

15+import Data.List

16+import Data.Typeable

2817import GHC.Generics

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

30−import Reflex

31−import Reflex.Dom.Core

18+import Network.URI hiding (path)

19+import Safe

3220import Text.Read

3321

34−

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

36−

3722-- | URI scheme to use

3823data Scheme =

3924 Http -- ^ http://

4025 | Https -- ^ https://

41− deriving (Show, Read, Eq, Ord, Generic)

26+ deriving (Show, Eq, Ord, Generic)

4227

4328-- | Simple data type to represent the target of HTTP requests

4429-- for servant's automatically-generated clients.

45−data BaseUrl = BaseFullUrl Scheme Text Int Text

46− | BasePath Text

47− deriving (Ord, Read, Show, Generic)

48−

30+data BaseUrl = BaseUrl

31+ { baseUrlScheme :: Scheme -- ^ URI scheme to use

32+ , baseUrlHost :: String -- ^ host (eg "haskell.org")

33+ , baseUrlPort :: Int -- ^ port (eg 80)

34+ , baseUrlPath :: String -- ^ path (eg "/a/b/c")

35+ } deriving (Show, Ord, Generic)

4936

5037instance Eq BaseUrl where

51− BasePath s == BasePath s' = s == s'

52− BaseFullUrl a b c path == BaseFullUrl a' b' c' path'

38+ BaseUrl a b c path == BaseUrl a' b' c' path'

5339 = a == a' && b == b' && c == c' && s path == s path'

54− where s x = if T.isPrefixOf "/" x then T.tail x else x

55− _ == _ = False

40+ where s ('/':x) = x

41+ s x = x

5642

57−showBaseUrl :: BaseUrl -> Text

58−showBaseUrl (BasePath s) = s

59−showBaseUrl (BaseFullUrl urlscheme host port path) =

60− schemeString <> "//" <> host <> (portString </> path)

43+showBaseUrl :: BaseUrl -> String

44+showBaseUrl (BaseUrl urlscheme host port path) =

45+ schemeString ++ "//" ++ host ++ (portString </> path)

6146 where

62− a </> b = if "/" `T.isPrefixOf` b || T.null b then a <> b else a <> "/" <> b

47+ a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b

6348 schemeString = case urlscheme of

6449 Http -> "http:"

6550 Https -> "https:"

6651 portString = case (urlscheme, port) of

6752 (Http, 80) -> ""

6853 (Https, 443) -> ""

69− _ -> ":" <> T.pack (show port)

54+ _ -> ":" ++ show port

55+

56+data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)

57+instance Exception InvalidBaseUrlException

7058

71−baseUrlWidget :: forall t m .(SupportsServantReflex t m,

72− DomBuilderSpace m ~ GhcjsDomSpace,

73− MonadFix m,

74− PostBuild t m,

75− MonadHold t m,

76− DomBuilder t m)

77− => m (Dynamic t BaseUrl)

78−baseUrlWidget = elClass "div" "base-url" $ do

79− urlWidget <- dropdown (0 :: Int) (constDyn $ 0 =: "BasePath" <> 1 =: "BaseUrlFull") def

80− let bUrlWidget = ffor (value urlWidget) $ \i -> case i of

81− 0 -> pathWidget

82− 1 -> fullUrlWidget

83− _ -> error "Surprising value"

84− join <$> widgetHold pathWidget (updated bUrlWidget)

85− where pathWidget :: m (Dynamic t BaseUrl)

86− pathWidget = do

87− text "Url base path"

88− t <- inputElement def

89− return $ BasePath <$> value t

90− fullUrlWidget :: m (Dynamic t BaseUrl)

91− fullUrlWidget = do

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

93− srv <- inputElement def

94− text ":"

95− prt <- inputElement def

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

97− path <- inputElement def

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

59+parseBaseUrl :: MonadThrow m => String -> m BaseUrl

60+parseBaseUrl s = case parseURI (removeTrailingSlash s) of

61+ -- This is a rather hacky implementation and should be replaced with something

62+ -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).

63+ Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->

64+ return (BaseUrl Http host port path)

65+ Just (URI "http:" (Just (URIAuth "" host "")) path "" "") ->

66+ return (BaseUrl Http host 80 path)

67+ Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->

68+ return (BaseUrl Https host port path)

69+ Just (URI "https:" (Just (URIAuth "" host "")) path "" "") ->

70+ return (BaseUrl Https host 443 path)

71+ _ -> if "://" `isInfixOf` s

72+ then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)

73+ else parseBaseUrl ("http://" ++ s)

74+ where

75+ removeTrailingSlash str = case lastMay str of

76+ Just '/' -> init str

77+ _ -> str

src/Servant/Common/Req.hs+186−413

@@ -1,431 +1,204 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

12{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE GADTs #-}

53{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE LambdaCase #-}

7−{-# LANGUAGE RankNTypes #-}

84{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TupleSections #-}

10−

115module Servant.Common.Req where

126

13−-------------------------------------------------------------------------------

14−import Control.Applicative (liftA2, liftA3)

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

16−import Control.Concurrent

17−import Control.Monad (join)

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

19−import Data.Bifunctor (first)

20−import qualified Data.ByteString.Builder as Builder

7+-- import Control.Exception

8+-- import Control.Monad

9+-- import Control.Monad.Catch (MonadThrow)

10+-- import Control.Monad.IO.Class

11+-- import Control.Monad.Trans.Except

12+import Data.ByteString.Char8 hiding (pack, filter, map, null, elem)

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

22−import Data.ByteString (ByteString)

23−import qualified Data.Map as Map

24−import Data.Maybe (catMaybes, fromMaybe)

25−import Data.Functor.Compose

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

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

28−import Data.Text (Text)

29−import qualified Data.Text as T

30−import qualified Data.Text.Encoding as TE

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)

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

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

39−-------------------------------------------------------------------------------

40−import Servant.API.BasicAuth

41−

42−

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

80−

81−

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

95−

96−------------------------------------------------------------------------------

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

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

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

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

101−reqFailure' _ = Nothing

102−

103−

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

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

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

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

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

109−response _ = Nothing

110−

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

112−-- | Retrieve response tag

113−reqTag :: ReqResult tag a -> tag

114−reqTag (ResponseSuccess tag _ _) = tag

115−reqTag (ResponseFailure tag _ _) = tag

116−reqTag (RequestFailure tag _ ) = tag

14+import qualified Data.Text.Encoding as TE

15+-- import qualified Data.Foldable as F

16+import qualified Data.List as L

17+import Data.Proxy

18+-- import Data.Monoid

19+-- import Data.String

20+-- import Data.String.Conversions

21+-- import Data.Proxy

22+-- import Data.Text (Text)

23+-- import Data.Text.Encoding

24+-- import Data.Typeable

25+-- import Network.HTTP.Client hiding (Proxy, path)

26+-- import Network.HTTP.Media

27+-- import Network.HTTP.Types

28+-- import qualified Network.HTTP.Types.Header as HTTP

29+-- import Network.URI hiding (path)

30+-- import Servant.API.ContentTypes

31+import Servant.Common.BaseUrl

32+import Servant.API.ContentTypes

33+import Reflex

34+import Reflex.Dom

35+

36+-- import qualified Network.HTTP.Client as Client

37+

38+import Web.HttpApiData

39+

40+-- data ServantError

41+-- = FailureResponse

42+-- { responseStatus :: Status

43+-- , responseContentType :: MediaType

44+-- , responseBody :: ByteString

45+-- }

46+-- | DecodeFailure

47+-- { decodeError :: String

48+-- , responseContentType :: MediaType

49+-- , responseBody :: ByteString

50+-- }

51+-- | UnsupportedContentType

52+-- { responseContentType :: MediaType

53+-- , responseBody :: ByteString

54+-- }

55+-- | InvalidContentTypeHeader

56+-- { responseContentTypeHeader :: ByteString

57+-- , responseBody :: ByteString

58+-- }

59+-- | ConnectionError

60+-- { connectionError :: SomeException

61+-- }

62+-- deriving (Show, Typeable)

63+

64+-- instance Exception ServantError

11765

118−-------------------------------------------------------------------------------

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

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

121−-- invalid

122−data QParam a = QParamSome a

123− -- ^ A valid query parameter

124− | QNone

125− -- ^ Indication that the parameter is intentionally absent (the request is valid)

126− | QParamInvalid Text

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

128−

129−

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

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

132−qParamToQueryPart QNone = Right Nothing

133−qParamToQueryPart (QParamInvalid e) = Left e

134−

135−

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

137− | QueryPartParams (Dynamic t [Text])

138− | QueryPartFlag (Dynamic t Bool)

139−

140−

141−-------------------------------------------------------------------------------

142−-- The data structure used to build up request information while traversing

143−-- the shape of a servant API

14466data Req t = Req

145− { reqMethod :: Text

146− , reqPathParts :: [Dynamic t (Either Text Text)]

147− , qParams :: [(Text, QueryPart t)]

148− , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))

149− , headers :: [(Text, Dynamic t (Either Text Text))]

150− , respHeaders :: XhrResponseHeaders

151− , authData :: Maybe (Dynamic t (Maybe BasicAuthData))

67+ { reqPathParts :: [Behavior t (Maybe String)]

68+ , qParams :: [(String, Behavior t String)]

69+ , reqBody :: Maybe (ByteString, String)

70+ -- , reqAccept :: [MediaType]

71+ , headers :: [(String, Behavior t String)]

15272 }

15373

15474defReq :: Req t

155−defReq = Req "GET" [] [] Nothing [] def Nothing

75+defReq = Req [] [] Nothing []

15676

157−prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t

77+prependToPathParts :: Reflex t => Behavior t (Maybe String) -> Req t -> Req t

15878prependToPathParts p req =

15979 req { reqPathParts = p : reqPathParts req }

16080

161−addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t

162−addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }

163−

164−

165−reqToReflexRequest

166− :: forall t. Reflex t

167− => Text

168− -> Dynamic t BaseUrl

169− -> Req t

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

171−reqToReflexRequest reqMeth reqHost req =

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

173− t = sequence $ reverse $ reqPathParts req

174−

175− baseUrl :: Dynamic t (Either Text Text)

176− baseUrl = Right . showBaseUrl <$> reqHost

177−

178− urlParts :: Dynamic t (Either Text [Text])

179− urlParts = fmap sequence t

180−

181− urlPath :: Dynamic t (Either Text Text)

182− urlPath = (fmap.fmap)

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

184− urlParts

185−

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

187− queryPartString (pName, qp) = case qp of

188− QueryPartParam p -> ffor p $ \case

189− Left e -> Just (Left e)

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

191− Right Nothing -> Nothing

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

193− if null pStrings

194− then Nothing

195− else Just . Right

196− . T.intercalate "&"

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

198− QueryPartFlag fl -> ffor fl $ \case

199− True -> Just $ Right pName

200− False -> Nothing

201−

202−

203− queryPartStrings :: [Dynamic t (Maybe (Either Text Text))]

204− queryPartStrings = map queryPartString (qParams req)

205− queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Dynamic t (Either Text [Text])

206− queryString :: Dynamic t (Either Text Text) =

207− ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs

208− xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q)

209− baseUrl urlPath queryString

210− where

211− (</>) :: Text -> Text -> Text

212− x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y

213− | otherwise = x <> "/" <> y

214−

215−

216− xhrHeaders :: Dynamic t (Either Text [(Text, Text)])

217− xhrHeaders = (fmap sequence . sequence . fmap f . headers) req

218− where

219− f = \(headerName, dynam) ->

220− fmap (fmap (\rightVal -> (headerName, rightVal))) dynam

221−

222− mkConfigBody :: Either Text [(Text,Text)]

223− -> (Either Text (BL.ByteString, Text))

224− -> Either Text (XhrRequestConfig XhrPayload)

225− mkConfigBody ehs rb = case (ehs, rb) of

226− (_, Left e) -> Left e

227− (Left e, _) -> Left e

228− (Right hs, Right (bBytes, bCT)) ->

229− Right $ XhrRequestConfig

230− { _xhrRequestConfig_sendData = bytesToPayload bBytes

231− , _xhrRequestConfig_headers =

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

233− , _xhrRequestConfig_user = Nothing

234− , _xhrRequestConfig_password = Nothing

235− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

236− , _xhrRequestConfig_withCredentials = False

237− , _xhrRequestConfig_responseHeaders = def

238− }

239−

240− xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))

241− xhrOpts = case reqBody req of

242− Nothing -> ffor xhrHeaders $ \case

243− Left e -> Left e

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

245− , _xhrRequestConfig_user = Nothing

246− , _xhrRequestConfig_password = Nothing

247− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

248− , _xhrRequestConfig_sendData = mempty

249− , _xhrRequestConfig_withCredentials = False

250− }

251− Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

252−

253− mkAuth :: Maybe BasicAuthData -> Either Text (XhrRequestConfig x) -> Either Text (XhrRequestConfig x)

254− mkAuth _ (Left e) = Left e

255− mkAuth Nothing r = r

256− mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config

257− { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u

258− , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}

259−

260− addAuth :: Dynamic t (Either Text (XhrRequestConfig x))

261− -> Dynamic t (Either Text (XhrRequestConfig x))

262− addAuth xhr = case authData req of

263− Nothing -> xhr

264− Just auth -> liftA2 mkAuth auth xhr

265−

266− xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)

267−

268− in xhrReq

81+addHeader :: (ToHttpApiData a, Reflex t) => String -> Behavior t (Maybe a) -> Req t -> Req t

82+addHeader name val req = req { headers = headers req

83+ ++ [(name, fmap (unpack . toHeader) val)]

84+-- ++ [(name, (fmap . fmap) (decodeUtf8 . toHeader) val)]

85+ }

86+

87+-- setRQBody :: ByteString -> String -> Req -> Req

88+-- setRQBody b t req = req { reqBody = Just (b, t) }

89+

90+-- TODO: Helpful soon!

91+-- reqToRequest :: (Reflex t, Functor m, MonadThrow m) => Req t -> BaseUrl -> m Request

92+-- reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =

93+-- setheaders . setAccept . setrqb . setQS <$> parseUrl url

94+

95+-- where url = show $ nullURI { uriScheme = case reqScheme of

96+-- Http -> "http:"

97+-- Https -> "https:"

98+-- , uriAuthority = Just $

99+-- URIAuth { uriUserInfo = ""

100+-- , uriRegName = reqHost

101+-- , uriPort = ":" ++ show reqPort

102+-- }

103+-- , uriPath = path ++ reqPath req

104+-- }

105+

106+-- setrqb r = case reqBody req of

107+-- Nothing -> r

108+-- Just (b,t) -> r { requestBody = RequestBodyLBS b

109+-- , requestHeaders = requestHeaders r

110+-- ++ [(hContentType, cs . show $ t)] }

111+-- setQS = setQueryString $ queryTextToQuery (qs req)

112+-- setheaders r = r { requestHeaders = requestHeaders r

113+-- <> fmap toProperHeader (headers req) }

114+-- setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)

115+-- <> [("Accept", renderHeader $ reqAccept req)

116+-- | not . null . reqAccept $ req] }

117+-- toProperHeader (name, val) =

118+-- (fromString name, encodeUtf8 val)

269119

270120-- * performing requests

271121

272−displayHttpRequest :: Text -> Text

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

274−

275−-- | This function performs the request

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

277− => Text

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

279− -> Dynamic t BaseUrl

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.

298−performSomeRequestsAsync

299− :: (MonadIO (Performable m),

300− MonadJSM (Performable m),

301− HasWebView (Performable m),

302− PerformEvent t m,

303− TriggerEvent t m,

304− Traversable f,

305− IsXhrPayload a,

306− Show a

307− )

308− => ClientOptions

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

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

311−performSomeRequestsAsync opts =

312− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

313−

314−

315−------------------------------------------------------------------------------

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

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

318−performSomeRequestsAsync'

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

320− => ClientOptions

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

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

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

324− rs <- hrs

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

326− Left e -> do

327− resp <- liftIO $ newMVar (Left e)

328− return resp

329− Right r' -> do

330− resp <- liftIO newEmptyMVar

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

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

333− return resp

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

335− return ()

336−

337−

338−

339−type XhrPayload = ByteString

340−bytesToPayload :: BL.ByteString -> XhrPayload

341−bytesToPayload = BL.toStrict

342−

343−

344−performRequestsCT

345− :: (SupportsServantReflex t m,

346− MimeUnrender ct a, Traversable f)

347− => Proxy ct

348− -> Text

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

350− -> Dynamic t BaseUrl

351− -> ClientOptions

352− -> Event t tag

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

354−performRequestsCT ct reqMeth reqs reqHost opts trigger = do

355− resps <- performRequests reqMeth reqs reqHost opts trigger

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

357− first T.pack .

358− mimeUnrender ct $

359− BL.fromStrict x

360− decodeResp _ = Left "No body"

361− return $ fmap

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

363− Left e -> RequestFailure t e

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

365− )

366− resps

367−

368−

369−performRequestsNoBody

370− :: (SupportsServantReflex t m,

371− Traversable f)

372− => Text

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

374− -> Dynamic t BaseUrl

375− -> ClientOptions

376− -> Event t tag

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

378−performRequestsNoBody reqMeth reqs reqHost opts trigger = do

379− resps <- performRequests reqMeth reqs reqHost opts trigger

380− let decodeResp = const $ Right NoContent

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

382− Left e -> RequestFailure tag e

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

384−

385−

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

387−evalResponse

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

389− -> (tag, XhrResponse)

390− -> ReqResult tag a

391−evalResponse decode (tag, xhr) =

392− let status = _xhrResponse_status xhr

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

394− errMsg = fromMaybe

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

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

397− (_xhrResponse_responseText xhr)

398− respPayld = if okStatus

399− then either

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

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

402− (decode xhr)

403− else ResponseFailure tag errMsg xhr

404− in respPayld

405−

406−------------------------------------------------------------------------------

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

408−-- response 'Event's,

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

410−fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess

411−

412−------------------------------------------------------------------------------

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

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

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

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

417−

418−

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

420−note e = maybe (Left e) Right

421−

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

423−fmapL _ (Right a) = Right a

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

425−

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

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

428−

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

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

431−

122+displayHttpRequest :: String -> String

123+displayHttpRequest httpmethod = "HTTP " ++ httpmethod ++ " request"

124+

125+

126+performRequest :: forall t m.MonadWidget t m => String -> Req t -> Dynamic t BaseUrl

127+ -> Event t ()

128+ -> m (Event t XhrResponse)

129+ -- -> ExceptT ServantError IO ( Int, ByteString, MediaType

130+ -- , [HTTP.Header], Response ByteString)

131+performRequest reqMethod req _ trigger = do

132+ let t :: Behavior t [Maybe String] = sequence $ reqPathParts req

133+ let urlParts :: Behavior t (Maybe [String]) = fmap sequence t

134+ let urlPath :: Behavior t (Maybe String) = (fmap.fmap) (L.intercalate "/") urlParts

135+ xhrReq = (fmap . fmap) (\p -> XhrRequest reqMethod p def) urlPath

136+ performRequestAsync (fmapMaybe id $ tag xhrReq trigger)

137+

138+-- TODO implement

139+-- => String -> Req -> BaseUrl -> ExceptT ServantError IO [HTTP.Header]

140+ -- TODO Proxy probably not needed

141+performRequestNoBody ::

142+ forall t m .MonadWidget t m => Proxy m -> String -> Req t -> Dynamic t BaseUrl

143+ -> Event t () -> m (Event t XhrResponse)

144+performRequestNoBody _ reqMethod req reqHost trigger = do

145+ performRequest reqMethod req reqHost trigger

146+ -- return hdrs

147+

148+performRequestCT :: (MonadWidget t m, FromHttpApiData a, MimeUnrender ct a)

149+ => Proxy ct -> String -> Req t -> Dynamic t BaseUrl

150+ -> Event t () -> m (Event t (Maybe a, XhrResponse))

151+performRequestCT ct reqMethod req reqHost trigger = do

152+ resp <- performRequest reqMethod req reqHost trigger

153+ return $ ffor resp $ \xhr -> (hushed (mimeUnrender ct . BL.fromStrict . TE.encodeUtf8) =<< _xhrResponse_responseText xhr, xhr)

154+ where hushed :: (x -> Either e y) -> (x -> Maybe y)

155+ hushed f ea = case f ea of

156+ Left e -> Nothing

157+ Right a -> Just a

158+

159+

160+ -- partialRequest <- liftIO $ reqToRequest req reqHost

161+

162+ -- let request = partialRequest { Client.method = reqMethod

163+ -- , checkStatus = \ _status _headers _cookies -> Nothing

164+ -- , qs :: QueryText

165+ -- , qs :: QueryText

166+ -- }

167+

168+ -- eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager

169+ -- case eResponse of

170+ -- Left err ->

171+ -- throwE . ConnectionError $ SomeException err

172+

173+ -- Right response -> do

174+ -- let status = Client.responseStatus response

175+ -- body = Client.responseBody response

176+ -- hdrs = Client.responseHeaders response

177+ -- status_code = statusCode status

178+ -- ct <- case lookup "Content-Type" $ Client.responseHeaders response of

179+ -- Nothing -> pure $ "application/octet-stream"

180+ -- Just t -> case parseAccept t of

181+ -- Nothing -> throwE $ InvalidContentTypeHeader (cs t) body

182+ -- Just t' -> pure t'

183+ -- unless (status_code >= 200 && status_code < 300) $

184+ -- throwE $ FailureResponse status ct body

185+ -- return (status_code, body, ct, hdrs, response)

186+

187+

188+-- TODO implement

189+-- performRequestCT :: (MimeUnrender ct result, Reflex t) =>

190+-- Proxy ct -> String -> Req t -> BaseUrl -> Event t ()

191+-- -> m (Event t (Maybe result, XhrResponse)) -- ExceptT ServantError IO ([HTTP.Header], result)

192+-- performRequestCT ct reqMethod req reqHost = do

193+-- let acceptCT = contentType ct

194+-- (_status, respBody, respCT, hdrs, _response) <-

195+-- performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager

196+-- unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody

197+-- case mimeUnrender ct respBody of

198+-- Left err -> throwE $ DecodeFailure err respCT respBody

199+-- Right val -> return (hdrs, val)

200+

201+-- catchConnectionError :: IO a -> IO (Either ServantError a)

202+-- catchConnectionError action =

203+-- catch (Right <$> action) $ \e ->

204+-- pure . Left . ConnectionError $ SomeException (e :: HttpException)

src/Servant/Reflex.hs+217−401

@@ -1,23 +1,15 @@

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

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE InstanceSigs #-}

6+{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TypeFamilies #-}

10+{-# LANGUAGE TypeOperators #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+{-# LANGUAGE MultiParamTypeClasses #-}

2113

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

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

@@ -25,71 +17,29 @@

2517-- API.

2618module Servant.Reflex

2719 ( client

28− , clientWithOpts

29− , clientWithOptsAndResultHandler

30− , clientWithRoute

31− , clientWithRouteAndResultHandler

32− , BuildHeaderKeysTo(..)

33− , toHeaders

34− , HasClient

35− , Client

36− , module Servant.Common.Req

20+ , HasClient(..)

3721 , module Servant.Common.BaseUrl

3822 ) where

3923

40−------------------------------------------------------------------------------

41−import Control.Applicative

42−import qualified Data.CaseInsensitive as CI

43−import Data.Functor.Identity

44−import qualified Data.Map as Map

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

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

47−import qualified Data.Set as Set

48−import Data.Text (Text)

49−import qualified Data.Text as T

50−import qualified Data.Text.Encoding as E

51−import GHC.Exts (Constraint)

52−import GHC.TypeLits (KnownSymbol, symbolVal)

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

54− BasicAuthData, BuildHeadersTo (..),

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

56− HttpVersion, IsSecure,

57− MimeRender (..), MimeUnrender,

58− NoContent, QueryFlag, QueryParam,

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

60− RemoteHost, ReqBody,

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)

72−------------------------------------------------------------------------------

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

74− showBaseUrl,

75− SupportsServantReflex)

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

77− defaultClientOptions,

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

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

80− defReq, evalResponse, prependToPathParts,

81− -- performRequestCT,

82− performRequestsCT,

83− -- performRequestNoBody,

84− performRequestsNoBody,

85− performSomeRequestsAsync,

86− qParamToQueryPart, reqBody,

87− reqSuccess, reqFailure,

88− reqMethod, respHeaders,

89− response,

90− reqTag,

91− qParams, withCredentials)

92−

24+import Control.Applicative ((<$>))

25+import Control.Monad.Trans.Except

26+import Data.ByteString.Lazy (ByteString)

27+import Data.List

28+import Data.Proxy

29+import Data.String.Conversions

30+import Data.Text (unpack)

31+import qualified Data.ByteString.Char8 as BS

32+import GHC.TypeLits

33+-- import Network.HTTP.Media

34+-- import qualified Network.HTTP.Types as H

35+-- import qualified Network.HTTP.Types.Header as HTTP

36+import Servant.API

37+import Servant.Common.BaseUrl

38+import Servant.Common.Req

39+import Servant.API.ContentTypes

40+import Reflex

41+import Reflex.Dom

42+import Reflex.Dom.Xhr

9343

9444-- * Accessing APIs as a Client

9545

@@ -101,191 +51,116 @@ import Servant.Common.Req (ClientOptions(..),

10151-- > myApi :: Proxy MyApi

10252-- > myApi = Proxy

10353-- >

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

54+-- > getAllBooks :: Event t () -> m (Event t (Either XhrError ((),[Book])))

55+-- > postNewBook :: Behavior t (Maybe Book) -> Event t ()

56+-- -> m (Event t (Either XhrError (Book,Book)))

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

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

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

141−

59+client :: (HasClient t m layout, MonadWidget t m)

60+ => Proxy layout -> Proxy m -> Dynamic t BaseUrl -> Client t m layout

61+client p q baseurl = clientWithRoute p q defReq baseurl

14262

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

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

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

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

66+class HasClient t m layout where

67+ type Client t m layout :: *

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

17569

17670

71+instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where

72+ type Client t m (a :<|> b) = Client t m a :<|> Client t m b

73+ clientWithRoute Proxy q req baseurl =

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

75+ clientWithRoute (Proxy :: Proxy b) q req baseurl

76+

17777-- Capture. Example:

17878-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book

17979-- >

18080-- > myApi :: Proxy MyApi = Proxy

18181-- >

182−-- > getBook :: SupportsServantReflex t m

82+-- > getBook :: MonadWidget t m

18383-- => Dynamic t BaseUrl

184−-- -> Dynamic t (Maybe Text)

185−-- -> Event t l

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

84+-- -> Behavior t (Maybe Text)

85+-- -> Event t ()

86+-- -> m (Event t (Either XhrError (Text, Book)))

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

88+instance (MonadWidget t m, KnownSymbol capture, ToHttpApiData a, HasClient t m sublayout)

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

18890

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

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

191−

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

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

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

92+ Behavior t (Maybe a) -> Client t m sublayout

19493

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

196− clientWithRouteAndResultHandler

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

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

94+ clientWithRoute Proxy q req baseurl val =

95+ clientWithRoute (Proxy :: Proxy sublayout)

96+ q

97+ (prependToPathParts p req)

98+ baseurl

19999

100+ where p = (fmap . fmap) (unpack . toUrlPiece) val

200101

201102-- VERB (Returning content) --

202103instance {-# OVERLAPPABLE #-}

203104 -- Note [Non-Empty Content Types]

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

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

105+ (MimeUnrender ct a, FromHttpApiData a, ReflectMethod method, cts' ~ (ct ': cts), MonadWidget t m

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

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

108+ Event t () -> m (Event t (Maybe a, XhrResponse))

208109 -- TODO how to access input types here?

209110 -- ExceptT ServantError IO a

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

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

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

213− req' = req { reqMethod = method }

214−

111+ clientWithRoute Proxy q req baseurl =

112+ performRequestCT (Proxy :: Proxy ct) method req baseurl

113+ where method = BS.unpack $ reflectMethod (Proxy :: Proxy method)

215114

115+-- TODO Overlapping error??

216116-- -- VERB (No content) --

217−instance {-# OVERLAPPING #-}

218− (ReflectMethod method, SupportsServantReflex t m) =>

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

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

223− -- ExceptT ServantError IO NoContent

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

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

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

227−

228−

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

230−toHeaders r =

231− let hdrs = maybe []

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

233− (Map.toList $ _xhrResponse_headers xhr))

234− (response r)

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

236−

237−

238−class BuildHeaderKeysTo hs where

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

240−

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

242− where buildHeaderKeysTo _ = []

243−

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

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−

117+-- instance {-# OVERLAPPABLE #-}

118+-- (ReflectMethod method, MonadWidget t m) =>

119+-- HasClient t m (Verb method status cts NoContent) where

120+-- type Client t m (Verb method status cts NoContent) =

121+-- Event t () -> m (Event t XhrResponse)

122+-- -- TODO: how to access input types here?

123+-- -- ExceptT ServantError IO NoContent

124+-- clientWithRoute Proxy req baseurl =

125+-- performRequestNoBody method req baseurl

126+-- where method = reflectMethod (Proxy :: Proxy method)

251127

252128-- HEADERS Verb (Content) --

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

254130-- in order to deny instances for (Headers ls (Capture "id" Int)),

255131-- a combinator that wouldn't make sense

256132-- TODO Overlapping??

257−instance {-# OVERLAPPABLE #-}

258− -- Note [Non-Empty Content Types]

259− ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

260− ReflectMethod method, cts' ~ (ct ': cts),

261− SupportsServantReflex t m

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

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

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

268− wrap $ toHeaders <$> resp

269− where req' = req { respHeaders =

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

271− }

272−

273−

274−-- HEADERS Verb (No content) --

275−instance {-# OVERLAPPABLE #-}

276− ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,

277− SupportsServantReflex t m

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

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

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

284− wrap $ toHeaders <$> resp

285− where req' = req {respHeaders =

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

287− }

133+-- instance {-# OVERLAPPABLE #-}

134+-- -- Note [Non-Empty Content Types]

135+-- ( MimeUnrender ct a, BuildHeadersTo ls,

136+-- ReflectMethod method, cts' ~ (ct ': cts),

137+-- MonadWidget t m

138+-- ) => HasClient t m (Verb method status cts' (Headers ls a)) where

139+-- type Client t m (Verb method status cts' (Headers ls a))

140+-- = Event t () -> m (Event t (Maybe a, XhrResponse))

141+-- -- ExceptT ServantError IO (Headers ls a)

142+-- clientWithRoute Proxy req baseurl = do

143+-- let method = reflectMethod (Proxy :: Proxy method)

144+-- (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl

145+-- return $ Headers { getResponse = resp

146+-- , getHeadersHList = buildHeadersTo hdrs

147+-- }

288148

149+-- TODO Overlapping??

150+-- -- HEADERS Verb (No content) --

151+-- instance {-# OVERLAPPABLE #-}

152+-- ( BuildHeadersTo ls, ReflectMethod method,

153+-- MonadWidget t m

154+-- ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where

155+-- type Client t m (Verb method status cts (Headers ls NoContent))

156+-- = Event t () -> m (Event t XhrResponse)

157+-- -- ExceptT ServantError IO (Headers ls NoContent)

158+-- clientWithRoute Proxy req baseurl = do

159+-- let method = reflectMethod (Proxy :: Proxy method)

160+-- hdrs <- performRequestNoBody method req baseurl

161+-- return $ Headers { getResponse = NoContent

162+-- , getHeadersHList = buildHeadersTo hdrs

163+-- }

289164

290165

291166-- HEADER

@@ -302,46 +177,34 @@ instance {-# OVERLAPPABLE #-}

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

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

304179instance (KnownSymbol sym, ToHttpApiData a,

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

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

307−

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

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

310−

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

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

180+ HasClient t m sublayout, MonadWidget t m)

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

317182

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

184+ Behavior t (Maybe a) -> Client t m sublayout

318185

186+ clientWithRoute Proxy q req baseurl mval =

187+ clientWithRoute (Proxy :: Proxy sublayout)

188+ q

189+ req

190+ -- (maybe req -- TODO Need to pass the header in

191+ -- (\value -> Servant.Common.Req.addHeader hname value req)

192+ -- mval

193+ -- )

194+ baseurl

319195

196+ where hname = symbolVal (Proxy :: Proxy sym)

320197

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

322199-- functions.

323−instance HasClient t m sublayout tag

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

325−

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)

342−

200+instance HasClient t m sublayout

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

343202

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

204+ Client t m sublayout

344205

206+ clientWithRoute Proxy q =

207+ clientWithRoute (Proxy :: Proxy sublayout) q

345208

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

347210-- the corresponding querying function will automatically take

@@ -369,24 +232,24 @@ instance (HasClient t m sublayout tag, KnownSymbol sym)

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

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

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

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

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

235+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)

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

374237

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

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

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

239+ -- TODO (Maybe a), or (Maybe (Maybe a))? (should the user be able to send a Nothing)

240+ Behavior t (Maybe a) -> Client t m sublayout

377241

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

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

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

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

382−

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

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

385− --paramPair = (T.pack pname, p mparam)

386− p prm = QueryPartParam $ fmap qParamToQueryPart prm -- (fmap . fmap) (unpack . toQueryParam) prm

387− paramPair = (T.pack pname, p mparam)

388−

243+ clientWithRoute Proxy q req baseurl mparam =

244+ clientWithRoute (Proxy :: Proxy sublayout)

245+ q

246+ req -- TODO Must pass in the query param

247+ -- (req {qParams = (pname', map show mparam) : qParams req})

248+ baseurl

389249

250+ -- where pname = cs pname'

251+ -- pname' = symbolVal (Proxy :: Proxy sym)

252+ -- mparamText = fmap toQueryParam mparam

390253

391254-- | If you use a 'QueryParams' in one of your endpoints in your API,

392255-- the corresponding querying function will automatically take

@@ -416,21 +279,24 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex

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

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

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

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

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

282+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)

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

421284

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

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

424−

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

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

427−

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

429− pname = symbolVal (Proxy :: Proxy sym)

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

431− paramlist

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

286+ [a] -> Client t m sublayout

432287

288+ clientWithRoute Proxy _ req baseurl paramlist = undefined

289+ -- clientWithRoute (Proxy :: Proxy sublayout)

290+ -- (foldl' prependPathParts req paramlist')

291+ -- (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))

292+ -- req

293+ -- paramlist'

294+ -- )

295+ -- baseurl

433296

297+ -- where pname = cs pname'

298+ -- pname' = symbolVal (Proxy :: Proxy sym)

299+ -- paramlist' = map (Just . toQueryParam) paramlist

434300

435301-- | If you use a 'QueryFlag' in one of your endpoints in your API,

436302-- the corresponding querying function will automatically take

@@ -456,42 +322,35 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex

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

457323

458324-- TODO Bring back

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

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

461−

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

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

464−

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

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

325+-- instance (KnownSymbol sym, HasClient t m sublayout)

326+-- => HasClient t m (QueryFlag sym :> sublayout) where

467327

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

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

470− pName = symbolVal (Proxy :: Proxy sym)

328+-- type Client t m (QueryFlag sym :> sublayout) =

329+-- Bool -> Client t m sublayout

471330

331+-- clientWithRoute Proxy req baseurl flag =

332+-- clientWithRoute (Proxy :: Proxy sublayout)

333+-- (if flag

334+-- then appendToQueryString paramname Nothing req

335+-- else req

336+-- )

337+-- baseurl

472338

339+-- where paramname = cs $ symbolVal (Proxy :: Proxy sym)

473340

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

479341

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

481−

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

489−

490− resps <- performRequestsAsync okReq

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

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

493− ]

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

343+-- back the full `Response`.

344+-- TODO redo

345+instance (MonadWidget t m) => HasClient t m Raw where

346+ type Client t m Raw = Behavior t (Maybe XhrRequest)

347+ -> Event t ()

348+ -> m (Event t XhrResponse)

494349

350+ -- clientWithRoute :: Proxy Raw -> Proxy m -> Req -> BaseUrl -> Client t m Raw

351+ clientWithRoute p q req baseurl xhrs triggers = do

352+ let okReq = fmapMaybe id $ tag xhrs triggers

353+ performRequestAsync okReq

495354

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

497356-- the corresponding querying function will automatically take

@@ -509,76 +368,60 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where

509368-- > myApi = Proxy

510369-- >

511370-- > addBook :: Book -> ExceptT String IO Book

512−-- > addBook = client myApi host

371+-- > addBook = client myApi host

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

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

515374

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

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

518−

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

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

521−

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

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

524− where req' = req { reqBody = bodyBytesCT }

525− ctProxy = Proxy :: Proxy ct

526− ctString = T.pack $ show $ contentType ctProxy

527− bodyBytesCT = Just $ (fmap . fmap)

528− (\b -> (mimeRender ctProxy b, ctString))

529− body

375+-- TODO: Bring back

376+-- instance (MimeRender ct a, HasClient t m sublayout)

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

530378

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

380+-- a -> Client sublayout

531381

382+-- clientWithRoute Proxy req baseurl body =

383+-- clientWithRoute (Proxy :: Proxy sublayout)

384+-- (let ctProxy = Proxy :: Proxy ct

385+-- in setRQBody (mimeRender ctProxy body)

386+-- (contentType ctProxy)

387+-- req

388+-- )

389+-- baseurl

532390

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

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

392+instance (KnownSymbol path, HasClient t m sublayout, Reflex t) => HasClient t m (path :> sublayout) where

393+ type Client t m (path :> sublayout) = Client t m sublayout

536394

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

395+ clientWithRoute Proxy q req baseurl =

396+ clientWithRoute (Proxy :: Proxy sublayout) q

397+ (prependToPathParts (constant (Just p)) req)

398+ baseurl

540399

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

542401

402+instance HasClient t m api => HasClient t m (Vault :> api) where

403+ type Client t m (Vault :> api) = Client t m api

543404

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

546−

547− clientWithRouteAndResultHandler Proxy =

548− clientWithRouteAndResultHandler (Proxy :: Proxy api)

549−

550−

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

553−

554− clientWithRouteAndResultHandler Proxy =

555− clientWithRouteAndResultHandler (Proxy :: Proxy api)

556−

405+ clientWithRoute Proxy q req baseurl =

406+ clientWithRoute (Proxy :: Proxy api) q req baseurl

557407

408+instance HasClient t m api => HasClient t m (RemoteHost :> api) where

409+ type Client t m (RemoteHost :> api) = Client t m api

558410

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

411+ clientWithRoute Proxy q req baseurl =

412+ clientWithRoute (Proxy :: Proxy api) q req baseurl

561413

562− clientWithRouteAndResultHandler Proxy =

563− clientWithRouteAndResultHandler (Proxy :: Proxy api)

414+instance HasClient t m api => HasClient t m (IsSecure :> api) where

415+ type Client t m (IsSecure :> api) = Client t m api

564416

417+ clientWithRoute Proxy q req baseurl =

418+ clientWithRoute (Proxy :: Proxy api) q req baseurl

565419

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

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

420+instance HasClient t m subapi =>

421+ HasClient t m (WithNamedConfig name config subapi) where

568422

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

570− -> Client t m api tag

571−

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

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

574− where

575− req' = req { authData = Just authdata }

576−

577−-- instance HasClient t m subapi =>

578−-- HasClient t m (WithNamedConfig name config subapi) where

579−

580−-- type Client t m (WithNamedConfig name config subapi) = Client t m subapi

581−-- clientWithRoute Proxy q = clientWithRoute (Proxy :: Proxy subapi) q

423+ type Client t m (WithNamedConfig name config subapi) = Client t m subapi

424+ clientWithRoute Proxy q = clientWithRoute (Proxy :: Proxy subapi) q

582425

583426

584427{- Note [Non-Empty Content Types]

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

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

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

598441-}

599−

600−

601−-- SUPPORT FOR servant-auth --

602−

603−-- For JavaScript clients we should be sending/storing JSON web tokens in a

604−-- way that is inaccessible to JavaScript.

605−--

606−-- For @servant-auth@ this is done with HTTP-only cookies. In a Reflex-DOM

607−-- app this means the @servant-auth@ client should only verify that the API

608−-- supports Cookie-based authentication but do nothing with the token

609−-- directly.

610−

611−-- @HasCookieAuth auths@ is nominally a redundant constraint, but ensures

612−-- we're not trying to rely on cookies when the API does not use them.

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

614−

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

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

617−

618−

619−type family HasCookieAuth xs :: Constraint where

620− HasCookieAuth (Auth.Cookie ': xs) = ()

621− HasCookieAuth (x ': xs) = HasCookieAuth xs

622− HasCookieAuth '[] = CookieAuthNotEnabled

623−

624−class CookieAuthNotEnabled

625−

src/Servant/Reflex/Multi.hsdeleted−401

@@ -1,401 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE InstanceSigs #-}

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

35−

36− , HasClientMulti(..)

37− ) where

38−

39−------------------------------------------------------------------------------

40−import Control.Applicative (liftA2)

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

42−import Data.Proxy (Proxy (..))

43−import qualified Data.Set as Set

44−import Data.Text (Text)

45−import qualified Data.Text as T

46−import qualified Data.Text.Encoding as E

47−import GHC.TypeLits (KnownSymbol, symbolVal)

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

49− BasicAuthData, BuildHeadersTo (..),

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

51− HttpVersion, IsSecure,

52− MimeRender (..), MimeUnrender,

53− NoContent, QueryFlag, QueryParam,

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

55− RemoteHost, ReqBody,

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

57− contentType)

58−import Servant.API.Description (Summary)

59−

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

61− XhrRequest (..),

62− XhrResponseHeaders (..),

63− attachPromptlyDynWith, constDyn)

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−

118−------------------------------------------------------------------------------

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

130− where

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

132− ps = (fmap . fmap . fmap) toUrlPiece vals

133−

134−

135−------------------------------------------------------------------------------

136−-- VERB (Returning content) --

137−instance {-# OVERLAPPABLE #-}

138− -- Note [Non-Empty Content Types]

139− (MimeUnrender ct a,

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

141− SupportsServantReflex t m,

142− Applicative f,

143− Traversable f

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

145−

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

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

148−

149− clientWithRouteMulti _ _ _ _ reqs baseurl opts =

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

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

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

153−

154−

155−------------------------------------------------------------------------------

156−-- -- VERB (No content) --

157−instance {-# OVERLAPPING #-}

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

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

162− -- TODO: how to access input types here?

163− -- ExceptT ServantError IO NoContent

164− clientWithRouteMulti Proxy _ _ _ req baseurl opts =

165− performRequestsNoBody method req baseurl opts

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

167−

168−

169−------------------------------------------------------------------------------

170−instance {-# OVERLAPPABLE #-}

171− -- Note [Non-Empty Content Types]

172− ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

173− ReflectMethod method, cts' ~ (ct ': cts),

174− SupportsServantReflex t m,

175− Traversable f

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

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

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

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

189−

190−

191−------------------------------------------------------------------------------

192−instance {-# OVERLAPPABLE #-}

193− ( BuildHeadersTo ls,

194− BuildHeaderKeysTo ls,

195− ReflectMethod method,

196− SupportsServantReflex t m,

197− Traversable f

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

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

204− resp <- performRequestsNoBody method reqs' baseurl opts triggers

205− return $ fmap toHeaders <$> resp

206− where reqs' = fmap (\req ->

207− req {respHeaders = OnlyHeaders (Set.fromList

208− (buildHeaderKeysTo (Proxy :: Proxy ls)))

209− }) <$> reqs

210−

211−

212−------------------------------------------------------------------------------

213−instance (KnownSymbol sym,

214− ToHttpApiData a,

215− HasClientMulti t m sublayout f tag,

216− SupportsServantReflex t m,

217− Traversable f,

218− Applicative f)

219− => HasClientMulti t m (Header sym a :> sublayout) f tag where

220−

221− type ClientMulti t m (Header sym a :> sublayout) f tag =

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

223−

224− clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =

225− clientWithRouteMulti (Proxy :: Proxy sublayout) f

226− q tag

227− reqs'

228− baseurl opts

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

230− reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)

231− <$> eVals <*>) <$> reqs

232−

233−

234−------------------------------------------------------------------------------

235−instance HasClientMulti t m sublayout f tag

236− => HasClientMulti t m (HttpVersion :> sublayout) f tag where

237−

238− type ClientMulti t m (HttpVersion :> sublayout) f tag =

239− ClientMulti t m sublayout f tag

240−

241− clientWithRouteMulti Proxy q f tag =

242− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

243−

244−

245−------------------------------------------------------------------------------

246−instance (HasClientMulti t m sublayout f tag, KnownSymbol sym)

247− => HasClientMulti t m (Summary sym :> sublayout) f tag where

248−

249− type ClientMulti t m (Summary sym :> sublayout) f tag =

250− ClientMulti t m sublayout f tag

251−

252− clientWithRouteMulti Proxy q f tag =

253− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

254−

255−

256−------------------------------------------------------------------------------

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

266−

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

268− -- TODO: Check the above comment

269− clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =

270− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

271− reqs' baseurl opts

272−

273− where pname = symbolVal (Proxy :: Proxy sym)

274− p prm = QueryPartParam $ fmap qParamToQueryPart prm

275− paramPair mp = (T.pack pname, p mp)

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

279− <$> mparams <*> reqs

280−

281−

282−instance (KnownSymbol sym,

283− ToHttpApiData a,

284− HasClientMulti t m sublayout f tag,

285− Reflex t,

286− Applicative f)

287− => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where

288−

289− type ClientMulti t m (QueryParams sym a :> sublayout) f tag =

290− Dynamic t (f [a]) -> ClientMulti t m sublayout f tag

291−

292− clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =

293− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts

294−

295− where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }

296− pname = symbolVal (Proxy :: Proxy sym)

297− params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)

298− l

299− reqs' = liftA2 req' <$> paramlists <*> reqs

300−

301−

302−instance (KnownSymbol sym,

303− HasClientMulti t m sublayout f tag,

304− Reflex t,

305− Applicative f)

306− => HasClientMulti t m (QueryFlag sym :> sublayout) f tag where

307−

308− type ClientMulti t m (QueryFlag sym :> sublayout) f tag =

309− Dynamic t (f Bool) -> ClientMulti t m sublayout f tag

310−

311− clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =

312− clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts

313−

314− where req' f req = req { qParams = thisPair (constDyn f) : qParams req }

315− thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)

316− pName = symbolVal (Proxy :: Proxy sym)

317− reqs' = liftA2 req' <$> flags <*> reqs

318−

319−

320−instance (SupportsServantReflex t m,

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

331− where

332− aux (tag, Right r) = ResponseSuccess tag () r

333− aux (tag, Left e) = RequestFailure tag e

334−

335−

336−instance (MimeRender ct a,

337− HasClientMulti t m sublayout f tag,

338− Reflex t,

339− Applicative f)

340− => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where

341−

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

344−

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

348− ctProxy = Proxy :: Proxy ct

349− ctString = T.pack $ show $ contentType ctProxy

350− bodyBytesCT b = Just $ (fmap . fmap)

351− (\b' -> (mimeRender ctProxy b', ctString))

352− b

353− reqs' = liftA2 req' <$> bodies <*> reqs

354−

355−

356−instance (KnownSymbol path,

357− HasClientMulti t m sublayout f tag,

358− Reflex t,

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

361−

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)

365− baseurl

366−

367− where p = symbolVal (Proxy :: Proxy path)

368−

369−

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

372−

373− clientWithRouteMulti Proxy q f tag reqs baseurl =

374− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

375−

376−

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

379−

380− clientWithRouteMulti Proxy q f tag reqs baseurl =

381− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

382−

383−

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

386−

387− clientWithRouteMulti Proxy q f tag reqs baseurl =

388− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

389−

390−

391−instance (HasClientMulti t m api f tag, Reflex t, Applicative f)

392− => HasClientMulti t m (BasicAuth realm usr :> api) f tag where

393−

394− type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))

395− -> ClientMulti t m api f tag

396−

397− clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =

398− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts

399− where

400− req' a r = r { authData = Just (constDyn a) }

401− reqs' = liftA2 req' <$> authdatas <*> reqs

stack.yamldeleted−56

@@ -1,56 +0,0 @@

1−flags: {}

2−extra-package-dbs: []

3−packages:

4−- '.'

5−

6−- location:

7− git: https://github.com/reflex-frp/reflex

8− commit: d78ba4318c425ca9b942dc387d7c5c7ab2d2e095

9− extra-dep: true

10−

11−- location:

12− git: https://github.com/mokus0/dependent-sum.git

13− commit: bbc8ad3a81ea7f2b07ce7d036efd56f2e0f7c6ff

14− extra-dep: true

15−

16−- location:

17− git: https://github.com/gtk2hs/gtk2hs.git

18− commit: 21d3a12a82756d04066e5e4198b35097012ee65b

19− subdirs:

20− - cairo

21− - gio

22− - glib

23− - gtk

24− - pango

25− - tools

26− extra-dep: true

27−

28−- location:

29− git: https://github.com/byorgey/hashtables.git

30− commit: 47d9ed261a5aba66a13d3c4da0e391d338b57fc5

31− extra-dep: true

32−

33−- location:

34− git: https://github.com/afcady/reflex-dom.git

35− commit: 39b5ff23f3ae95d77c909ab3ed4bc4bd9e61f600

36− extra-dep: true

37−

38−- location:

39− git: https://github.com/afcady/dependent-sum-template.git

40− commit: 68fc1a90580ea8f20775491cf651eefea422212a

41− extra-dep: true

42−

43−extra-deps:

44−- cpphs-1.20.4

45−- directory-1.2.7.1

46−- ghcjs-dom-0.2.4.0

47−- haskell-src-exts-1.17.1

48−- haskell-src-meta-0.6.0.14

49−- hlint-1.9.35

50−- prim-uniq-0.1.0.1

51−- primitive-0.6.2.0

52−- ref-tf-0.4.0.1

53−- vector-0.12.0.0

54−- webkitgtk3-javascriptcore-0.13.2.0

55−- zenc-0.1.1

56−resolver: lts-8.3

testdriver/LICENSE.mddeleted−30