c9de020 · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

Make the traversable f params dynamically sized

commitc9de02039971ce933a2900b3b6e8b16522e4621b authorGreg Hale <imalsogreg@gmail.com> dateSun 19 Feb 2017, 23:38 (10 years ago) parentafed558

3 files changed+95−43

compare with master

unifiedsplit

exec/Example.hs+14−2 src/Servant/Common/Req.hs+9−7 src/Servant/Reflex/Multi.hs+72−34

exec/Example.hs+14−2

@@ -42,7 +42,7 @@ runMulti :: forall t m. (SupportsServantReflex t m,

4242runMulti = do

4343 url <- baseUrlWidget

4444 el "br" blank

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

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

4646 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url

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

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

@@ -50,10 +50,22 @@ runMulti = do

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

5151 b <- button "Run dbl multi"

5252 reqCount <- count b

53− r <- dbl [num,num2] (tag (current reqCount) b)

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

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

5555 lastInd <- holdDyn Nothing (Just . fst <$> r)

5656 display lastInd

57+

58+ divClass "demo-group" $ do

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

60+ text "Names"

61+ textInput def

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

63+ text "Greetings"

64+ textInput def

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

66+ b <- button "Go"

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

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

5769 return ()

5870

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

src/Servant/Common/Req.hs+9−7

@@ -15,6 +15,7 @@ module Servant.Common.Req where

1515import Control.Concurrent

1616import Control.Applicative (liftA2, liftA3)

1717import Control.Arrow (second)

18+import Control.Monad (join)

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

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

2021import qualified Data.Map as Map

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

107108reqToReflexRequest

108109 :: forall t. Reflex t

109110 => Text

110− -> Req t

111111 -> Dynamic t BaseUrl

112+ -> Req t

112113 -> (Dynamic t (Either Text (XhrRequest XhrPayload)))

113−reqToReflexRequest reqMeth req reqHost =

114+reqToReflexRequest reqMeth reqHost req =

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

115116 t = sequence $ reverse $ reqPathParts req

116117

@@ -213,12 +214,13 @@ displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

213214-- | This function actually performs the request.

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

215216 => Text

216− -> f (Req t)

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

217218 -> Dynamic t BaseUrl

218219 -> Event t tag

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

220221performRequests reqMeth rs reqHost trigger = do

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

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

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

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

223225 resps <- performSomeRequestsAsync reqs

224226 return $ getCompose <$> resps

@@ -267,7 +269,7 @@ performRequest :: forall t m tag .(SupportsServantReflex t m)

267269 -> m (Event t (tag, XhrResponse), Event t (tag, Text))

268270performRequest reqMeth req reqHost trigger = do

269271

270− let xhrReq = reqToReflexRequest reqMeth req reqHost

272+ let xhrReq = reqToReflexRequest reqMeth reqHost req

271273 let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger

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

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

@@ -298,7 +300,7 @@ performRequestNoBody reqMeth req reqHost trigger = do

298300

299301performRequestsNoBody :: forall t m f tag. (SupportsServantReflex t m, Traversable f)

300302 => Text

301− -> f (Req t)

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

302304 -> Dynamic t BaseUrl

303305 -> Event t tag -> m (Event t (tag, f (ReqResult NoContent)))

304306performRequestsNoBody reqMeth reqs reqHost trigger = do

@@ -334,7 +336,7 @@ performRequestsCT

334336 MimeUnrender ct a, Traversable f)

335337 => Proxy ct

336338 -> Text

337− -> f (Req t)

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

338340 -> Dynamic t BaseUrl

339341 -> Event t tag

340342 -> m (Event t (tag, f (ReqResult a)))

src/Servant/Reflex/Multi.hs+72−34

@@ -44,7 +44,7 @@ import Servant.API ((:<|>)(..),(:>), BasicAuth,

4444import Reflex.Dom (Dynamic, Event, Reflex,

4545 XhrRequest(..),

4646 XhrResponseHeaders(..),

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

47+ XhrResponse(..), constDyn, ffor, fmapMaybe,

4848 leftmost, performRequestAsync, attachPromptlyDynWith,

4949 tagPromptlyDyn )

5050------------------------------------------------------------------------------

@@ -65,22 +65,38 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),

6565 qParams)

6666import Servant.Reflex (BuildHeaderKeysTo(..), toHeaders)

6767

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

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

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

7168

69+------------------------------------------------------------------------------

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

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

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

73+clientA p q f tag baseurl =

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

75+

76+

77+------------------------------------------------------------------------------

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

7379 type ClientMulti t m layout f tag :: *

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

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

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

82+ -> ClientMulti t m layout f tag

7583

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

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

84+

85+------------------------------------------------------------------------------

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

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

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

89+ ClientMulti t m b f tag

7890 clientWithRouteMulti Proxy q f tag reqs baseurl =

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

8092 clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl

8193

8294

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

95+------------------------------------------------------------------------------

96+instance (SupportsServantReflex t m,

97+ ToHttpApiData a,

98+ HasClientMulti t m sublayout f tag,

99+ Applicative f)

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

85101

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

@@ -88,9 +104,11 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClientMulti t m sublayo

88104

89105 clientWithRouteMulti l q f tag reqs baseurl vals = clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

90106 where

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

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

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

93109

110+

111+------------------------------------------------------------------------------

94112-- VERB (Returning content) --

95113instance {-# OVERLAPPABLE #-}

96114 -- Note [Non-Empty Content Types]

@@ -107,8 +125,10 @@ instance {-# OVERLAPPABLE #-}

107125 clientWithRouteMulti _ _ f tag reqs baseurl =

108126 performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl

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

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

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

129+

111130

131+------------------------------------------------------------------------------

112132-- -- VERB (No content) --

113133instance {-# OVERLAPPING #-}

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

@@ -121,6 +141,8 @@ instance {-# OVERLAPPING #-}

121141 performRequestsNoBody method req baseurl

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

123143

144+

145+------------------------------------------------------------------------------

124146instance {-# OVERLAPPABLE #-}

125147 -- Note [Non-Empty Content Types]

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

@@ -134,30 +156,36 @@ instance {-# OVERLAPPABLE #-}

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

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

136158 return $ (fmap . fmap) toHeaders <$> resp

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

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

139− }

159+ where

160+ reqs' = fmap (\r ->

161+ r { respHeaders =

162+ OnlyHeaders (Set.fromList

163+ (buildHeaderKeysTo (Proxy :: Proxy ls)))

164+ }) <$> reqs

140165

141166

167+------------------------------------------------------------------------------

142168instance {-# OVERLAPPABLE #-}

143169 ( BuildHeadersTo ls,

144170 BuildHeaderKeysTo ls,

145171 ReflectMethod method,

146172 SupportsServantReflex t m,

147173 Traversable f

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

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

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

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

150177 = Event t tag -> m (Event t (tag, f (ReqResult (Headers ls NoContent))))

151178 clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do

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

153180 resp <- performRequestsNoBody method reqs' baseurl triggers

154181 return $ (fmap . fmap) toHeaders <$> resp

155− where reqs' = ffor reqs $ \req ->

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

156183 req {respHeaders = OnlyHeaders (Set.fromList

157184 (buildHeaderKeysTo (Proxy :: Proxy ls)))

158− }

185+ }) <$> reqs

159186

160187

188+------------------------------------------------------------------------------

161189instance (KnownSymbol sym,

162190 ToHttpApiData a,

163191 HasClientMulti t m sublayout f tag,

@@ -175,10 +203,11 @@ instance (KnownSymbol sym,

175203 reqs'

176204 baseurl

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

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

179− <$> eVals <*> reqs

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

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

180208

181209

210+------------------------------------------------------------------------------

182211instance HasClientMulti t m sublayout f tag

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

184213

@@ -189,11 +218,17 @@ instance HasClientMulti t m sublayout f tag

189218 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

190219

191220

192−instance (KnownSymbol sym, ToHttpApiData a, HasClientMulti t m sublayout f tag, Reflex t, Traversable f, Applicative f)

221+------------------------------------------------------------------------------

222+instance (KnownSymbol sym,

223+ ToHttpApiData a,

224+ HasClientMulti t m sublayout f tag,

225+ Reflex t,

226+ Traversable f,

227+ Applicative f)

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

194229

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

196− f (Dynamic t (QParam a)) -> ClientMulti t m sublayout f tag

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

197232

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

199234 -- TODO: Check the above comment

@@ -204,7 +239,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClientMulti t m sublayout f tag,

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

205240 p prm = QueryPartParam $ fmap qParamToQueryPart prm

206241 paramPair mp = (T.pack pname, p mp)

207− reqs' = (\param req -> req {qParams = paramPair param : qParams req})

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

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

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

208245 <$> mparams <*> reqs

209246

210247

@@ -217,16 +254,17 @@ instance (KnownSymbol sym,

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

218255

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

220− f (Dynamic t [a]) -> ClientMulti t m sublayout f tag

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

221258

222259 clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =

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

224261

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

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

226263 pname = symbolVal (Proxy :: Proxy sym)

227264 params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)

228265 l

229− reqs' = req' <$> paramlists <*> reqs

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

267+ -- reqs' = req' <$> paramlists <*> reqs

230268

231269

232270instance (KnownSymbol sym,

@@ -237,15 +275,15 @@ instance (KnownSymbol sym,

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

238276

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

240− f (Dynamic t Bool) -> ClientMulti t m sublayout f tag

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

241279

242280 clientWithRouteMulti Proxy q f tag reqs baseurl flags =

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

244282

245− where req' f req = req { qParams = thisPair f : qParams req }

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

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

247285 pName = symbolVal (Proxy :: Proxy sym)

248− reqs' = req' <$> flags <*> reqs

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

249287

250288

251289instance (SupportsServantReflex t m,

@@ -272,17 +310,17 @@ instance (MimeRender ct a,

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

273311

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

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

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

276314

277315 clientWithRouteMulti Proxy q f tag reqs baseurl bodies =

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

279− where req' b r = r { reqBody = bodyBytesCT b }

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

280318 ctProxy = Proxy :: Proxy ct

281319 ctString = T.pack $ show $ contentType ctProxy

282320 bodyBytesCT b = Just $ (fmap . fmap)

283321 (\b' -> (mimeRender ctProxy b', ctString))

284322 b

285− reqs' = req' <$> bodies <*> reqs

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

286324

287325

288326instance (KnownSymbol path,

@@ -293,7 +331,7 @@ instance (KnownSymbol path,

293331

294332 clientWithRouteMulti Proxy q f tag reqs baseurl =

295333 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

296− (prependToPathParts (pure (Right $ T.pack p)) <$> reqs)

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

297335 baseurl

298336

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

@@ -323,11 +361,11 @@ instance HasClientMulti t m api f tag => HasClientMulti t m (IsSecure :> api) f

323361instance (HasClientMulti t m api f tag, Reflex t, Traversable f, Applicative f)

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

325363

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

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

327365 -> ClientMulti t m api f tag

328366

329367 clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =

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

331369 where

332− req' a r = r { authData = Just a }

333− reqs' = req' <$> authdatas <*> reqs

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

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