2cd77cf · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

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

commit2cd77cf982a1db9d776eae4fb0da1302538c9f83 authorGreg Hale <imalsogreg@gmail.com> dateTue 19 Jul 2016, 12:25 (10 years ago) parentd8a9c57

7 files changed+91−49

compare with master

unifiedsplit

exec/Example.hs+6−5 servant-reflex.cabal+1−1 src/Servant/Common/Req.hs+22−22 src/Servant/Reflex.hs+13−13 testserver/Main.hs+9−7 testserver/testserver.cabal+8−1 testserver/tr.nix+32

exec/Example.hs+6−5

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

5959 text "Name"

6060 el "br" $ return ()

6161 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

6363 el "br" $ return ()

6464

6565 text "Greetings (space-separated)"

6666 el "br" $ return ()

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

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

6868

6969 el "br" $ return ()

7070

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

7272

7373 el "br" $ return ()

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

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

7576

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

77+ resp <- sayhi checkedName greetings gusto triggers

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

7879

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

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

8182 el "br" $ return ()

8283 dblinp <- value <$> textInput def

8384 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

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

8687 el "br" (return ())

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

8889

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

9091 text "Multi-part path"

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

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

9293 mpGo <- button "Test"

9394 multiResp <- multi b mpGo

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

servant-reflex.cabal+1−1

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

3535 reflex == 0.4.*,

3636 reflex-dom == 0.3.*,

3737 safe >= 0.3.9 && < 0.4,

38− servant >= 0.5 && < 0.8,

38+ servant >= 0.5 && < 0.9,

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

4040 text >= 1.2 && < 1.3,

4141 transformers >= 0.4 && < 0.5

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

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

7171qParamToQueryPart QNone = Right Nothing

7272qParamToQueryPart (QParamInvalid e) = Left e

7373

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

75− | QueryPartParams (Behavior t [Text])

76− | QueryPartFlag (Behavior t Bool)

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

75+ | QueryPartParams (Dynamic t [Text])

76+ | QueryPartFlag (Dynamic t Bool)

7777

7878data Req t = Req

7979 { reqMethod :: Text

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

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

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

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

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

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

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

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

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

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

8686 }

8787

8888defReq :: Reflex t => Req t

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

9090

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

9292prependToPathParts p req =

9393 req { reqPathParts = p : reqPathParts req }

9494

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

9696addHeader name val req = req { headers = headers req

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

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

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

115115performRequest reqMeth req reqHost trigger = do

116116

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

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

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

119119 t = sequence $ reverse $ reqPathParts req

120120

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

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

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

122+ baseUrl = Right . showBaseUrl <$> reqHost

123123

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

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

125125 urlParts = fmap sequence t

126126

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

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

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

129129

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

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

131131 queryPartString (pName, qp) = case qp of

132132 QueryPartParam p -> ffor p $ \case

133133 Left e -> Just (Left e)

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

142142 False -> Nothing

143143

144144

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

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

146146 queryPartStrings = map queryPartString (qParams req)

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

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

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

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

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

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

151151 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

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

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

156156

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

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

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

159159

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

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

165165 , _xhrRequestConfig_headers =

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

167167

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

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

169169 xhrOpts = case reqBody req of

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

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

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

178178 { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u

179179 , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}

180180

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

182182 addAuth xhr = case authData req of

183183 Nothing -> xhr

184184 Just auth -> liftA2 mkAuth auth xhr

185185

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

187187

188− let reqs = tag xhrReq trigger

188+ let reqs = tagDyn xhrReq trigger

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

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

191191

src/Servant/Reflex.hs+13−13

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

4747-- > myApi = Proxy

4848-- >

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

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

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

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

7676-- >

7777-- > getBook :: MonadWidget t m

7878-- => Dynamic t BaseUrl

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

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

8080-- -> Event t ()

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

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

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

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

8585

8686 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

8888

8989 clientWithRoute Proxy q req baseurl val =

9090 clientWithRoute (Proxy :: Proxy sublayout)

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

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

177177

178178 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

180180

181181 clientWithRoute Proxy q req baseurl _ =

182182 clientWithRoute (Proxy :: Proxy sublayout)

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

231231

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

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

235235

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

237237 clientWithRoute Proxy q req baseurl mparam =

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

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

277277

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

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

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

280280

281281 clientWithRoute Proxy q req baseurl paramlist =

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

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

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

316316

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

318− Behavior t Bool -> Client t m sublayout

318+ Dynamic t Bool -> Client t m sublayout

319319

320320 clientWithRoute Proxy q req baseurl flag =

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

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

329329-- back the full `Response`.

330330-- TODO redo

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

333333 -> Event t ()

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

335335

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

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

341341 <> _xhrRequest_url jx})

342342 xhrs

343− (showBaseUrl <$> current baseurl)

344− reqs = tag xhrs' triggers

343+ (showBaseUrl <$> baseurl)

344+ reqs = tagDyn xhrs' triggers

345345 okReq = fmapMaybe hush reqs

346346 badReq = fmapMaybe tattle reqs

347347 resps <- performRequestAsync okReq

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

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

380380

381381 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

383383

384384 clientWithRoute Proxy q req baseurl body =

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

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

397397

398398 clientWithRoute Proxy q req baseurl =

399399 clientWithRoute (Proxy :: Proxy sublayout) q

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

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

401401 baseurl

402402

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

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

423423instance (HasClient t m api, Reflex t)

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

425425

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)

427427 -> Client t m api

428428

429429 clientWithRoute Proxy q req baseurl authdata =

testserver/Main.hs+9−7

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

1212import Data.Monoid

1313import Data.Proxy

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

15+import qualified Data.Text as T

1516import GHC.Generics

1617import Snap.Http.Server

1718import Snap.Core

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

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

4647server :: Server API (Handler App App)

48− where sayhi nm greetings withGusto = case nm of

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

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

50+ sayhi nm greetings withGusto = case nm of

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

5052 Just n -> do

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

53+ let modifier = bool id T.toUpper withGusto

5254 greetPart

5355 | null greetings = "Hi, "

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

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

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

57− return . modifier $ greetPart ++ n

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

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

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

59+ return . modifier $ greetPart <> n

5860 dbl x = return $ x * 2

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

6062

testserver/testserver.cabal+8−1

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

1919 main-is: Main.hs

2020 -- other-modules:

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

2330 -- hs-source-dirs:

2431 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+}