@@ -8,6 +8,7 @@
88{-# LANGUAGE MultiParamTypeClasses #-}
99{-# LANGUAGE OverloadedStrings #-}
1010{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE Rank2Types #-}
1112{-# LANGUAGE ScopedTypeVariables #-}
1213{-# LANGUAGE TupleSections #-}
1314{-# LANGUAGE TypeFamilies #-}
@@ -25,7 +26,9 @@
2526module Servant.Reflex
2627 ( client
2728 , clientWithOpts
29+ , clientWithOptsAndResultHandler
2830 , clientWithRoute
31+ , clientWithRouteAndResultHandler
2932 , BuildHeaderKeysTo(..)
3033 , toHeaders
3134 , HasClient
@@ -120,21 +123,53 @@ clientWithOpts
120123 -> Client t m layout tag
121124clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
122125
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+
123140
124141-- | This class lets us define how each API combinator
125142-- influences the creation of an HTTP request. It's mostly
126143-- 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
128145 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
130165
131166
132167instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
133168 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
134169
135− clientWithRoute Proxy q pTag req baseurl opts =
136− clientWithRoute (Proxy :: Proxy a) q pTag req baseurl opts :<|>
137− clientWithRoute (Proxy :: Proxy b) q pTag req baseurl opts
170+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =
171+ clientWithRouteAndResultHandler (Proxy :: Proxy a) q pTag req baseurl opts wrap :<|>
172+ clientWithRouteAndResultHandler (Proxy :: Proxy b) q pTag req baseurl opts wrap
138173
139174
140175-- Capture. Example:
@@ -155,11 +190,9 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
155190 type Client t m (Capture capture a :> sublayout) tag =
156191 Dynamic t (Either Text a) -> Client t m sublayout tag
157192
158− clientWithRoute Proxy q t req baseurl opts val =
159− clientWithRoute (Proxy :: Proxy sublayout)
160− q t
161− (prependToPathParts p req)
162− baseurl opts
193+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
194+ clientWithRouteAndResultHandler
195+ (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
163196 where p = (fmap . fmap) (toUrlPiece) val
164197
165198
@@ -172,8 +205,8 @@ instance {-# OVERLAPPABLE #-}
172205 Event t tag -> m (Event t (ReqResult tag a))
173206 -- TODO how to access input types here?
174207 -- ExceptT ServantError IO a
175− clientWithRoute Proxy _ _ req baseurl opts trigs =
176− fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
208+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
209+ wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
177210 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
178211 req' = req { reqMethod = method }
179212
@@ -186,8 +219,8 @@ instance {-# OVERLAPPING #-}
186219 Event t tag -> m (Event t (ReqResult tag NoContent))
187220 -- TODO: how to access input types here?
188221 -- ExceptT ServantError IO NoContent
189− clientWithRoute Proxy _ _ req baseurl opts =
190− (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl opts
222+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
223+ wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
191224 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
192225
193226
@@ -223,10 +256,10 @@ instance {-# OVERLAPPABLE #-}
223256 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
224257 type Client t m (Verb method status cts' (Headers ls a)) tag =
225258 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
227260 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
228261 resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
229− return $ toHeaders <$> resp
262+ wrap $ toHeaders <$> resp
230263 where req' = req { respHeaders =
231264 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
232265 }
@@ -239,10 +272,10 @@ instance {-# OVERLAPPABLE #-}
239272 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
240273 type Client t m (Verb method status cts (Headers ls NoContent)) tag
241274 = 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
243276 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
244277 resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
245− return $ toHeaders <$> resp
278+ wrap $ toHeaders <$> resp
246279 where req' = req {respHeaders =
247280 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
248281 }
@@ -269,11 +302,11 @@ instance (KnownSymbol sym, ToHttpApiData a,
269302 type Client t m (Header sym a :> sublayout) tag =
270303 Dynamic t (Either Text a) -> Client t m sublayout tag
271304
272− clientWithRoute Proxy q t req baseurl opts eVal =
273− clientWithRoute (Proxy :: Proxy sublayout)
274− q t
275− (Servant.Common.Req.addHeader hname eVal req)
276− baseurl opts
305+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =
306+ clientWithRouteAndResultHandler
307+ (Proxy :: Proxy sublayout) q t
308+ (Servant.Common.Req.addHeader hname eVal req)
309+ baseurl opts wrap
277310 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
278311
279312
@@ -287,8 +320,8 @@ instance HasClient t m sublayout tag
287320 type Client t m (HttpVersion :> sublayout) tag =
288321 Client t m sublayout tag
289322
290− clientWithRoute Proxy q t =
291− clientWithRoute (Proxy :: Proxy sublayout) q t
323+ clientWithRouteAndResultHandler Proxy =
324+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
292325
293326
294327-- | 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
324357 Dynamic t (QParam a) -> Client t m sublayout tag
325358
326359 -- if mparam = Nothing, we don't add it to the query string
327− clientWithRoute Proxy q t req baseurl opts mparam =
328− clientWithRoute (Proxy :: Proxy sublayout) q t
329− (req {qParams = paramPair : qParams req}) baseurl opts
360+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
361+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
362+ (req {qParams = paramPair : qParams req}) baseurl opts wrap
330363
331364 where pname = symbolVal (Proxy :: Proxy sym)
332365 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -370,8 +403,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
370403 type Client t m (QueryParams sym a :> sublayout) tag =
371404 Dynamic t [a] -> Client t m sublayout tag
372405
373− clientWithRoute Proxy q t req baseurl opts paramlist =
374− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
406+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
407+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
375408
376409 where req' = req { qParams = (T.pack pname, params') : qParams req }
377410 pname = symbolVal (Proxy :: Proxy sym)
@@ -410,8 +443,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
410443 type Client t m (QueryFlag sym :> sublayout) tag =
411444 Dynamic t Bool -> Client t m sublayout tag
412445
413− clientWithRoute Proxy q t req baseurl opts flag =
414− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
446+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
447+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
415448
416449 where req' = req { qParams = thisPair : qParams req }
417450 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -425,7 +458,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
425458 -> Event t tag
426459 -> m (Event t (ReqResult tag ()))
427460
428− clientWithRoute _ _ _ _ baseurl _ xhrs triggers = do
461+ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
429462
430463 let xhrs' = liftA2 (\x path -> case x of
431464 Left e -> Left e
@@ -436,7 +469,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
436469 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
437470
438471 resps <- performRequestsAsync okReq
439− return $ leftmost [ uncurry RequestFailure <$> badReq
472+ wrap $ leftmost [ uncurry RequestFailure <$> badReq
440473 , evalResponse (const $ Right ()) <$> resps
441474 ]
442475
@@ -467,8 +500,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
467500 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
468501 Dynamic t (Either Text a) -> Client t m sublayout tag
469502
470− clientWithRoute Proxy q t req baseurl opts body =
471− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
503+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
504+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
472505 where req' = req { reqBody = bodyBytesCT }
473506 ctProxy = Proxy :: Proxy ct
474507 ctString = T.pack $ show $ contentType ctProxy
@@ -482,9 +515,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
482515instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
483516 type Client t m (path :> sublayout) tag = Client t m sublayout tag
484517
485− clientWithRoute Proxy q t req baseurl opts =
486− clientWithRoute (Proxy :: Proxy sublayout) q t
487− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts
518+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =
519+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
520+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap
488521
489522 where p = symbolVal (Proxy :: Proxy path)
490523
@@ -492,23 +525,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient
492525instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
493526 type Client t m (Vault :> api) tag = Client t m api tag
494527
495− clientWithRoute Proxy q t req baseurl =
496− clientWithRoute (Proxy :: Proxy api) q t req baseurl
528+ clientWithRouteAndResultHandler Proxy =
529+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
497530
498531
499532instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
500533 type Client t m (RemoteHost :> api) tag = Client t m api tag
501534
502− clientWithRoute Proxy q t req baseurl =
503− clientWithRoute (Proxy :: Proxy api) q t req baseurl
535+ clientWithRouteAndResultHandler Proxy =
536+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
504537
505538
506539
507540instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
508541 type Client t m (IsSecure :> api) tag = Client t m api tag
509542
510− clientWithRoute Proxy q t req baseurl =
511− clientWithRoute (Proxy :: Proxy api) q t req baseurl
543+ clientWithRouteAndResultHandler Proxy =
544+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
512545
513546
514547instance (HasClient t m api tag, Reflex t)
@@ -517,8 +550,8 @@ instance (HasClient t m api tag, Reflex t)
517550 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
518551 -> Client t m api tag
519552
520− clientWithRoute Proxy q t req baseurl opts authdata =
521− clientWithRoute (Proxy :: Proxy api) q t req' baseurl opts
553+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
554+ clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
522555 where
523556 req' = req { authData = Just authdata }
524557
@@ -561,7 +594,7 @@ for empty and one for non-empty lists).
561594instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where
562595
563596 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)
565598
566599
567600type family HasCookieAuth xs :: Constraint where