ec87233 · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

on master help sign in

Merge pull request #65 from obsidiansystems/result-handler

ec87233Greg Hale8 years ago

src/Servant/Reflex.hs+81−48

compare with master

unifiedsplit

@@ -8,6 +8,7 @@

8{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE Rank2Types #-}

11{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE TupleSections #-}

13{-# LANGUAGE TupleSections #-}

13{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeFamilies #-}

@@ -25,7 +26,9 @@

25module Servant.Reflex

26module Servant.Reflex

26 ( client

27 ( client

27 , clientWithOpts

28 , clientWithOpts

29+ , clientWithOptsAndResultHandler

28 , clientWithRoute

30 , clientWithRoute

31+ , clientWithRouteAndResultHandler

29 , BuildHeaderKeysTo(..)

32 , BuildHeaderKeysTo(..)

30 , toHeaders

33 , toHeaders

31 , HasClient

34 , HasClient

@@ -120,21 +123,53 @@ clientWithOpts

120 -> Client t m layout tag

123 -> Client t m layout tag

121clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl

124clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl

122

125

126+-- | Like 'clientWithOpts' but allows passing a function which will process the

127+-- result event in some way. This can be used to handle errors in a uniform way

128+-- across call sites.

129+clientWithOptsAndResultHandler

130+ :: (HasClient t m layout tag)

131+ => Proxy layout

132+ -> Proxy m

133+ -> Proxy tag

134+ -> Dynamic t BaseUrl

135+ -> ClientOptions

136+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))

137+ -> Client t m layout tag

138+clientWithOptsAndResultHandler p q t = clientWithRouteAndResultHandler p q t defReq

139+

123

140

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

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

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

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

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

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

127−class HasClient t m layout (tag :: *) where

144+class Monad m => HasClient t m layout (tag :: *) where

128 type Client t m layout tag :: *

145 type Client t m layout tag :: *

129− clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag

146+ clientWithRoute

147+ :: Proxy layout

148+ -> Proxy m

149+ -> Proxy tag

150+ -> Req t

151+ -> Dynamic t BaseUrl

152+ -> ClientOptions

153+ -> Client t m layout tag

154+ clientWithRoute l m t r b o = clientWithRouteAndResultHandler l m t r b o return

155+

156+ clientWithRouteAndResultHandler

157+ :: Proxy layout

158+ -> Proxy m

159+ -> Proxy tag

160+ -> Req t

161+ -> Dynamic t BaseUrl

162+ -> ClientOptions

163+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))

164+ -> Client t m layout tag

130

165

131

166

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

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

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

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

134

169

135− clientWithRoute Proxy q pTag req baseurl opts =

170+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =

136− clientWithRoute (Proxy :: Proxy a) q pTag req baseurl opts :<|>

171+ clientWithRouteAndResultHandler (Proxy :: Proxy a) q pTag req baseurl opts wrap :<|>

137− clientWithRoute (Proxy :: Proxy b) q pTag req baseurl opts

172+ clientWithRouteAndResultHandler (Proxy :: Proxy b) q pTag req baseurl opts wrap

138

173

139

174

140-- Capture. Example:

175-- Capture. Example:

@@ -155,11 +190,9 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta

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

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

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

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

157

192

158− clientWithRoute Proxy q t req baseurl opts val =

193+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =

159− clientWithRoute (Proxy :: Proxy sublayout)

194+ clientWithRouteAndResultHandler

160− q t

161− (prependToPathParts p req)

195+ (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap

162− baseurl opts

163 where p = (fmap . fmap) (toUrlPiece) val

196 where p = (fmap . fmap) (toUrlPiece) val

164

197

165

198

@@ -172,8 +205,8 @@ instance {-# OVERLAPPABLE #-}

172 Event t tag -> m (Event t (ReqResult tag a))

205 Event t tag -> m (Event t (ReqResult tag a))

173 -- TODO how to access input types here?

206 -- TODO how to access input types here?

174 -- ExceptT ServantError IO a

207 -- ExceptT ServantError IO a

175− clientWithRoute Proxy _ _ req baseurl opts trigs =

208+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =

176− fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs

209+ wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs

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

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

178 req' = req { reqMethod = method }

211 req' = req { reqMethod = method }

179

212

@@ -186,8 +219,8 @@ instance {-# OVERLAPPING #-}

186 Event t tag -> m (Event t (ReqResult tag NoContent))

219 Event t tag -> m (Event t (ReqResult tag NoContent))

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

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

188 -- ExceptT ServantError IO NoContent

221 -- ExceptT ServantError IO NoContent

189− clientWithRoute Proxy _ _ req baseurl opts =

222+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =

190− (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl opts

223+ wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs

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

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

192

225

193

226

@@ -223,10 +256,10 @@ instance {-# OVERLAPPABLE #-}

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

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

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

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

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

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

226− clientWithRoute Proxy _ _ req baseurl opts trigs = do

259+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do

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

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

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

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

229− return $ toHeaders <$> resp

262+ wrap $ toHeaders <$> resp

230 where req' = req { respHeaders =

263 where req' = req { respHeaders =

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

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

232 }

265 }

@@ -239,10 +272,10 @@ instance {-# OVERLAPPABLE #-}

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

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

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

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

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

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

242− clientWithRoute Proxy _ _ req baseurl opts trigs = do

275+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do

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

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

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

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

245− return $ toHeaders <$> resp

278+ wrap $ toHeaders <$> resp

246 where req' = req {respHeaders =

279 where req' = req {respHeaders =

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

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

248 }

281 }

@@ -269,11 +302,11 @@ instance (KnownSymbol sym, ToHttpApiData a,

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

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

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

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

271

304

272− clientWithRoute Proxy q t req baseurl opts eVal =

305+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =

306+ clientWithRouteAndResultHandler

273− clientWithRoute (Proxy :: Proxy sublayout)

307+ (Proxy :: Proxy sublayout) q t

274− q t

275− (Servant.Common.Req.addHeader hname eVal req)

308+ (Servant.Common.Req.addHeader hname eVal req)

276− baseurl opts

309+ baseurl opts wrap

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

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

278

311

279

312

@@ -287,8 +320,8 @@ instance HasClient t m sublayout tag

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

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

288 Client t m sublayout tag

321 Client t m sublayout tag

289

322

290− clientWithRoute Proxy q t =

323+ clientWithRouteAndResultHandler Proxy =

291− clientWithRoute (Proxy :: Proxy sublayout) q t

324+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

292

325

293

326

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

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

@@ -324,9 +357,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex

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

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

325

358

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

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

327− clientWithRoute Proxy q t req baseurl opts mparam =

360+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =

328− clientWithRoute (Proxy :: Proxy sublayout) q t

361+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t

329− (req {qParams = paramPair : qParams req}) baseurl opts

362+ (req {qParams = paramPair : qParams req}) baseurl opts wrap

330

363

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

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

332 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm

365 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm

@@ -370,8 +403,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex

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

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

371 Dynamic t [a] -> Client t m sublayout tag

404 Dynamic t [a] -> Client t m sublayout tag

372

405

373− clientWithRoute Proxy q t req baseurl opts paramlist =

406+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =

374− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts

407+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap

375

408

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

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

377 pname = symbolVal (Proxy :: Proxy sym)

410 pname = symbolVal (Proxy :: Proxy sym)

@@ -410,8 +443,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)

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

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

411 Dynamic t Bool -> Client t m sublayout tag

444 Dynamic t Bool -> Client t m sublayout tag

412

445

413− clientWithRoute Proxy q t req baseurl opts flag =

446+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =

414− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts

447+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap

415

448

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

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

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

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

@@ -425,7 +458,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where

425 -> Event t tag

458 -> Event t tag

426 -> m (Event t (ReqResult tag ()))

459 -> m (Event t (ReqResult tag ()))

427

460

428− clientWithRoute _ _ _ _ baseurl _ xhrs triggers = do

461+ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do

429

462

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

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

431 Left e -> Left e

464 Left e -> Left e

@@ -436,7 +469,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where

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

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

437

470

438 resps <- performRequestsAsync okReq

471 resps <- performRequestsAsync okReq

439− return $ leftmost [ uncurry RequestFailure <$> badReq

472+ wrap $ leftmost [ uncurry RequestFailure <$> badReq

440 , evalResponse (const $ Right ()) <$> resps

473 , evalResponse (const $ Right ()) <$> resps

441 ]

474 ]

442

475

@@ -467,8 +500,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)

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

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

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

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

469

502

470− clientWithRoute Proxy q t req baseurl opts body =

503+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =

471− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts

504+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap

472 where req' = req { reqBody = bodyBytesCT }

505 where req' = req { reqBody = bodyBytesCT }

473 ctProxy = Proxy :: Proxy ct

506 ctProxy = Proxy :: Proxy ct

474 ctString = T.pack $ show $ contentType ctProxy

507 ctString = T.pack $ show $ contentType ctProxy

@@ -482,9 +515,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)

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

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

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

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

484

517

485− clientWithRoute Proxy q t req baseurl opts =

518+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =

486− clientWithRoute (Proxy :: Proxy sublayout) q t

519+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t

487− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts

520+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap

488

521

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

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

490

523

@@ -492,23 +525,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient

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

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

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

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

494

527

495− clientWithRoute Proxy q t req baseurl =

528+ clientWithRouteAndResultHandler Proxy =

496− clientWithRoute (Proxy :: Proxy api) q t req baseurl

529+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

497

530

498

531

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

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

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

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

501

534

502− clientWithRoute Proxy q t req baseurl =

535+ clientWithRouteAndResultHandler Proxy =

503− clientWithRoute (Proxy :: Proxy api) q t req baseurl

536+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

504

537

505

538

506

539

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

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

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

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

509

542

510− clientWithRoute Proxy q t req baseurl =

543+ clientWithRouteAndResultHandler Proxy =

511− clientWithRoute (Proxy :: Proxy api) q t req baseurl

544+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

512

545

513

546

514instance (HasClient t m api tag, Reflex t)

547instance (HasClient t m api tag, Reflex t)

@@ -517,8 +550,8 @@ instance (HasClient t m api tag, Reflex t)

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

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

518 -> Client t m api tag

551 -> Client t m api tag

519

552

520− clientWithRoute Proxy q t req baseurl opts authdata =

553+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =

521− clientWithRoute (Proxy :: Proxy api) q t req' baseurl opts

554+ clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap

522 where

555 where

523 req' = req { authData = Just authdata }

556 req' = req { authData = Just authdata }

524

557

@@ -561,7 +594,7 @@ for empty and one for non-empty lists).

561instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where

594instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where

562

595

563 type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag

596 type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag

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

597+ clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)

565

598

566

599

567type family HasCookieAuth xs :: Constraint where

600type family HasCookieAuth xs :: Constraint where