f870bba · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

Drop non-traversable versions of performRequest*

commitf870bbaa85a6eff0b10d98732f32f4c831ec5a6b authorGreg Hale <imalsogreg@gmail.com> dateSat 4 Mar 2017, 14:37 (10 years ago) parent5d0ef87

3 files changed+113−101

compare with master

unifiedsplit

src/Servant/Common/Req.hs+75−67 src/Servant/Reflex.hs+23−20 src/Servant/Reflex/Multi.hs+15−14

src/Servant/Common/Req.hs+75−67

@@ -37,28 +37,32 @@ import Servant.API.BasicAuth

3737

3838

3939

40−data ReqResult a = ResponseSuccess a XhrResponse

41− | ResponseFailure Text XhrResponse

42− | RequestFailure Text

40+data ReqResult tag a = ResponseSuccess tag a XhrResponse

41+ | ResponseFailure tag Text XhrResponse

42+ | RequestFailure tag Text

4343

44−instance Functor ReqResult where

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

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

47− fmap _ (RequestFailure r) = RequestFailure r

44+instance Functor (ReqResult tag) where

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

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

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

4848

49−reqSuccess :: ReqResult a -> Maybe a

50−reqSuccess (ResponseSuccess x _) = Just x

51−reqSuccess _ = Nothing

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

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

51+reqSuccess _ = Nothing

5252

53−reqFailure :: ReqResult a -> Maybe Text

54−reqFailure (ResponseFailure s _) = Just s

55−reqFailure (RequestFailure s) = Just s

56−reqFailure _ = Nothing

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

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

55+reqSuccess' _ = Nothing

5756

58−response :: ReqResult a -> Maybe XhrResponse

59−response (ResponseSuccess _ x) = Just x

60−response (ResponseFailure _ x) = Just x

61−response _ = Nothing

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

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

59+reqFailure (RequestFailure _ s) = Just s

60+reqFailure _ = Nothing

61+

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

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

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

65+response _ = Nothing

6266

6367

6468-------------------------------------------------------------------------------

@@ -285,38 +289,39 @@ bytesToPayload :: BL.ByteString -> XhrPayload

285289bytesToPayload = TE.decodeUtf8 . BL.toStrict

286290

287291

288−performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)

289− => Text

290− -> Req t

291− -> Dynamic t BaseUrl

292− -> Event t tag -> m (Event t (tag, ReqResult NoContent))

293−performRequestNoBody reqMeth req reqHost trigger = do

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

295− let decodeResp = const $ Right NoContent

296− return $ leftmost [ fmap (second (evalResponse decodeResp)) resp,

297− fmap (second RequestFailure) badReq]

298−

299−

300−

301−performRequestCT

302− :: (SupportsServantReflex t m,

303− MimeUnrender ct a)

304− => Proxy ct

305− -> Text

306− -> Req t

307− -> Dynamic t BaseUrl

308− -> Event t tag

309− -> m (Event t (tag, ReqResult a))

310−performRequestCT ct reqMeth req reqHost trigger = do

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

312− let decodeResp x = first T.pack .

313− mimeUnrender ct .

314− BL.fromStrict .

315− TE.encodeUtf8 =<< note "No body text"

316− (_xhrResponse_responseText x)

317−

318− return $ leftmost [fmap (second (evalResponse decodeResp)) resp,

319− fmap (second RequestFailure) badReq]

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

293+-- => Text

294+-- -> Req t

295+-- -> Dynamic t BaseUrl

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

297+-- performRequestNoBody reqMeth req reqHost trigger = do

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

299+-- let decodeResp = const $ Right NoContent

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

301+-- , fmap (uncurry RequestFailure) badReq

302+-- ]

303+

304+

305+-- performRequestCT

306+-- :: (SupportsServantReflex t m,

307+-- MimeUnrender ct a)

308+-- => Proxy ct

309+-- -> Text

310+-- -> Req t

311+-- -> Dynamic t BaseUrl

312+-- -> Event t tag

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

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

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

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

317+-- mimeUnrender ct .

318+-- BL.fromStrict .

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

320+-- (_xhrResponse_responseText x)

321+

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

323+-- , fmap (uncurry RequestFailure) badReq

324+-- ]

320325

321326

322327performRequestsCT

@@ -327,7 +332,7 @@ performRequestsCT

327332 -> Dynamic t (f (Req t))

328333 -> Dynamic t BaseUrl

329334 -> Event t tag

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

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

331336performRequestsCT ct reqMeth reqs reqHost trigger = do

332337 resps <- performRequests reqMeth reqs reqHost trigger

333338 let decodeResp x = first T.pack .

@@ -335,11 +340,12 @@ performRequestsCT ct reqMeth reqs reqHost trigger = do

335340 BL.fromStrict .

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

337342 (_xhrResponse_responseText x)

338− return $ ffor resps $ \(t, rs) ->

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

340− Left e -> RequestFailure e

341− Right g -> evalResponse decodeResp g

343+ return $ fmap

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

345+ Left e -> RequestFailure t e

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

342347 )

348+ resps

343349

344350

345351performRequestsNoBody

@@ -349,30 +355,32 @@ performRequestsNoBody

349355 -> Dynamic t (f (Req t))

350356 -> Dynamic t BaseUrl

351357 -> Event t tag

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

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

353359performRequestsNoBody reqMeth reqs reqHost trigger = do

354360 resps <- performRequests reqMeth reqs reqHost trigger

355361 let decodeResp = const $ Right NoContent

356− return $ ffor resps $ \(t, rs) ->

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

358− Left e -> RequestFailure e

359− Right g -> evalResponse decodeResp g

360− )

361−

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

363+ Left e -> RequestFailure tag e

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

362365

363366

364367------------------------------------------------------------------------------

365−evalResponse :: (XhrResponse -> Either Text a) -> XhrResponse -> ReqResult a

366−evalResponse decode xhr =

368+evalResponse

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

370+ -> (tag, XhrResponse)

371+ -> ReqResult tag a

372+evalResponse decode (tag, xhr) =

367373 let okStatus = _xhrResponse_status xhr < 400

368374 errMsg = fromMaybe

369375 ("Empty response with error code " <>

370376 T.pack (show $ _xhrResponse_status xhr))

371377 (_xhrResponse_responseText xhr)

372378 respPayld = if okStatus

373− then either (flip ResponseFailure xhr)

374− (flip ResponseSuccess xhr) (decode xhr)

375− else ResponseFailure errMsg xhr

379+ then either

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

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

382+ (decode xhr)

383+ else ResponseFailure tag errMsg xhr

376384 in respPayld

377385

378386

src/Servant/Reflex.hs+23−20

@@ -39,6 +39,7 @@ import Data.Monoid ((<>))

3939import qualified Data.Set as Set

4040import qualified Data.Text.Encoding as E

4141import Data.CaseInsensitive (mk)

42+import Data.Functor.Identity

4243import Data.Proxy (Proxy (..))

4344import qualified Data.Map as Map

4445import Data.Text (Text)

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

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

5859 XhrRequest(..),

5960 XhrResponseHeaders(..),

60− XhrResponse(..), attachPromptlyDynWith, ffor, fmapMaybe,

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

6162 leftmost, performRequestsAsync,

6263 )

6364------------------------------------------------------------------------------

@@ -66,10 +67,10 @@ import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget

6667 SupportsServantReflex)

6768import Servant.Common.Req (Req, ReqResult(..), QParam(..),

6869 QueryPart(..), addHeader, authData,

69− defReq, prependToPathParts,

70− performRequestCT,

70+ defReq, evalResponse, prependToPathParts,

71+ -- performRequestCT,

7172 performRequestsCT,

72− performRequestNoBody,

73+ -- performRequestNoBody,

7374 performRequestsNoBody,

7475 performSomeRequestsAsync,

7576 qParamToQueryPart, reqBody,

@@ -146,11 +147,12 @@ instance {-# OVERLAPPABLE #-}

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

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

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

149− Event t tag -> m (Event t (tag, ReqResult a))

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

150151 -- TODO how to access input types here?

151152 -- ExceptT ServantError IO a

152153 clientWithRoute Proxy _ _ req baseurl trigs =

153− performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs

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

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

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

155157 req' = req { reqMethod = method }

156158

@@ -160,15 +162,15 @@ instance {-# OVERLAPPING #-}

160162 (ReflectMethod method, SupportsServantReflex t m) =>

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

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

163− Event t tag -> m (Event t (tag, ReqResult NoContent))

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

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

165167 -- ExceptT ServantError IO NoContent

166168 clientWithRoute Proxy _ _ req baseurl =

167− performRequestNoBody method req baseurl

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

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

169171

170172

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

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

172174toHeaders r =

173175 let toBS = E.encodeUtf8

174176 hdrs = maybe []

@@ -199,11 +201,11 @@ instance {-# OVERLAPPABLE #-}

199201 SupportsServantReflex t m

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

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

202− Event t tag -> m (Event t (tag, ReqResult (Headers ls a)))

203− clientWithRoute Proxy _ _ req baseurl = do

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

205+ clientWithRoute Proxy _ _ req baseurl trigs = do

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

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

206− return $ (fmap . fmap) toHeaders <$> resp

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

208+ return $ toHeaders <$> resp

207209 where req' = req { respHeaders =

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

209211 }

@@ -215,11 +217,11 @@ instance {-# OVERLAPPABLE #-}

215217 SupportsServantReflex t m

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

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

218− = Event t tag -> m (Event t (tag, ReqResult (Headers ls NoContent)))

219− clientWithRoute Proxy _ _ req baseurl = do

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

221+ clientWithRoute Proxy _ _ req baseurl trigs = do

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

221− resp <- performRequestNoBody method req' baseurl

222− return $ (fmap . fmap) toHeaders <$> resp

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

224+ return $ toHeaders <$> resp

223225 where req' = req {respHeaders =

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

225227 }

@@ -400,7 +402,7 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)

400402instance SupportsServantReflex t m => HasClient t m Raw tag where

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

402404 -> Event t tag

403− -> m (Event t (tag, ReqResult ()))

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

404406

405407 clientWithRoute _ _ _ _ baseurl xhrs triggers = do

406408

@@ -413,8 +415,9 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where

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

414416

415417 resps <- performRequestsAsync okReq

416− return $ leftmost [ fmap (ResponseSuccess ()) <$> resps

417− , fmap (RequestFailure) <$> badReq ]

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

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

420+ ]

418421

419422

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

src/Servant/Reflex/Multi.hs+15−14

@@ -54,9 +54,9 @@ import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget

5454import Servant.Common.Req (Req, ReqResult(..), QParam(..),

5555 QueryPart(..), addHeader, authData,

5656 defReq, prependToPathParts,

57− performRequestCT,

57+ -- performRequestCT,

5858 performRequestsCT,

59− performRequestNoBody,

59+ -- performRequestNoBody,

6060 performRequestsNoBody,

6161 performSomeRequestsAsync,

6262 qParamToQueryPart, reqBody,

@@ -120,7 +120,7 @@ instance {-# OVERLAPPABLE #-}

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

121121

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

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

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

124124

125125 clientWithRouteMulti _ _ f tag reqs baseurl =

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

@@ -134,7 +134,7 @@ instance {-# OVERLAPPING #-}

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

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

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

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

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

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

139139 -- ExceptT ServantError IO NoContent

140140 clientWithRouteMulti Proxy _ _ tag req baseurl =

@@ -151,11 +151,11 @@ instance {-# OVERLAPPABLE #-}

151151 Traversable f

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

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

154− Event t tag -> m (Event t (tag, f (ReqResult (Headers ls a))))

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

155155 clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do

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

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

158− return $ (fmap . fmap) toHeaders <$> resp

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

158+ return $ fmap toHeaders <$> resp

159159 where

160160 reqs' = fmap (\r ->

161161 r { respHeaders =

@@ -174,11 +174,11 @@ instance {-# OVERLAPPABLE #-}

174174 ) => HasClientMulti t m (Verb method status

175175 cts (Headers ls NoContent)) f tag where

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

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

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

178178 clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do

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

180180 resp <- performRequestsNoBody method reqs' baseurl triggers

181− return $ (fmap . fmap) toHeaders <$> resp

181+ return $ fmap toHeaders <$> resp

182182 where reqs' = fmap (\req ->

183183 req {respHeaders = OnlyHeaders (Set.fromList

184184 (buildHeaderKeysTo (Proxy :: Proxy ls)))

@@ -287,19 +287,20 @@ instance (KnownSymbol sym,

287287

288288

289289instance (SupportsServantReflex t m,

290− Traversable f) => HasClientMulti t m Raw f tag where

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

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

292292 -> Event t tag

293− -> m (Event t (tag, f (ReqResult ())))

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

294294

295295 clientWithRouteMulti _ _ _ _ oldReqs baseurl rawReqs triggers = do

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

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

298− resps <- fmap (second (fmap aux) . getCompose) <$> performSomeRequestsAsync rawReqs''

298+-- resps <- fmap (second (fmap aux) . getCompose) <$> performSomeRequestsAsync rawReqs''

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

299300 return resps

300301 where

301− aux (Right r) = ResponseSuccess () r

302− aux (Left e) = RequestFailure e

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

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

303304

304305

305306instance (MimeRender ct a,