2cd77cf · servant-reflex

git.iko.soy/servant-reflex

on master help sign in

Dynamic servant api, tagDyn to catch most recent parameters; update example

2cd77cfGreg Hale10 years ago

exec/Example.hs+6−5

compare with master

unifiedsplit

@@ -59,12 +59,12 @@ run = do

59 text "Name"

60 el "br" $ return ()

61 inp :: Dynamic t Text <- fmap value (textInput def)

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

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

63 el "br" $ return ()

65 text "Greetings (space-separated)"

66 el "br" $ return ()

67− greetings <- fmap (fmap T.words . current . value) (textInput def)

67+ greetings <- fmap (fmap T.words . value) (textInput def)

69 el "br" $ return ()

@@ -72,8 +72,9 @@ run = do

73 el "br" $ return ()

74 sayhiClicks :: Event t () <- button "Say hi"

75+ let triggers = leftmost [sayhiClicks, () <$ updated inp]

76− resp <- sayhi checkedName greetings (current gusto) sayhiClicks

77+ resp <- sayhi checkedName greetings gusto triggers

77 dynText =<< holdDyn "No hi yet" (leftmost [fmapMaybe reqSuccess resp, fmapMaybe reqFailure resp])

78 dynText =<< holdDyn "No hi yet" (leftmost [fmapMaybe reqSuccess resp, fmapMaybe reqFailure resp])

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

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

@@ -81,14 +82,14 @@ run = do

81 el "br" $ return ()

82 el "br" $ return ()

82 dblinp <- value <$> textInput def

83 dblinp <- value <$> textInput def

83 dblBtn <- button "Double it"

84 dblBtn <- button "Double it"

84− dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $ current dblinp) dblBtn

85+ dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $ dblinp) dblBtn

85 dynText =<< holdDyn "(no errors)" (fmapMaybe reqFailure dblResp)

86 dynText =<< holdDyn "(no errors)" (fmapMaybe reqFailure dblResp)

86 el "br" (return ())

87 el "br" (return ())

87 display =<< holdDyn "No number yet" (fmap tShow $ fmapMaybe reqSuccess dblResp)

88 display =<< holdDyn "No number yet" (fmap tShow $ fmapMaybe reqSuccess dblResp)

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

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

90 text "Multi-part path"

91 text "Multi-part path"

91− b <- (current . value) <$> checkbox False def

92+ b <- value <$> checkbox False def

92 mpGo <- button "Test"

93 mpGo <- button "Test"

93 multiResp <- multi b mpGo

94 multiResp <- multi b mpGo

94 dynText =<< holdDyn "No res yet" (fmap tShow $ fmapMaybe reqSuccess $ multiResp)

95 dynText =<< holdDyn "No res yet" (fmap tShow $ fmapMaybe reqSuccess $ multiResp)

servant-reflex.cabal+1−1

@@ -35,7 +35,7 @@ library

35 reflex == 0.4.*,

36 reflex-dom == 0.3.*,

37 safe >= 0.3.9 && < 0.4,

38− servant >= 0.5 && < 0.8,

38+ servant >= 0.5 && < 0.9,

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

40 text >= 1.2 && < 1.3,

41 transformers >= 0.4 && < 0.5

src/Servant/Common/Req.hs+22−22

@@ -71,28 +71,28 @@ qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)

71qParamToQueryPart QNone = Right Nothing

72qParamToQueryPart (QParamInvalid e) = Left e

74−data QueryPart t = QueryPartParam (Behavior t (Either Text (Maybe Text)))

74+data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))

75− | QueryPartParams (Behavior t [Text])

75+ | QueryPartParams (Dynamic t [Text])

76− | QueryPartFlag (Behavior t Bool)

76+ | QueryPartFlag (Dynamic t Bool)

78data Req t = Req

79 { reqMethod :: Text

80− , reqPathParts :: [Behavior t (Either Text Text)]

80+ , reqPathParts :: [Dynamic t (Either Text Text)]

81 , qParams :: [(Text, QueryPart t)]

82− , reqBody :: Maybe (Behavior t (Either Text (BL.ByteString, Text)))

82+ , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))

83 -- , reqAccept :: [MediaType] -- TODO ?

84− , headers :: [(Text, Behavior t Text)]

84+ , headers :: [(Text, Dynamic t Text)]

85− , authData :: Maybe (Behavior t (Maybe BasicAuthData))

85+ , authData :: Maybe (Dynamic t (Maybe BasicAuthData))

86 }

88defReq :: Reflex t => Req t

89defReq = Req "GET" [] [] Nothing [] Nothing

91−prependToPathParts :: Reflex t => Behavior t (Either Text Text) -> Req t -> Req t

91+prependToPathParts :: Reflex t => Dynamic t (Either Text Text) -> Req t -> Req t

92prependToPathParts p req =

93 req { reqPathParts = p : reqPathParts req }

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

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

96addHeader name val req = req { headers = headers req

97 <> [(name, fmap (TE.decodeUtf8 . toHeader) val)]

98-- <> [(name, (fmap . fmap) (decodeUtf8 . toHeader) val)]

@@ -115,19 +115,19 @@ performRequest :: forall t m.MonadWidget t m

115performRequest reqMeth req reqHost trigger = do

116

117 -- Ridiculous functor-juggling! How to clean this up?

118− let t :: Behavior t [Either Text Text]

118+ let t :: Dynamic t [Either Text Text]

119 t = sequence $ reverse $ reqPathParts req

120

121− baseUrl :: Behavior t (Either Text Text)

121+ baseUrl :: Dynamic t (Either Text Text)

122− baseUrl = Right . showBaseUrl <$> current reqHost

122+ baseUrl = Right . showBaseUrl <$> reqHost

123

124− urlParts :: Behavior t (Either Text [Text])

124+ urlParts :: Dynamic t (Either Text [Text])

125 urlParts = fmap sequence t

126

127− urlPath :: Behavior t (Either Text Text)

127+ urlPath :: Dynamic t (Either Text Text)

128 urlPath = (fmap.fmap) (T.intercalate "/") urlParts

129

130− queryPartString :: (Text, QueryPart t) -> Behavior t (Maybe (Either Text Text))

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

131 queryPartString (pName, qp) = case qp of

132 QueryPartParam p -> ffor p $ \case

133 Left e -> Just (Left e)

@@ -142,10 +142,10 @@ performRequest reqMeth req reqHost trigger = do

142 False -> Nothing

143

144

145− queryPartStrings :: [Behavior t (Maybe (Either Text Text))]

145+ queryPartStrings :: [Dynamic t (Maybe (Either Text Text))]

146 queryPartStrings = map queryPartString (qParams req)

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

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

148− queryString :: Behavior t (Either Text Text) =

148+ queryString :: Dynamic t (Either Text Text) =

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

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

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

@@ -154,7 +154,7 @@ performRequest reqMeth req reqHost trigger = do

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

155 | otherwise = x <> "/" <> y

156

157− xhrHeaders :: Behavior t [(Text, Text)]

157+ xhrHeaders :: Dynamic t [(Text, Text)]

158 xhrHeaders = sequence $ ffor (headers req) $ \(hName, hVal) -> fmap (hName,) hVal

159

160 mkConfigBody :: [(Text,Text)] -> (Either Text (BL.ByteString, Text)) -> Either Text (XhrRequestConfig LT.Text)

@@ -165,7 +165,7 @@ performRequest reqMeth req reqHost trigger = do

165 , _xhrRequestConfig_headers =

166 Map.insert "Content-Type" bCT (_xhrRequestConfig_headers def)}

167

168− xhrOpts :: Behavior t (Either Text (XhrRequestConfig LT.Text))

168+ xhrOpts :: Dynamic t (Either Text (XhrRequestConfig LT.Text))

169 xhrOpts = case reqBody req of

170 Nothing -> fmap (\h -> Right $ XhrRequestConfig

171 (Map.fromList h) Nothing Nothing Nothing "") xhrHeaders

@@ -178,14 +178,14 @@ performRequest reqMeth req reqHost trigger = do

178 { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u

179 , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}

180

181− addAuth :: Behavior t (Either Text (XhrRequestConfig x)) -> Behavior t (Either Text (XhrRequestConfig x))

181+ addAuth :: Dynamic t (Either Text (XhrRequestConfig x)) -> Dynamic t (Either Text (XhrRequestConfig x))

182 addAuth xhr = case authData req of

183 Nothing -> xhr

184 Just auth -> liftA2 mkAuth auth xhr

185

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

187

188− let reqs = tag xhrReq trigger

188+ let reqs = tagDyn xhrReq trigger

189 okReqs = fmapMaybe (either (const Nothing) Just) reqs

190 badReqs = fmapMaybe (either Just (const Nothing)) reqs

191

src/Servant/Reflex.hs+13−13

@@ -47,7 +47,7 @@ import Reflex.Dom

47-- > myApi = Proxy

48-- >

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

50−-- > postNewBook :: Behavior t (Maybe Book) -> Event t ()

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

51-- -> m (Event t (Either XhrError (Book,Book)))

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

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

@@ -76,7 +76,7 @@ instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where

76-- >

77-- > getBook :: MonadWidget t m

78-- => Dynamic t BaseUrl

79−-- -> Behavior t (Maybe Text)

79+-- -> Dynamic t (Maybe Text)

80-- -> Event t ()

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

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

@@ -84,7 +84,7 @@ instance (MonadWidget t m, KnownSymbol capture, ToHttpApiData a, HasClient t m s

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

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

87− Behavior t (Either Text a) -> Client t m sublayout

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

89 clientWithRoute Proxy q req baseurl val =

90 clientWithRoute (Proxy :: Proxy sublayout)

@@ -176,7 +176,7 @@ instance (KnownSymbol sym, ToHttpApiData a,

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

177

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

179− Behavior t (Either Text a) -> Client t m sublayout

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

180

181 clientWithRoute Proxy q req baseurl _ =

182 clientWithRoute (Proxy :: Proxy sublayout)

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

231

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

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

234− Behavior t (QParam a) -> Client t m sublayout

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

235

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

237 clientWithRoute Proxy q req baseurl mparam =

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

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

277

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

279− Behavior t [a] -> Client t m sublayout

279+ Dynamic t [a] -> Client t m sublayout

280

281 clientWithRoute Proxy q req baseurl paramlist =

282 clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl

@@ -315,7 +315,7 @@ instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)

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

316

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

318− Behavior t Bool -> Client t m sublayout

318+ Dynamic t Bool -> Client t m sublayout

319

320 clientWithRoute Proxy q req baseurl flag =

321 clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl

@@ -329,7 +329,7 @@ instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)

329-- back the full `Response`.

330-- TODO redo

331instance (MonadWidget t m) => HasClient t m Raw where

332− type Client t m Raw = Behavior t (Either Text (XhrRequest ()))

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

333 -> Event t ()

334 -> m (Event t (ReqResult ()))

335

@@ -340,8 +340,8 @@ instance (MonadWidget t m) => HasClient t m Raw where

340 Right jx -> Right $ jx {_xhrRequest_url = path

341 <> _xhrRequest_url jx})

342 xhrs

343− (showBaseUrl <$> current baseurl)

343+ (showBaseUrl <$> baseurl)

344− reqs = tag xhrs' triggers

344+ reqs = tagDyn xhrs' triggers

345 okReq = fmapMaybe hush reqs

346 badReq = fmapMaybe tattle reqs

347 resps <- performRequestAsync okReq

@@ -379,7 +379,7 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)

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

380

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

382− Behavior t (Either Text a) -> Client t m sublayout

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

383

384 clientWithRoute Proxy q req baseurl body =

385 clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl

@@ -397,7 +397,7 @@ instance (KnownSymbol path, HasClient t m sublayout, Reflex t) => HasClient t m

397

398 clientWithRoute Proxy q req baseurl =

399 clientWithRoute (Proxy :: Proxy sublayout) q

400− (prependToPathParts (constant (Right $ T.pack p)) req)

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

401 baseurl

402

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

@@ -423,7 +423,7 @@ instance HasClient t m api => HasClient t m (IsSecure :> api) where

423instance (HasClient t m api, Reflex t)

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

425

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

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

427 -> Client t m api

428

429 clientWithRoute Proxy q req baseurl authdata =

testserver/Main.hs+9−7

@@ -12,6 +12,7 @@ import qualified Data.List as L

12import Data.Monoid

13import Data.Proxy

14import Data.Text hiding (length, null, map, head, toUpper)

15+import qualified Data.Text as T

15import GHC.Generics

16import GHC.Generics

16import Snap.Http.Server

17import Snap.Http.Server

17import Snap.Core

18import Snap.Core

@@ -45,16 +46,17 @@ data App = App

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

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

46server :: Server API (Handler App App)

47server :: Server API (Handler App App)

49+ where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text

48− where sayhi nm greetings withGusto = case nm of

50+ sayhi nm greetings withGusto = case nm of

49− Nothing -> return ("Sorry, who are you?" :: String)

51+ Nothing -> return ("Sorry, who are you?" :: Text)

50 Just n -> do

52 Just n -> do

51− let modifier = bool id (map toUpper) withGusto

53+ let modifier = bool id T.toUpper withGusto

52 greetPart

54 greetPart

53 | null greetings = "Hi, "

55 | null greetings = "Hi, "

54− | length greetings == 1 = L.head greetings ++ ", "

56+ | length greetings == 1 = L.head greetings <> ", "

55− | otherwise = L.intercalate ", " (L.init greetings)

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

56− ++ ", and " ++ L.last greetings ++ ", "

58+ <> ", and " <> L.last greetings <> ", "

57− return . modifier $ greetPart ++ n

59+ return . modifier $ greetPart <> n

58 dbl x = return $ x * 2

60 dbl x = return $ x * 2

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

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

testserver/testserver.cabal+8−1

@@ -19,6 +19,13 @@ executable back

19 main-is: Main.hs

20 -- other-modules:

21 -- other-extensions:

22− build-depends: aeson, base >=4.8 && <4.9, snap, snap-server, snap-core, servant, servant-snap, text

22+ build-depends: aeson >= 0.9 && < 0.12

23+ , base >=4.8 && <4.10

24+ , snap >= 1.0 && < 1.1

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

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

27+ , servant >= 0.7.1 && < 0.8

28+ , servant-snap

29+ , text >= 1.2 && < 1.3

23 -- hs-source-dirs:

30 -- hs-source-dirs:

24 default-language: Haskell2010

31 default-language: Haskell2010

testserver/tr.nixnew file+32

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

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

2+let

4+ dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;

5+ cabal2nixResult = reflex-platform.cabal2nixResult;

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

7+in

8+reflex-platform.ghc.override {

9+ overrides = self: super: {

10+ servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});

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

12+ io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});

13+ io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});

14+ heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});

15+ xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});

16+ snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});

17+ snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});

18+ snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});

19+ snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});

20+ hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});

21+

22+ # servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});

23+ # servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});

24+ # servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});

25+ # servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});

26+ # servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});

27+ # servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});

28+ # servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});

29+ # servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});

30+

31+ };

32+}