8244434 · servant-reflex

git.iko.soy/servant-reflex

on master help sign in

Merge branch 'master' of github.com:imalsogreg/servant-reflex

8244434Greg Hale10 years ago

.gitignore+1

compare with master

unifiedsplit

@@ -7,3 +7,4 @@ log

7*.stats

8out

9reflex-platform

10+/.stack-work/

.travis.yml+2−2

@@ -37,8 +37,8 @@ install:

37 - travis_retry cabal update -v

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

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

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

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

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

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

42 - cd testserver && dist/build/back/back -p 8000 &

43 - sleep 3

44 - phantomjs --webdriver=127.0.0.1:4444 &

@@ -48,7 +48,7 @@ script:

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

49 - git config --global user.name "Travis-CI"

50 - ./build.sh

51− - testdriver/dist/build/spec/spec

51+ # - testdriver/dist/build/spec/spec

53cache:

54 directories:

changelog.mdnew file+32

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

1+0.3

2+---

4+- **Addition of the 'Servant.Reflex.Multi' module** which allows the user

5+to choose some '(Applicative f, Traversable f) => f' for collecting

6+endpoint parameters. The traversable instance is used for passing

7+multiple 'XhrRequest's in response to a single event trigger. The

8+Applicative instance is used to combine parameters. For example,

9+'Capture "id" Name :> QueryParam "greeting" Text :> Get '[JSON] Text'

10+will generate a client function:

11+`Dynamic t (f Name) -> Dynamic t (f greeting) -> Event t tag ->

12+ m (Event t (f (ReqResult tag Text)))`

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

14+`clientFun

15+(constDyn ["Greg", "Bernie"])

16+(constDyn ["Greetings", "Hey"])

17+trigger`

18+would produce four XhrRequests per 'trigger' event, one for each

19+combination of possible parameters, and one response event

20+would carry a list of the four responses.

21+A 'zip-wise' combination of the parameters can be chosen with

22+a different applicative wrapper: 'ZipList'

23+

24+- **Event tags**. A new type parameter lets users choose a payload

25+value to attach to outgoing requests at the point of triggering,

26+and which is embedded in the response, allowing individual

27+request-response pairs to be followed. The response's tag has been

28+added to each constructor `ReqResult tag a` type.

29+

30+- **Improved Unicode support** Thanks to Schell Scivally

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

32+encoding bug!

exec/Example.hs+83−29

@@ -2,30 +2,75 @@

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE RecursiveDo #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7module Main where

8module Main where

10+------------------------------------------------------------------------------

9import Data.Bool

11import Data.Bool

10import Data.Maybe

12import Data.Maybe

11import Control.Monad.Fix (MonadFix)

13import Control.Monad.Fix (MonadFix)

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

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

13import Data.Text (Text)

15import Data.Text (Text)

14import qualified Data.Text as T

16import qualified Data.Text as T

15import GHC.TypeLits

17import GHC.TypeLits

16import Servant.API

18import Servant.API

17−import Servant.Reflex

18import API

19import API

19import Data.Proxy

20import Data.Proxy

20import Text.Read (readMaybe)

21import Text.Read (readMaybe)

21import Reflex.Dom

22import Reflex.Dom

23+------------------------------------------------------------------------------

24+import Servant.Reflex

25+import Servant.Reflex.Multi

26+

23api :: Proxy API

28api :: Proxy API

24api = Proxy

29api = Proxy

26main :: IO ()

31main :: IO ()

27−main = mainWidget run

32+main = mainWidget $ do

28−

33+ divClass "example-base" run

34+ divClass "example-multi" runMulti

35+

36+

37+runMulti :: forall t m. (SupportsServantReflex t m,

38+ DomBuilder t m,

39+ DomBuilderSpace m ~ GhcjsDomSpace,

40+ MonadFix m,

41+ PostBuild t m,

42+ MonadHold t m) => m ()

43+runMulti = do

44+ url <- baseUrlWidget

45+ el "br" blank

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

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

48+

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

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

51+

52+ b <- button "Run dbl multi"

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

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

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

56+

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

58+ display lastInd

59+

60+ divClass "demo-group" $ do

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

62+ text "Names"

63+ textInput def

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

65+ text "Greetings"

66+ textInput def

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

68+ b <- button "Go"

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

70+

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

72+

73+ return ()

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

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

31 DomBuilder t m,

76 DomBuilder t m,

@@ -33,37 +78,41 @@ run :: forall t m. (SupportsServantReflex t m,

33 MonadFix m,

78 MonadFix m,

34 PostBuild t m,

79 PostBuild t m,

35 MonadHold t m) => m ()

80 MonadHold t m) => m ()

36−run = do

81+run = mdo

83+ reqCount <- count $ leftmost

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

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

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

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

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

40 url <- baseUrlWidget

87 url <- baseUrlWidget

41 el "br" (return ())

88 el "br" (return ())

42 dynText $ showBaseUrl <$> url

89 dynText $ showBaseUrl <$> url

90+

43 el "br" (return ())

91 el "br" (return ())

45 -- Name the computed API client functions

93 -- Name the computed API client functions

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

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

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

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

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

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

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

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

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

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

102

55− unitResponse <- getUnit unitBtn

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

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

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

105

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

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

107

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

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

61− leftmost [fmapMaybe response unitResponse

109+ leftmost [fmapMaybe response (unitResponse)

62− ,fmapMaybe response intResponse

110+ ,fmapMaybe response (intResponse)

63 ]

111 ]

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

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

113+ return (unitBtn, intBtn)

114

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

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

116

68 text "Name"

117 text "Name"

69 el "br" $ return ()

118 el "br" $ return ()

@@ -81,43 +130,48 @@ run = do

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

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

131

83 el "br" $ return ()

132 el "br" $ return ()

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

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

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

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

135

87− resp <- sayhi checkedName greetings gusto triggers

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

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

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

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

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

90− , fmapMaybe reqFailure resp])

139+ , fmapMaybe reqFailure (resp)])

140+ return sayHiClicks

141

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

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

93 text "A Double to double"

143 text "A Double to double"

94 el "br" $ return ()

144 el "br" $ return ()

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

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

96− dblBtn <- divClass "double-button" $ button "Double it"

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

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

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

98− dblinp) dblBtn

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

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

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

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

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

101 el "br" (return ())

151 el "br" (return ())

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

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

103 holdDyn "No number yet" (fmap tShow $

153 holdDyn "No number yet" (fmap tShow $

104− fmapMaybe reqSuccess dblResp)

154+ fmapMaybe reqSuccess (dblResp))

155+ return dblBtn

105

156

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

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

107 text "Multi-part path"

158 text "Multi-part path"

108 b <- value <$> checkbox False def

159 b <- value <$> checkbox False def

109 mpGo <- button "Test"

160 mpGo <- button "Test"

110− multiResp <- multi b mpGo

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

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

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

112 fmapMaybe reqSuccess $

163 fmapMaybe reqSuccess $

113− multiResp)

164+ (multiResp))

165+ return mpGo

166+

167+ return ()

114

168

115 el "br" $ return ()

169 el "br" $ return ()

116

170

117 elClass "div" "demo-group" $ do

171 elClass "div" "demo-group" $ do

118 text "JSON Unicode encoding test"

172 text "JSON Unicode encoding test"

119 txt <- value <$> textInput def

173 txt <- value <$> textInput def

120− ev <- button "Question"

174+ ev <- fmap (1 <$) $ button "Question"

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

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

122 rr <- qna dQ ev

176 rr <- qna dQ ev

123 el "p" $

177 el "p" $

overrides-ghc.nix−21

@@ -14,27 +14,6 @@ in reflex-platform.ghc.override {

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

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

16 Glob = pkgs.haskell.lib.dontCheck super.Glob;

17− natural-transformation = self.callPackage (

18− { mkDerivation, base, containers, fetchgit, quickcheck-instances

19− , stdenv, tasty, tasty-quickcheck

20− }:

21− mkDerivation {

22− pname = "natural-transformation";

23− version = "0.4";

24− src = fetchgit {

25− url = "https://github.com/ku-fpg/natural-transformation";

26− sha256 = "0xbnnxbf5ydszbhf7h5ra3mrqy4mcyqc3zb2k8bwm1zyqrz6v0fs";

27− rev = "b1200c09dcafd034e32846413913b74735c8ba56";

28− };

29− libraryHaskellDepends = [ base ];

30− testHaskellDepends = [

31− base containers quickcheck-instances tasty tasty-quickcheck

32− ];

33− homepage = "https://github.com/ku-fpg/natural-transformation";

34− description = "A natural transformation package";

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

36− }

37− ) {};

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

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

39 };

18 };

40}

19}

servant-reflex.cabal+2−1

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

1Name: servant-reflex

2−Version: 0.2.1

2+Version: 0.3

3Synopsis: Servant reflex API generator

4Description: Servant reflex API generator

5License: AllRightsReserved

@@ -14,6 +14,7 @@ Cabal-version: >=1.10

14library

15 exposed-modules:

16 Servant.Reflex

17+ Servant.Reflex.Multi

18 other-modules:

19 other-modules:

19 Servant.Common.BaseUrl

20 Servant.Common.BaseUrl

src/Servant/Common/Req.hs+224−69

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

1−{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE CPP #-}

1{-# LANGUAGE CPP #-}

3{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

@@ -6,50 +5,89 @@

6{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TupleSections #-}

7{-# LANGUAGE TupleSections #-}

9module Servant.Common.Req where

11-------------------------------------------------------------------------------

12+import Control.Concurrent

12import Control.Applicative (liftA2, liftA3)

13import Control.Applicative (liftA2, liftA3)

14+import Control.Monad (join)

15+import Control.Monad.IO.Class (MonadIO, liftIO)

13import Data.Bifunctor (first)

16import Data.Bifunctor (first)

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

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

15import qualified Data.Map as Map

18import qualified Data.Map as Map

16import Data.Maybe (catMaybes, fromMaybe)

19import Data.Maybe (catMaybes, fromMaybe)

20+import Data.Functor.Compose

17import Data.Monoid ((<>))

21import Data.Monoid ((<>))

18import Data.Proxy (Proxy(..))

22import Data.Proxy (Proxy(..))

19import Data.Text (Text)

23import Data.Text (Text)

20import qualified Data.Text as T

24import qualified Data.Text as T

21import qualified Data.Text.Encoding as TE

25import qualified Data.Text.Encoding as TE

26+import Data.Traversable (forM)

22−import Reflex.Dom

27+import Reflex.Dom hiding (tag)

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

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

29+ SupportsServantReflex)

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

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

25import Web.HttpApiData (ToHttpApiData(..))

31import Web.HttpApiData (ToHttpApiData(..))

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

32-------------------------------------------------------------------------------

27import Servant.API.BasicAuth

33import Servant.API.BasicAuth

36+------------------------------------------------------------------------------

37+-- | The result of a request event

38+data ReqResult tag a

39+ = ResponseSuccess tag a XhrResponse

40+ -- ^ The succesfully decoded response from a request tagged with 'tag'

41+ | ResponseFailure tag Text XhrResponse

42+ -- ^ The failure response, which may have failed decoding or had

43+ -- a non-successful response code

44+ | RequestFailure tag Text

45+ -- ^ A failure to construct the request tagged with 'tag' at trigger time

46+

47+

48+------------------------------------------------------------------------------

49+-- | Simple filter/accessor for successful responses, when you want to

50+-- ignore the error case. For example:

51+-- >> goodResponses <- fmapMaybe reqSuccess <$> clientFun triggers

52+reqSuccess :: ReqResult tag a -> Maybe a

53+reqSuccess (ResponseSuccess _ x _) = Just x

54+reqSuccess _ = Nothing

55+

56+

57+------------------------------------------------------------------------------

58+-- | Simple filter/accessor like 'reqSuccess', but keeping the request tag

59+reqSuccess' :: ReqResult tag a -> Maybe (tag,a)

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

61+reqSuccess' _ = Nothing

31−data ReqResult a = ResponseSuccess a XhrResponse

32− | ResponseFailure Text XhrResponse

33− | RequestFailure Text

35−instance Functor ReqResult where

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

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

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

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

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

38− fmap _ (RequestFailure r) = RequestFailure r

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

68+reqFailure (RequestFailure _ s) = Just s

69+reqFailure _ = Nothing

40−reqSuccess :: ReqResult a -> Maybe a

41−reqSuccess (ResponseSuccess x _) = Just x

42−reqSuccess _ = Nothing

72+------------------------------------------------------------------------------

73+-- | Simple filter/accessor for the raw XHR response

44−reqFailure :: ReqResult a -> Maybe Text

74+response :: ReqResult tag a -> Maybe XhrResponse

75+response (ResponseSuccess _ _ x) = Just x

45−reqFailure (ResponseFailure s _) = Just s

76+response (ResponseFailure _ _ x) = Just x

46−reqFailure (RequestFailure s) = Just s

47−reqFailure _ = Nothing

77+response _ = Nothing

49−response :: ReqResult a -> Maybe XhrResponse

79+------------------------------------------------------------------------------

80+-- | Retrieve response tag

81+reqTag :: ReqResult tag a -> tag

50−response (ResponseSuccess _ x) = Just x

82+reqTag (ResponseSuccess tag _ _) = tag

51−response (ResponseFailure _ x) = Just x

83+reqTag (ResponseFailure tag _ _) = tag

52−response _ = Nothing

84+reqTag (RequestFailure tag _ ) = tag

85+

86+------------------------------------------------------------------------------

87+instance Functor (ReqResult tag) where

88+ fmap f (ResponseSuccess tag a xhr) = ResponseSuccess tag (f a) xhr

89+ fmap _ (ResponseFailure tag r x) = ResponseFailure tag r x

90+ fmap _ (RequestFailure tag r) = RequestFailure tag r

55-------------------------------------------------------------------------------

93-------------------------------------------------------------------------------

@@ -63,11 +101,13 @@ data QParam a = QParamSome a

63 | QParamInvalid Text

101 | QParamInvalid Text

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

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

103

104+

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

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

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

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

68qParamToQueryPart QNone = Right Nothing

107qParamToQueryPart QNone = Right Nothing

69qParamToQueryPart (QParamInvalid e) = Left e

108qParamToQueryPart (QParamInvalid e) = Left e

109

110+

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

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

72 | QueryPartParams (Dynamic t [Text])

112 | QueryPartParams (Dynamic t [Text])

73 | QueryPartFlag (Dynamic t Bool)

113 | QueryPartFlag (Dynamic t Bool)

@@ -97,20 +137,13 @@ addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) ->

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

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

138

139

100−-- * performing requests

140+reqToReflexRequest

101−

141+ :: forall t. Reflex t

102−displayHttpRequest :: Text -> Text

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

104−

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

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

107− => Text

142+ => Text

108− -> Req t

109− -> Dynamic t BaseUrl

143+ -> Dynamic t BaseUrl

110− -> Event t ()

144+ -> Req t

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

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

112−performRequest reqMeth req reqHost trigger = do

146+reqToReflexRequest reqMeth reqHost req =

113−

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

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

115 t = sequence $ reverse $ reqPathParts req

148 t = sequence $ reverse $ reqPathParts req

116

149

@@ -143,8 +176,8 @@ performRequest reqMeth req reqHost trigger = do

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

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

144 queryString :: Dynamic t (Either Text Text) =

177 queryString :: Dynamic t (Either Text Text) =

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

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

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

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

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

180+ baseUrl urlPath queryString

148 where

181 where

149 (</>) :: Text -> Text -> Text

182 (</>) :: Text -> Text -> Text

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

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

@@ -203,64 +236,186 @@ performRequest reqMeth req reqHost trigger = do

203

236

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

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

205

238

206− let reqs = tagPromptlyDyn xhrReq trigger

239+ in xhrReq

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

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

209

240

210− resps <- performRequestAsync okReqs

241+-- * performing requests

242+

243+displayHttpRequest :: Text -> Text

244+displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

245+

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

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

248+ => Text

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

250+ -> Dynamic t BaseUrl

251+ -> Event t tag

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

253+performRequests reqMeth rs reqHost trigger = do

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

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

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

257+ resps <- performSomeRequestsAsync reqs

258+ return $ getCompose <$> resps

259+

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

261+performSomeRequestsAsync

262+ :: (MonadIO (Performable m),

263+ HasWebView (Performable m),

264+ PerformEvent t m,

265+ TriggerEvent t m,

266+ Traversable f,

267+ IsXhrPayload a)

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

269+ -> m (Event t (f (Either Text XhrResponse)))

270+performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return

271+

272+

273+------------------------------------------------------------------------------

274+-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync

275+-- that accepts 'f (Either e (XhrRequestb))' events

276+performSomeRequestsAsync'

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

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

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

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

281+ rs <- hrs

282+ resps <- forM rs $ \r -> case r of

283+ Left e -> do

284+ resp <- liftIO $ newMVar (Left e)

285+ return resp

286+ Right r' -> do

287+ resp <- liftIO newEmptyMVar

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

289+ return resp

290+ _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar

291+ return ()

292+

293+

294+

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

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

297+ => Text

298+ -> (Req t)

299+ -> Dynamic t BaseUrl

300+ -> Event t tag

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

302+performRequest reqMeth req reqHost trigger = do

303+

304+ let xhrReq = reqToReflexRequest reqMeth reqHost req

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

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

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

308+

309+ resps <- performRequestsAsync okReqs

211

310

212 return (resps, badReqs)

311 return (resps, badReqs)

213

312

313+

214type XhrPayload = T.Text

314type XhrPayload = T.Text

215bytesToPayload :: BL.ByteString -> XhrPayload

315bytesToPayload :: BL.ByteString -> XhrPayload

216bytesToPayload = TE.decodeUtf8 . BL.toStrict

316bytesToPayload = TE.decodeUtf8 . BL.toStrict

217

317

218

318

219−------------------------------------------------------------------------------

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

319+-- performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)

221− => Text

320+-- => Text

222− -> Req t

321+-- -> Req t

223− -> Dynamic t BaseUrl

322+-- -> Dynamic t BaseUrl

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

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

225−performRequestNoBody reqMeth req reqHost trigger = do

324+-- performRequestNoBody reqMeth req reqHost trigger = do

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

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

227− let decodeResp = const $ Right NoContent

326+-- let decodeResp = const $ Right NoContent

228− return $ leftmost [ fmap (evalRequest decodeResp) resp,

327+-- return $ leftmost [ fmap (evalResponse decodeResp) resp

229− fmap RequestFailure badReq]

328+-- , fmap (uncurry RequestFailure) badReq

230−

329+-- ]

231−

330+

232−------------------------------------------------------------------------------

331+

332+-- performRequestCT

233−performRequestCT :: (SupportsServantReflex t m,

333+-- :: (SupportsServantReflex t m,

234− MimeUnrender ct a)

334+-- MimeUnrender ct a)

335+-- => Proxy ct

336+-- -> Text

337+-- -> Req t

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

338+-- -> Dynamic t BaseUrl

339+-- -> Event t tag

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

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

237−performRequestCT ct reqMeth req reqHost trigger = do

341+-- performRequestCT ct reqMeth req reqHost trigger = do

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

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

343+-- let decodeResp x = first T.pack .

344+-- mimeUnrender ct .

345+-- BL.fromStrict .

346+-- TE.encodeUtf8 =<< note "No body text"

347+-- (_xhrResponse_responseText x)

348+

349+-- return $ leftmost [fmap (evalResponse decodeResp) resp

350+-- , fmap (uncurry RequestFailure) badReq

351+-- ]

352+

353+

354+performRequestsCT

355+ :: (SupportsServantReflex t m,

356+ MimeUnrender ct a, Traversable f)

357+ => Proxy ct

358+ -> Text

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

360+ -> Dynamic t BaseUrl

361+ -> Event t tag

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

363+performRequestsCT ct reqMeth reqs reqHost trigger = do

364+ resps <- performRequests reqMeth reqs reqHost trigger

239 let decodeResp x = first T.pack .

365 let decodeResp x = first T.pack .

240 mimeUnrender ct .

366 mimeUnrender ct .

241 BL.fromStrict .

367 BL.fromStrict .

242 TE.encodeUtf8 =<< note "No body text"

368 TE.encodeUtf8 =<< note "No body text"

243 (_xhrResponse_responseText x)

369 (_xhrResponse_responseText x)

244−

370+ return $ fmap

245− return $ leftmost [fmap (evalRequest decodeResp) resp,

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

372+ Left e -> RequestFailure t e

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

374+ )

375+ resps

376+

377+

378+performRequestsNoBody

379+ :: (SupportsServantReflex t m,

380+ Traversable f)

381+ => Text

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

383+ -> Dynamic t BaseUrl

384+ -> Event t tag

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

386+performRequestsNoBody reqMeth reqs reqHost trigger = do

387+ resps <- performRequests reqMeth reqs reqHost trigger

388+ let decodeResp = const $ Right NoContent

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

246− fmap RequestFailure badReq]

390+ Left e -> RequestFailure tag e

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

247

392

248

393

249------------------------------------------------------------------------------

394------------------------------------------------------------------------------

395+evalResponse

250−evalRequest :: (XhrResponse -> Either Text a) -> XhrResponse -> ReqResult a

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

397+ -> (tag, XhrResponse)

398+ -> ReqResult tag a

251−evalRequest decode xhr =

399+evalResponse decode (tag, xhr) =

252 let okStatus = _xhrResponse_status xhr < 400

400 let okStatus = _xhrResponse_status xhr < 400

253 errMsg = fromMaybe

401 errMsg = fromMaybe

254 ("Empty response with error code " <>

402 ("Empty response with error code " <>

255 T.pack (show $ _xhrResponse_status xhr))

403 T.pack (show $ _xhrResponse_status xhr))

256 (_xhrResponse_responseText xhr)

404 (_xhrResponse_responseText xhr)

257 respPayld = if okStatus

405 respPayld = if okStatus

406+ then either

258− then either (flip ResponseFailure xhr)

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

259− (flip ResponseSuccess xhr) (decode xhr)

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

409+ (decode xhr)

260− else ResponseFailure errMsg xhr

410+ else ResponseFailure tag errMsg xhr

261 in respPayld

411 in respPayld

262

412

263

413

264

414

415+

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

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

266note e = maybe (Left e) Right

417note e = maybe (Left e) Right

418+

419+fmapL :: (e -> e') -> Either e a -> Either e' a

420+fmapL _ (Right a) = Right a

421+fmapL f (Left e) = Left (f e)

src/Servant/Reflex.hs+204−165

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

1+{-# LANGUAGE AllowAmbiguousTypes #-}

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE InstanceSigs #-}

6{-# LANGUAGE InstanceSigs #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TupleSections #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE UndecidableInstances #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

14{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE OverloadedStrings #-}

15{-# LANGUAGE OverloadedStrings #-}

8{-# LANGUAGE PolyKinds #-}

16{-# LANGUAGE PolyKinds #-}

@@ -18,47 +26,59 @@

18-- API.

26-- API.

19module Servant.Reflex

27module Servant.Reflex

20 ( client

28 ( client

29+ , BuildHeaderKeysTo(..)

30+ , toHeaders

21 , HasClient(..)

31 , HasClient(..)

22 , module Servant.Common.Req

32 , module Servant.Common.Req

23 , module Servant.Common.BaseUrl

33 , module Servant.Common.BaseUrl

24 ) where

34 ) where

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

36+------------------------------------------------------------------------------

27import Control.Applicative

37import Control.Applicative

28−import Data.CaseInsensitive (mk)

38+import Data.Monoid ((<>))

29−import qualified Data.Map as Map

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

31−import Data.Proxy (Proxy (..))

32−import qualified Data.Set as Set

39+import qualified Data.Set as Set

33−import Data.Text (Text)

34−import qualified Data.Text as T

35−import qualified Data.Text.Encoding as E

40+import qualified Data.Text.Encoding as E

41+import Data.CaseInsensitive (mk)

42+import Data.Functor.Identity

43+import Data.Proxy (Proxy (..))

44+import qualified Data.Map as Map

45+import Data.Text (Text)

46+import qualified Data.Text as T

36−import GHC.TypeLits (KnownSymbol, symbolVal)

47+import GHC.TypeLits (KnownSymbol, symbolVal)

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

38− XhrRequest (..), XhrResponse (..),

39− XhrResponseHeaders (..), ffor,

40− fmapMaybe, leftmost,

41− performRequestAsync, tagPromptlyDyn)

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

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

43− BasicAuthData, BuildHeadersTo (..),

49+ BasicAuthData, BuildHeadersTo(..),

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

50+ Capture, contentType, Header,

45− HttpVersion, IsSecure, MimeRender (..),

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

52+ MimeRender(..), MimeUnrender,

46− MimeUnrender, NoContent, QueryFlag,

53+ NoContent, QueryFlag, QueryParam,

47− QueryParam, QueryParams, Raw,

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

48− ReflectMethod (..), RemoteHost,

55+ RemoteHost, ReqBody,

49− ReqBody, ToHttpApiData (..), Vault,

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

50− Verb, contentType)

57+

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

59+ XhrRequest(..),

60+ XhrResponseHeaders(..),

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

62+ leftmost, performRequestsAsync,

63+ )

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

51−import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),

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

52− SupportsServantReflex, baseUrlWidget,

53− showBaseUrl)

66+ showBaseUrl,

67+ SupportsServantReflex)

54−import Servant.Common.Req (QParam (..), QueryPart (..), Req,

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

55− ReqResult (..), addHeader, authData,

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

70+ defReq, evalResponse, prependToPathParts,

56− defReq, performRequestCT,

71+ -- performRequestCT,

72+ performRequestsCT,

57− performRequestNoBody,

73+ -- performRequestNoBody,

74+ performRequestsNoBody,

75+ performSomeRequestsAsync,

58− prependToPathParts, qParamToQueryPart,

76+ qParamToQueryPart, reqBody,

59− qParams, reqBody, reqFailure,

77+ reqSuccess, reqFailure,

60− reqMethod, reqSuccess, respHeaders,

78+ reqMethod, respHeaders, response,

61− response)

79+ reqTag,

80+ qParams)

81+

63-- * Accessing APIs as a Client

83-- * Accessing APIs as a Client

@@ -70,28 +90,31 @@ import Servant.Common.Req (QParam (..), QueryPart (..), Req,

70-- > myApi :: Proxy MyApi

90-- > myApi :: Proxy MyApi

71-- > myApi = Proxy

91-- > myApi = Proxy

72-- >

92-- >

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

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

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

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

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

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

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

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

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

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

78−client :: (HasClient t m layout)

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

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

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

80−client p q = clientWithRoute p q defReq

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

101+

102

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

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

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

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

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

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

85−class HasClient t m layout where

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

86− type Client t m layout :: *

107+ type Client t m layout tag :: *

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

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

109

110

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

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

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

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

113+

92− clientWithRoute Proxy q req baseurl =

114+ clientWithRoute Proxy q pTag req baseurl =

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

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

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

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

117+

118

96-- Capture. Example:

119-- Capture. Example:

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

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

@@ -101,50 +124,54 @@ instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where

101-- > getBook :: SupportsServantReflex t m

124-- > getBook :: SupportsServantReflex t m

102-- => Dynamic t BaseUrl

125-- => Dynamic t BaseUrl

103-- -> Dynamic t (Maybe Text)

126-- -> Dynamic t (Maybe Text)

104−-- -> Event t ()

127+-- -> Event t l

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

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

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

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

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

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

109

130

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

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

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

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

112

133

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

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

136+

113− clientWithRoute Proxy q req baseurl val =

137+ clientWithRoute Proxy q t req baseurl val =

114 clientWithRoute (Proxy :: Proxy sublayout)

138 clientWithRoute (Proxy :: Proxy sublayout)

115− q

139+ q t

116 (prependToPathParts p req)

140 (prependToPathParts p req)

117 baseurl

141 baseurl

142+ where p = (fmap . fmap) (toUrlPiece) val

118

143

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

120

144

121-- VERB (Returning content) --

145-- VERB (Returning content) --

122instance {-# OVERLAPPABLE #-}

146instance {-# OVERLAPPABLE #-}

123 -- Note [Non-Empty Content Types]

147 -- Note [Non-Empty Content Types]

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

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

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

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

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

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

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

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

128 -- TODO how to access input types here?

152 -- TODO how to access input types here?

129 -- ExceptT ServantError IO a

153 -- ExceptT ServantError IO a

130− clientWithRoute Proxy _ req =

154+ clientWithRoute Proxy _ _ req baseurl trigs =

131− performRequestCT (Proxy :: Proxy ct) method req'

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

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

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

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

133 req' = req { reqMethod = method }

158 req' = req { reqMethod = method }

134

159

160+

135-- -- VERB (No content) --

161-- -- VERB (No content) --

136instance {-# OVERLAPPING #-}

162instance {-# OVERLAPPING #-}

137 (ReflectMethod method, SupportsServantReflex t m) =>

163 (ReflectMethod method, SupportsServantReflex t m) =>

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

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

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

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

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

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

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

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

142 -- ExceptT ServantError IO NoContent

168 -- ExceptT ServantError IO NoContent

143− clientWithRoute Proxy _ =

169+ clientWithRoute Proxy _ _ req baseurl =

144− performRequestNoBody method

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

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

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

146

172

173+

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

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

148toHeaders r =

175toHeaders r =

149 let toBS = E.encodeUtf8

176 let toBS = E.encodeUtf8

150 hdrs = maybe []

177 hdrs = maybe []

@@ -173,33 +200,35 @@ instance {-# OVERLAPPABLE #-}

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

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

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

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

175 SupportsServantReflex t m

202 SupportsServantReflex t m

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

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

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

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

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

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

179− clientWithRoute Proxy _ req baseurl = do

206+ clientWithRoute Proxy _ _ req baseurl trigs = do

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

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

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

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

182− return $ (fmap . fmap) toHeaders resp

209+ return $ toHeaders <$> resp

183 where req' = req { respHeaders =

210 where req' = req { respHeaders =

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

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

185 }

212 }

186

213

214+

187-- HEADERS Verb (No content) --

215-- HEADERS Verb (No content) --

188instance {-# OVERLAPPABLE #-}

216instance {-# OVERLAPPABLE #-}

189 ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,

217 ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,

190 SupportsServantReflex t m

218 SupportsServantReflex t m

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

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

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

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

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

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

194− clientWithRoute Proxy _ req baseurl = do

222+ clientWithRoute Proxy _ _ req baseurl trigs = do

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

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

196− resp <- performRequestNoBody method req' baseurl

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

197− return $ (fmap . fmap) toHeaders resp

225+ return $ toHeaders <$> resp

198 where req' = req {respHeaders =

226 where req' = req {respHeaders =

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

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

200 }

228 }

201

229

202

230

231+

203-- HEADER

232-- HEADER

204-- > newtype Referer = Referer { referrer :: Text }

233-- > newtype Referer = Referer { referrer :: Text }

205-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)

234-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)

@@ -214,28 +243,32 @@ instance {-# OVERLAPPABLE #-}

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

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

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

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

216instance (KnownSymbol sym, ToHttpApiData a,

245instance (KnownSymbol sym, ToHttpApiData a,

217− HasClient t m sublayout, SupportsServantReflex t m)

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

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

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

219

248

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

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

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

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

222

251

223− clientWithRoute Proxy q req baseurl eVal =

252+ clientWithRoute Proxy q t req baseurl eVal =

224 clientWithRoute (Proxy :: Proxy sublayout)

253 clientWithRoute (Proxy :: Proxy sublayout)

225− q

254+ q t

226 (Servant.Common.Req.addHeader hname eVal req)

255 (Servant.Common.Req.addHeader hname eVal req)

227 baseurl

256 baseurl

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

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

229

258

259+

260+

261+

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

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

231-- functions.

263-- functions.

232−instance HasClient t m sublayout

264+instance HasClient t m sublayout tag

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

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

234

266

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

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

236− Client t m sublayout

268+ Client t m sublayout tag

237

269

270+ clientWithRoute Proxy q t =

238− clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy sublayout)

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

239

272

240

273

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

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

@@ -264,15 +297,15 @@ instance HasClient t m sublayout

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

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

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

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

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

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

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

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

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

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

269

302

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

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

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

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

272

305

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

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

274− clientWithRoute Proxy q req baseurl mparam =

307+ clientWithRoute Proxy q t req baseurl mparam =

275− clientWithRoute (Proxy :: Proxy sublayout) q

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

276 (req {qParams = paramPair : qParams req}) baseurl

309 (req {qParams = paramPair : qParams req}) baseurl

277

310

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

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

@@ -281,6 +314,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

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

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

282 paramPair = (T.pack pname, p mparam)

315 paramPair = (T.pack pname, p mparam)

283

316

317+

318+

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

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

285-- the corresponding querying function will automatically take

320-- the corresponding querying function will automatically take

286-- an additional argument, a list of values of the type specified

321-- an additional argument, a list of values of the type specified

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

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

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

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

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

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

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

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

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

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

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

314

349

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

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

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

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

317

352

318− clientWithRoute Proxy q req baseurl paramlist =

353+ clientWithRoute Proxy q t req baseurl paramlist =

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

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

320

355

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

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

322 pname = symbolVal (Proxy :: Proxy sym)

357 pname = symbolVal (Proxy :: Proxy sym)

@@ -324,6 +359,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

324 paramlist

359 paramlist

325

360

326

361

362+

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

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

328-- the corresponding querying function will automatically take

364-- the corresponding querying function will automatically take

329-- an additional 'Bool' argument.

365-- an additional 'Bool' argument.

@@ -348,49 +384,42 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

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

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

349

385

350-- TODO Bring back

386-- TODO Bring back

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

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

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

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

353

389

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

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

355− Dynamic t Bool -> Client t m sublayout

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

356

392

357− clientWithRoute Proxy q req baseurl flag =

393+ clientWithRoute Proxy q t req baseurl flag =

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

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

359

395

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

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

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

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

362 pName = symbolVal (Proxy :: Proxy sym)

398 pName = symbolVal (Proxy :: Proxy sym)

363

399

364

400

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

401+

366−-- back the full `Response`.

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

367−-- TODO redo

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

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

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

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

370− -> Event t ()

405+ -> Event t tag

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

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

372−

407+

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

374− clientWithRoute _ _ _ baseurl xhrs triggers = do

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

409+

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

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

376− Left e -> Left e

411+ Left e -> Left e

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

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

378− <> _xhrRequest_url jx})

379− xhrs

380− (showBaseUrl <$> baseurl)

413+ ) xhrs (showBaseUrl <$> baseurl)

381− reqs = tagPromptlyDyn xhrs' triggers

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

382− okReq = fmapMaybe hush reqs

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

383− badReq = fmapMaybe tattle reqs

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

384− resps <- performRequestAsync okReq

417+

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

418+ resps <- performRequestsAsync okReq

386− ,fmap RequestFailure badReq]

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

387−

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

388−

421+ ]

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

422+

390−hush = either (const Nothing) Just

391−

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

393−tattle = either Just (const Nothing)

394

423

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

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

396-- the corresponding querying function will automatically take

425-- the corresponding querying function will automatically take

@@ -412,14 +441,14 @@ tattle = either Just (const Nothing)

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

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

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

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

414

443

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

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

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

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

417

446

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

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

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

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

420

449

421− clientWithRoute Proxy q req baseurl body =

450+ clientWithRoute Proxy q t req baseurl body =

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

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

423 where req' = req { reqBody = bodyBytesCT }

452 where req' = req { reqBody = bodyBytesCT }

424 ctProxy = Proxy :: Proxy ct

453 ctProxy = Proxy :: Proxy ct

425 ctString = T.pack $ show $ contentType ctProxy

454 ctString = T.pack $ show $ contentType ctProxy

@@ -427,39 +456,49 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)

427 (\b -> (mimeRender ctProxy b, ctString))

456 (\b -> (mimeRender ctProxy b, ctString))

428 body

457 body

429

458

459+

460+

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

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

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

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

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

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

433

464

434− clientWithRoute Proxy q req =

465+ clientWithRoute Proxy q t req baseurl =

435− clientWithRoute (Proxy :: Proxy sublayout) q

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

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

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

437

468

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

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

439

470

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

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

442

471

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

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

474+

475+ clientWithRoute Proxy q t req baseurl =

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

477+

478+

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

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

481+

482+ clientWithRoute Proxy q t req baseurl =

443− clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)

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

484+

444

485

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

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

447

486

448− clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)

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

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

449

489

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

490+ clientWithRoute Proxy q t req baseurl =

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

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

452

492

453− clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)

454

493

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

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

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

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

457

496

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

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

459− -> Client t m api

498+ -> Client t m api tag

460

499

461− clientWithRoute Proxy q req baseurl authdata =

500+ clientWithRoute Proxy q t req baseurl authdata =

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

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

463 where

502 where

464 req' = req { authData = Just authdata }

503 req' = req { authData = Just authdata }

465

504

src/Servant/Reflex/Multi.hsnew file+372

@@ -0,0 +1,372 @@

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+ , BaseUrl(..)

20+ , Scheme(..)

21+

22+ -- * Build QueryParam arguments

23+ , QParam(..)

24+

25+

26+ -- * Access response data

27+ , ReqResult(..)

28+ , reqSuccess

29+ , reqSuccess'

30+ , reqFailure

31+ , response

32+

33+ , HasClientMulti(..)

34+ ) where

35+

36+------------------------------------------------------------------------------

37+import Control.Applicative (liftA2)

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

39+import Data.Proxy (Proxy (..))

40+import qualified Data.Set as Set

41+import Data.Text (Text)

42+import qualified Data.Text as T

43+import qualified Data.Text.Encoding as E

44+import GHC.TypeLits (KnownSymbol, symbolVal)

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

46+ BasicAuthData, BuildHeadersTo (..),

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

48+ HttpVersion, IsSecure, MimeRender (..),

49+ MimeUnrender, NoContent, QueryFlag,

50+ QueryParam, QueryParams, Raw,

51+ ReflectMethod (..), RemoteHost,

52+ ReqBody, ToHttpApiData (..), Vault,

53+ Verb, contentType)

54+

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

56+ XhrRequest (..),

57+ XhrResponseHeaders (..),

58+ attachPromptlyDynWith, constDyn)

59+------------------------------------------------------------------------------

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

61+ SupportsServantReflex)

62+import Servant.Common.Req (QParam (..), QueryPart (..), Req,

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

64+ defReq, performRequestsCT,

65+ performRequestsNoBody,

66+ performSomeRequestsAsync,

67+ prependToPathParts, qParamToQueryPart,

68+ qParams, reqBody, reqFailure,

69+ reqMethod, reqSuccess, reqSuccess',

70+ respHeaders, response)

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

72+

73+

74+------------------------------------------------------------------------------

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

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

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

78+clientA p q f tag baseurl =

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

80+

81+

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

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

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

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

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

87+ -> ClientMulti t m layout f tag

88+

89+

90+------------------------------------------------------------------------------

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

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

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

94+ ClientMulti t m b f tag

95+ clientWithRouteMulti Proxy q f tag reqs baseurl =

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

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

98+

99+

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

101+instance (SupportsServantReflex t m,

102+ ToHttpApiData a,

103+ HasClientMulti t m sublayout f tag,

104+ Applicative f)

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

106+

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

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

109+

110+ clientWithRouteMulti _ q f tag reqs baseurl vals =

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

112+ where

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

114+ ps = (fmap . fmap . fmap) toUrlPiece vals

115+

116+

117+------------------------------------------------------------------------------

118+-- VERB (Returning content) --

119+instance {-# OVERLAPPABLE #-}

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

121+ (MimeUnrender ct a,

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

123+ SupportsServantReflex t m,

124+ Applicative f,

125+ Traversable f

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

127+

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

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

130+

131+ clientWithRouteMulti _ _ _ _ reqs baseurl =

132+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl

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

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

135+

136+

137+------------------------------------------------------------------------------

138+-- -- VERB (No content) --

139+instance {-# OVERLAPPING #-}

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

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

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

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

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

145+ -- ExceptT ServantError IO NoContent

146+ clientWithRouteMulti Proxy _ _ _ req baseurl =

147+ performRequestsNoBody method req baseurl

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

149+

150+

151+------------------------------------------------------------------------------

152+instance {-# OVERLAPPABLE #-}

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

154+ ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

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

156+ SupportsServantReflex t m,

157+ Traversable f

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

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

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

161+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do

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

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

164+ return $ fmap toHeaders <$> resp

165+ where

166+ reqs' = fmap (\r ->

167+ r { respHeaders =

168+ OnlyHeaders (Set.fromList

169+ (buildHeaderKeysTo (Proxy :: Proxy ls)))

170+ }) <$> reqs

171+

172+

173+------------------------------------------------------------------------------

174+instance {-# OVERLAPPABLE #-}

175+ ( BuildHeadersTo ls,

176+ BuildHeaderKeysTo ls,

177+ ReflectMethod method,

178+ SupportsServantReflex t m,

179+ Traversable f

180+ ) => HasClientMulti t m (Verb method status

181+ cts (Headers ls NoContent)) f tag where

182+ type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag

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

184+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do

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

186+ resp <- performRequestsNoBody method reqs' baseurl triggers

187+ return $ fmap toHeaders <$> resp

188+ where reqs' = fmap (\req ->

189+ req {respHeaders = OnlyHeaders (Set.fromList

190+ (buildHeaderKeysTo (Proxy :: Proxy ls)))

191+ }) <$> reqs

192+

193+

194+------------------------------------------------------------------------------

195+instance (KnownSymbol sym,

196+ ToHttpApiData a,

197+ HasClientMulti t m sublayout f tag,

198+ SupportsServantReflex t m,

199+ Traversable f,

200+ Applicative f)

201+ => HasClientMulti t m (Header sym a :> sublayout) f tag where

202+

203+ type ClientMulti t m (Header sym a :> sublayout) f tag =

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

205+

206+ clientWithRouteMulti Proxy f q tag reqs baseurl eVals =

207+ clientWithRouteMulti (Proxy :: Proxy sublayout) f

208+ q tag

209+ reqs'

210+ baseurl

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

212+ reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)

213+ <$> eVals <*>) <$> reqs

214+

215+

216+------------------------------------------------------------------------------

217+instance HasClientMulti t m sublayout f tag

218+ => HasClientMulti t m (HttpVersion :> sublayout) f tag where

219+

220+ type ClientMulti t m (HttpVersion :> sublayout) f tag =

221+ ClientMulti t m sublayout f tag

222+

223+ clientWithRouteMulti Proxy q f tag =

224+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

225+

226+

227+------------------------------------------------------------------------------

228+instance (KnownSymbol sym,

229+ ToHttpApiData a,

230+ HasClientMulti t m sublayout f tag,

231+ Reflex t,

232+ Applicative f)

233+ => HasClientMulti t m (QueryParam sym a :> sublayout) f tag where

234+

235+ type ClientMulti t m (QueryParam sym a :> sublayout) f tag =

236+ Dynamic t (f (QParam a)) -> ClientMulti t m sublayout f tag

237+

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

239+ -- TODO: Check the above comment

240+ clientWithRouteMulti Proxy q f tag reqs baseurl mparams =

241+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

242+ reqs' baseurl

243+

244+ where pname = symbolVal (Proxy :: Proxy sym)

245+ p prm = QueryPartParam $ fmap qParamToQueryPart prm

246+ paramPair mp = (T.pack pname, p mp)

247+ -- reqs' = (\params reqs -> (\req param -> req {qParams = paramPair param : qParams req}) <$> reqs <*> params)

248+ -- <$> mparams <*> reqs

249+ reqs' = liftA2 (\(pr :: QParam a) (r :: Req t) -> r { qParams = paramPair (constDyn pr) : qParams r })

250+ <$> mparams <*> reqs

251+

252+

253+instance (KnownSymbol sym,

254+ ToHttpApiData a,

255+ HasClientMulti t m sublayout f tag,

256+ Reflex t,

257+ Applicative f)

258+ => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where

259+

260+ type ClientMulti t m (QueryParams sym a :> sublayout) f tag =

261+ Dynamic t (f [a]) -> ClientMulti t m sublayout f tag

262+

263+ clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =

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

265+

266+ where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }

267+ pname = symbolVal (Proxy :: Proxy sym)

268+ params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)

269+ l

270+ reqs' = liftA2 req' <$> paramlists <*> reqs

271+

272+

273+instance (KnownSymbol sym,

274+ HasClientMulti t m sublayout f tag,

275+ Reflex t,

276+ Applicative f)

277+ => HasClientMulti t m (QueryFlag sym :> sublayout) f tag where

278+

279+ type ClientMulti t m (QueryFlag sym :> sublayout) f tag =

280+ Dynamic t (f Bool) -> ClientMulti t m sublayout f tag

281+

282+ clientWithRouteMulti Proxy q f' tag reqs baseurl flags =

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

284+

285+ where req' f req = req { qParams = thisPair (constDyn f) : qParams req }

286+ thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)

287+ pName = symbolVal (Proxy :: Proxy sym)

288+ reqs' = liftA2 req' <$> flags <*> reqs

289+

290+

291+instance (SupportsServantReflex t m,

292+ Traversable f, Applicative f) => HasClientMulti t m Raw f tag where

293+ type ClientMulti t m Raw f tag = f (Dynamic t (Either Text (XhrRequest ())))

294+ -> Event t tag

295+ -> m (Event t (f (ReqResult tag ())))

296+

297+ clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do

298+ let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))

299+ rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers

300+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync rawReqs''

301+ return resps

302+ where

303+ aux (tag, Right r) = ResponseSuccess tag () r

304+ aux (tag, Left e) = RequestFailure tag e

305+

306+

307+instance (MimeRender ct a,

308+ HasClientMulti t m sublayout f tag,

309+ Reflex t,

310+ Applicative f)

311+ => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where

312+

313+ type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =

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

315+

316+ clientWithRouteMulti Proxy q f tag reqs baseurl bodies =

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

318+ where req' b r = r { reqBody = bodyBytesCT (constDyn b) }

319+ ctProxy = Proxy :: Proxy ct

320+ ctString = T.pack $ show $ contentType ctProxy

321+ bodyBytesCT b = Just $ (fmap . fmap)

322+ (\b' -> (mimeRender ctProxy b', ctString))

323+ b

324+ reqs' = liftA2 req' <$> bodies <*> reqs

325+

326+

327+instance (KnownSymbol path,

328+ HasClientMulti t m sublayout f tag,

329+ Reflex t,

330+ Functor f) => HasClientMulti t m (path :> sublayout) f tag where

331+ type ClientMulti t m (path :> sublayout) f tag = ClientMulti t m sublayout f tag

332+

333+ clientWithRouteMulti Proxy q f tag reqs baseurl =

334+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

335+ (fmap (prependToPathParts (pure (Right $ T.pack p))) <$> reqs)

336+ baseurl

337+

338+ where p = symbolVal (Proxy :: Proxy path)

339+

340+

341+instance HasClientMulti t m api f tag => HasClientMulti t m (Vault :> api) f tag where

342+ type ClientMulti t m (Vault :> api) f tag = ClientMulti t m api f tag

343+

344+ clientWithRouteMulti Proxy q f tag reqs baseurl =

345+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

346+

347+

348+instance HasClientMulti t m api f tag => HasClientMulti t m (RemoteHost :> api) f tag where

349+ type ClientMulti t m (RemoteHost :> api) f tag = ClientMulti t m api f tag

350+

351+ clientWithRouteMulti Proxy q f tag reqs baseurl =

352+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

353+

354+

355+instance HasClientMulti t m api f tag => HasClientMulti t m (IsSecure :> api) f tag where

356+ type ClientMulti t m (IsSecure :> api) f tag = ClientMulti t m api f tag

357+

358+ clientWithRouteMulti Proxy q f tag reqs baseurl =

359+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

360+

361+

362+instance (HasClientMulti t m api f tag, Reflex t, Applicative f)

363+ => HasClientMulti t m (BasicAuth realm usr :> api) f tag where

364+

365+ type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))

366+ -> ClientMulti t m api f tag

367+

368+ clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =

369+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl

370+ where

371+ req' a r = r { authData = Just (constDyn a) }

372+ reqs' = liftA2 req' <$> authdatas <*> reqs

stack.yamlnew file+56

@@ -0,0 +1,56 @@

1+flags: {}

2+extra-package-dbs: []

3+packages:

4+- '.'

6+- location:

7+ git: https://github.com/reflex-frp/reflex

8+ commit: d78ba4318c425ca9b942dc387d7c5c7ab2d2e095

9+ extra-dep: true

10+

11+- location:

12+ git: https://github.com/mokus0/dependent-sum.git

13+ commit: bbc8ad3a81ea7f2b07ce7d036efd56f2e0f7c6ff

14+ extra-dep: true

15+

16+- location:

17+ git: https://github.com/gtk2hs/gtk2hs.git

18+ commit: 21d3a12a82756d04066e5e4198b35097012ee65b

19+ subdirs:

20+ - cairo

21+ - gio

22+ - glib

23+ - gtk

24+ - pango

25+ - tools

26+ extra-dep: true

27+

28+- location:

29+ git: https://github.com/byorgey/hashtables.git

30+ commit: 47d9ed261a5aba66a13d3c4da0e391d338b57fc5

31+ extra-dep: true

32+

33+- location:

34+ git: https://github.com/afcady/reflex-dom.git

35+ commit: 39b5ff23f3ae95d77c909ab3ed4bc4bd9e61f600

36+ extra-dep: true

37+

38+- location:

39+ git: https://github.com/afcady/dependent-sum-template.git

40+ commit: 68fc1a90580ea8f20775491cf651eefea422212a

41+ extra-dep: true

42+

43+extra-deps:

44+- cpphs-1.20.4

45+- directory-1.2.7.1

46+- ghcjs-dom-0.2.4.0

47+- haskell-src-exts-1.17.1

48+- haskell-src-meta-0.6.0.14

49+- hlint-1.9.35

50+- prim-uniq-0.1.0.1

51+- primitive-0.6.2.0

52+- ref-tf-0.4.0.1

53+- vector-0.12.0.0

54+- webkitgtk3-javascriptcore-0.13.2.0

55+- zenc-0.1.1

56+resolver: lts-8.3