git.iko.soy/servant-reflex
on master help sign in
Add ClientOptions to support withCredentials and request debugging
commitf3363261761b8ff6bffc03887394b3b92df3be10 authorGreg Hale <imalsogreg@gmail.com> dateSun 24 Sep 2017, 18:45 (9 years ago) parent810a32b
5 files changed+162−134
compare with master
unifiedsplit
exec/Example.hs+6−1 servant-reflex.cabal+1−1 src/Servant/Common/Req.hs+56−66 src/Servant/Reflex.hs+56−36 src/Servant/Reflex/Multi.hs+43−30
exec/Example.hs+6−1
@@ -98,7 +98,12 @@ run = mdo
9898 -- Name the computed API client functions
9999 let (getUnit :<|> getInt :<|> sayhi :<|> dbl
100100 :<|> multi :<|> qna :<|> secret :<|> doRaw) =
101− client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url
101+ clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url
102+ (ClientOptions {
103+ optsWithCredentials = True
104+ , optsDebugRequests = \x -> putStrLn "Got a request!" >>
105+ putStrLn (show x)
106+ })
102107
103108 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
104109
servant-reflex.cabal+1−1
@@ -1,5 +1,5 @@
11Name: servant-reflex
2−Version: 0.3.1
2+Version: 0.3.2
33Synopsis: Servant reflex API generator
44Description: Servant reflex API generator
55License: BSD3
src/Servant/Common/Req.hs+56−66
@@ -25,7 +25,7 @@ import Data.Text (Text)
2525import qualified Data.Text as T
2626import qualified Data.Text.Encoding as TE
2727import Data.Traversable (forM)
28−import Language.Javascript.JSaddle.Monad (JSM, MonadJSM)
28+import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
2929import Reflex.Dom hiding (tag)
3030import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
3131 SupportsServantReflex)
@@ -47,6 +47,18 @@ data ReqResult tag a
4747 -- ^ A failure to construct the request tagged with 'tag' at trigger time
4848 deriving (Functor)
4949
50+data ClientOptions = ClientOptions
51+ { optsWithCredentials :: Bool
52+ -- ^ Set withCredentials field of xhr requests
53+ , optsDebugRequests :: Either Text (XhrRequest XhrPayload) -> JSM ()
54+ -- ^ JSM action to run on each triggered request
55+ }
56+
57+defaultClientOptions :: ClientOptions
58+defaultClientOptions = ClientOptions
59+ { optsWithCredentials = False
60+ , optsDebugRequests = const (return ())
61+ }
5062
5163------------------------------------------------------------------------------
5264-- | Simple filter/accessor for successful responses, when you want to
@@ -120,10 +132,13 @@ data Req t = Req
120132 , headers :: [(Text, Dynamic t (Either Text Text))]
121133 , respHeaders :: XhrResponseHeaders
122134 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))
135+ -- , reqWithCreds :: Bool
136+ -- ^ set the withCredentials XHR flag
137+ -- , debugReq :: Either Text (XhrRequest XhrPayload) -> JSM ()
123138 }
124139
125140defReq :: Req t
126−defReq = Req "GET" [] [] Nothing [] def Nothing
141+defReq = Req "GET" [] [] Nothing [] def Nothing -- False (\_ -> return ())
127142
128143prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t
129144prependToPathParts p req =
@@ -137,9 +152,10 @@ reqToReflexRequest
137152 :: forall t. Reflex t
138153 => Text
139154 -> Dynamic t BaseUrl
155+ -> ClientOptions
140156 -> Req t
141− -> (Dynamic t (Either Text (XhrRequest XhrPayload)))
142−reqToReflexRequest reqMeth reqHost req =
157+ -> Dynamic t (Either Text (XhrRequest XhrPayload))
158+reqToReflexRequest reqMeth reqHost opts req =
143159 let t :: Dynamic t [Either Text Text]
144160 t = sequence $ reverse $ reqPathParts req
145161
@@ -196,11 +212,11 @@ reqToReflexRequest reqMeth reqHost req =
196212 Right $ XhrRequestConfig
197213 { _xhrRequestConfig_sendData = bytesToPayload bBytes
198214 , _xhrRequestConfig_headers =
199− Map.insert "Content-Type" bCT (Map.fromList hs)
215+ Map.insert "Content-Type" bCT (Map.fromList hs)
200216 , _xhrRequestConfig_user = Nothing
201217 , _xhrRequestConfig_password = Nothing
202218 , _xhrRequestConfig_responseType = Nothing
203− , _xhrRequestConfig_withCredentials = False
219+ , _xhrRequestConfig_withCredentials = optsWithCredentials opts
204220 , _xhrRequestConfig_responseHeaders = def
205221 }
206222
@@ -239,17 +255,26 @@ reqToReflexRequest reqMeth reqHost req =
239255displayHttpRequest :: Text -> Text
240256displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
241257
242−-- | This function actually performs the request.
258+-- | This function performs the request
243259performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
244260 => Text
245261 -> Dynamic t (f (Req t))
246262 -> Dynamic t BaseUrl
263+ -> ClientOptions
247264 -> Event t tag
248265 -> m (Event t (tag, f (Either Text XhrResponse)))
249−performRequests reqMeth rs reqHost trigger = do
250− -- let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))
251− let xhrReqs = join $ (\(fxhr :: f (Req t)) -> sequence $ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
252− let reqs = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
266+performRequests reqMeth rs reqHost opts trigger = do
267+ let xhrReqs =
268+ join $ (\(fxhr :: f (Req t)) -> sequence $
269+ reqToReflexRequest reqMeth reqHost opts <$> fxhr) <$> rs
270+
271+ -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
272+ reqs = attachPromptlyDynWith
273+ (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
274+
275+ performEvent_ $ ffor (reqs) $
276+ liftJSM . mapM_ (optsDebugRequests opts $)
277+
253278 resps <- performSomeRequestsAsync reqs
254279 return $ getCompose <$> resps
255280
@@ -289,23 +314,23 @@ performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb ->
289314
290315
291316
292−-- | This function actually performs the request.
293−performRequest :: forall t m tag .(SupportsServantReflex t m)
294− => Text
295− -> (Req t)
296− -> Dynamic t BaseUrl
297− -> Event t tag
298− -> m (Event t (tag, XhrResponse), Event t (tag, Text))
299−performRequest reqMeth req reqHost trigger = do
317+-- -- | This function performs the request
318+-- performRequest :: forall t m tag .(SupportsServantReflex t m)
319+-- => Text
320+-- -> Req t
321+-- -> Dynamic t BaseUrl
322+-- -> Event t tag
323+-- -> m (Event t (tag, XhrResponse), Event t (tag, Text))
324+-- performRequest reqMeth req reqHost trigger = do
300325
301− let xhrReq = reqToReflexRequest reqMeth reqHost req
302− let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger
303− okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) e) reqs
304− badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) e) reqs
326+-- let xhrReq = reqToReflexRequest reqMeth reqHost req
327+-- let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger
328+-- okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) (snd e)) reqs
329+-- badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) (snd e)) reqs
305330
306− resps <- performRequestsAsync okReqs
331+-- resps <- performRequestsAsync okReqs
307332
308− return (resps, badReqs)
333+-- return (resps, badReqs)
309334
310335
311336type XhrPayload = T.Text
@@ -313,41 +338,6 @@ bytesToPayload :: BL.ByteString -> XhrPayload
313338bytesToPayload = TE.decodeUtf8 . BL.toStrict
314339
315340
316−-- performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)
317−-- => Text
318−-- -> Req t
319−-- -> Dynamic t BaseUrl
320−-- -> Event t tag -> m (Event t (ReqResult tag NoContent))
321−-- performRequestNoBody reqMeth req reqHost trigger = do
322−-- (resp, badReq) <- performRequest reqMeth req reqHost trigger
323−-- let decodeResp = const $ Right NoContent
324−-- return $ leftmost [ fmap (evalResponse decodeResp) resp
325−-- , fmap (uncurry RequestFailure) badReq
326−-- ]
327−
328−
329−-- performRequestCT
330−-- :: (SupportsServantReflex t m,
331−-- MimeUnrender ct a)
332−-- => Proxy ct
333−-- -> Text
334−-- -> Req t
335−-- -> Dynamic t BaseUrl
336−-- -> Event t tag
337−-- -> m (Event t (ReqResult tag a))
338−-- performRequestCT ct reqMeth req reqHost trigger = do
339−-- (resp, badReq) <- performRequest reqMeth req reqHost trigger
340−-- let decodeResp x = first T.pack .
341−-- mimeUnrender ct .
342−-- BL.fromStrict .
343−-- TE.encodeUtf8 =<< note "No body text"
344−-- (_xhrResponse_responseText x)
345−
346−-- return $ leftmost [fmap (evalResponse decodeResp) resp
347−-- , fmap (uncurry RequestFailure) badReq
348−-- ]
349−
350−
351341performRequestsCT
352342 :: (SupportsServantReflex t m,
353343 MimeUnrender ct a, Traversable f)
@@ -355,10 +345,11 @@ performRequestsCT
355345 -> Text
356346 -> Dynamic t (f (Req t))
357347 -> Dynamic t BaseUrl
348+ -> ClientOptions
358349 -> Event t tag
359350 -> m (Event t (f (ReqResult tag a)))
360−performRequestsCT ct reqMeth reqs reqHost trigger = do
361− resps <- performRequests reqMeth reqs reqHost trigger
351+performRequestsCT ct reqMeth reqs reqHost opts trigger = do
352+ resps <- performRequests reqMeth reqs reqHost opts trigger
362353 let decodeResp x = first T.pack .
363354 mimeUnrender ct .
364355 BL.fromStrict .
@@ -378,10 +369,11 @@ performRequestsNoBody
378369 => Text
379370 -> Dynamic t (f (Req t))
380371 -> Dynamic t BaseUrl
372+ -> ClientOptions
381373 -> Event t tag
382374 -> m (Event t (f (ReqResult tag NoContent)))
383−performRequestsNoBody reqMeth reqs reqHost trigger = do
384− resps <- performRequests reqMeth reqs reqHost trigger
375+performRequestsNoBody reqMeth reqs reqHost opts trigger = do
376+ resps <- performRequests reqMeth reqs reqHost opts trigger
385377 let decodeResp = const $ Right NoContent
386378 return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
387379 Left e -> RequestFailure tag e
@@ -408,8 +400,6 @@ evalResponse decode (tag, xhr) =
408400 in respPayld
409401
410402
411−
412−
413403note :: e -> Maybe a -> Either e a
414404note e = maybe (Left e) Right
415405
src/Servant/Reflex.hs+56−36
@@ -24,9 +24,12 @@
2424-- API.
2525module Servant.Reflex
2626 ( client
27+ , clientWithOpts
28+ , clientWithRoute
2729 , BuildHeaderKeysTo(..)
2830 , toHeaders
29− , HasClient(..)
31+ , HasClient
32+ , Client
3033 , module Servant.Common.Req
3134 , module Servant.Common.BaseUrl
3235 ) where
@@ -65,7 +68,9 @@ import Reflex.Dom (Dynamic, Event, Reflex,
6568import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
6669 showBaseUrl,
6770 SupportsServantReflex)
68−import Servant.Common.Req (Req, ReqResult(..), QParam(..),
71+import Servant.Common.Req (ClientOptions(..),
72+ defaultClientOptions,
73+ Req, ReqResult(..), QParam(..),
6974 QueryPart(..), addHeader, authData,
7075 defReq, evalResponse, prependToPathParts,
7176 -- performRequestCT,
@@ -75,7 +80,8 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),
7580 performSomeRequestsAsync,
7681 qParamToQueryPart, reqBody,
7782 reqSuccess, reqFailure,
78− reqMethod, respHeaders, response,
83+ reqMethod, respHeaders,
84+ response,
7985 reqTag,
8086 qParams)
8187
@@ -95,9 +101,24 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),
95101-- -> m (Event t (l, ReqResult Book)))
96102-- > (getAllBooks :<|> postNewBook) = client myApi host
97103-- > where host = constDyn $ BaseUrl Http "localhost" 8080
98−client :: (HasClient t m layout tag)
99− => Proxy layout -> Proxy m -> Proxy tag -> Dynamic t BaseUrl -> Client t m layout tag
100−client p q t baseurl = clientWithRoute p q t defReq baseurl
104+client
105+ :: (HasClient t m layout tag)
106+ => Proxy layout
107+ -> Proxy m
108+ -> Proxy tag
109+ -> Dynamic t BaseUrl
110+ -> Client t m layout tag
111+client p q t baseurl = clientWithRoute p q t defReq baseurl defaultClientOptions
112+
113+clientWithOpts
114+ :: (HasClient t m layout tag)
115+ => Proxy layout
116+ -> Proxy m
117+ -> Proxy tag
118+ -> Dynamic t BaseUrl
119+ -> ClientOptions
120+ -> Client t m layout tag
121+clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
101122
102123
103124-- | This class lets us define how each API combinator
@@ -105,15 +126,15 @@ client p q t baseurl = clientWithRoute p q t defReq baseurl
105126-- an internal class, you can just use 'client'.
106127class HasClient t m layout (tag :: *) where
107128 type Client t m layout tag :: *
108− clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> Client t m layout tag
129+ clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag
109130
110131
111132instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
112133 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
113134
114− clientWithRoute Proxy q pTag req baseurl =
115− clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>
116− clientWithRoute (Proxy :: Proxy b) q pTag req baseurl
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
117138
118139
119140-- Capture. Example:
@@ -134,11 +155,11 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
134155 type Client t m (Capture capture a :> sublayout) tag =
135156 Dynamic t (Either Text a) -> Client t m sublayout tag
136157
137− clientWithRoute Proxy q t req baseurl val =
158+ clientWithRoute Proxy q t req baseurl opts val =
138159 clientWithRoute (Proxy :: Proxy sublayout)
139160 q t
140161 (prependToPathParts p req)
141− baseurl
162+ baseurl opts
142163 where p = (fmap . fmap) (toUrlPiece) val
143164
144165
@@ -151,9 +172,8 @@ instance {-# OVERLAPPABLE #-}
151172 Event t tag -> m (Event t (ReqResult tag a))
152173 -- TODO how to access input types here?
153174 -- ExceptT ServantError IO a
154− clientWithRoute Proxy _ _ req baseurl trigs =
155− -- performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs
156− fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl trigs
175+ clientWithRoute Proxy _ _ req baseurl opts trigs =
176+ fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
157177 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
158178 req' = req { reqMethod = method }
159179
@@ -166,8 +186,8 @@ instance {-# OVERLAPPING #-}
166186 Event t tag -> m (Event t (ReqResult tag NoContent))
167187 -- TODO: how to access input types here?
168188 -- ExceptT ServantError IO NoContent
169− clientWithRoute Proxy _ _ req baseurl =
170− (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl
189+ clientWithRoute Proxy _ _ req baseurl opts =
190+ (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl opts
171191 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
172192
173193
@@ -203,9 +223,9 @@ instance {-# OVERLAPPABLE #-}
203223 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
204224 type Client t m (Verb method status cts' (Headers ls a)) tag =
205225 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
206− clientWithRoute Proxy _ _ req baseurl trigs = do
226+ clientWithRoute Proxy _ _ req baseurl opts trigs = do
207227 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
208− resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl trigs
228+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
209229 return $ toHeaders <$> resp
210230 where req' = req { respHeaders =
211231 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
@@ -219,9 +239,9 @@ instance {-# OVERLAPPABLE #-}
219239 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
220240 type Client t m (Verb method status cts (Headers ls NoContent)) tag
221241 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
222− clientWithRoute Proxy _ _ req baseurl trigs = do
242+ clientWithRoute Proxy _ _ req baseurl opts trigs = do
223243 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
224− resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl trigs
244+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
225245 return $ toHeaders <$> resp
226246 where req' = req {respHeaders =
227247 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
@@ -249,11 +269,11 @@ instance (KnownSymbol sym, ToHttpApiData a,
249269 type Client t m (Header sym a :> sublayout) tag =
250270 Dynamic t (Either Text a) -> Client t m sublayout tag
251271
252− clientWithRoute Proxy q t req baseurl eVal =
272+ clientWithRoute Proxy q t req baseurl opts eVal =
253273 clientWithRoute (Proxy :: Proxy sublayout)
254274 q t
255275 (Servant.Common.Req.addHeader hname eVal req)
256− baseurl
276+ baseurl opts
257277 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
258278
259279
@@ -304,9 +324,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
304324 Dynamic t (QParam a) -> Client t m sublayout tag
305325
306326 -- if mparam = Nothing, we don't add it to the query string
307− clientWithRoute Proxy q t req baseurl mparam =
327+ clientWithRoute Proxy q t req baseurl opts mparam =
308328 clientWithRoute (Proxy :: Proxy sublayout) q t
309− (req {qParams = paramPair : qParams req}) baseurl
329+ (req {qParams = paramPair : qParams req}) baseurl opts
310330
311331 where pname = symbolVal (Proxy :: Proxy sym)
312332 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -350,8 +370,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
350370 type Client t m (QueryParams sym a :> sublayout) tag =
351371 Dynamic t [a] -> Client t m sublayout tag
352372
353− clientWithRoute Proxy q t req baseurl paramlist =
354− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
373+ clientWithRoute Proxy q t req baseurl opts paramlist =
374+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
355375
356376 where req' = req { qParams = (T.pack pname, params') : qParams req }
357377 pname = symbolVal (Proxy :: Proxy sym)
@@ -390,8 +410,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
390410 type Client t m (QueryFlag sym :> sublayout) tag =
391411 Dynamic t Bool -> Client t m sublayout tag
392412
393− clientWithRoute Proxy q t req baseurl flag =
394− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
413+ clientWithRoute Proxy q t req baseurl opts flag =
414+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
395415
396416 where req' = req { qParams = thisPair : qParams req }
397417 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -405,7 +425,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
405425 -> Event t tag
406426 -> m (Event t (ReqResult tag ()))
407427
408− clientWithRoute _ _ _ _ baseurl xhrs triggers = do
428+ clientWithRoute _ _ _ _ baseurl _ xhrs triggers = do
409429
410430 let xhrs' = liftA2 (\x path -> case x of
411431 Left e -> Left e
@@ -447,8 +467,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
447467 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
448468 Dynamic t (Either Text a) -> Client t m sublayout tag
449469
450− clientWithRoute Proxy q t req baseurl body =
451− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
470+ clientWithRoute Proxy q t req baseurl opts body =
471+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
452472 where req' = req { reqBody = bodyBytesCT }
453473 ctProxy = Proxy :: Proxy ct
454474 ctString = T.pack $ show $ contentType ctProxy
@@ -462,9 +482,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
462482instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
463483 type Client t m (path :> sublayout) tag = Client t m sublayout tag
464484
465− clientWithRoute Proxy q t req baseurl =
485+ clientWithRoute Proxy q t req baseurl opts =
466486 clientWithRoute (Proxy :: Proxy sublayout) q t
467− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl
487+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts
468488
469489 where p = symbolVal (Proxy :: Proxy path)
470490
@@ -497,8 +517,8 @@ instance (HasClient t m api tag, Reflex t)
497517 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
498518 -> Client t m api tag
499519
500− clientWithRoute Proxy q t req baseurl authdata =
501− clientWithRoute (Proxy :: Proxy api) q t req' baseurl
520+ clientWithRoute Proxy q t req baseurl opts authdata =
521+ clientWithRoute (Proxy :: Proxy api) q t req' baseurl opts
502522 where
503523 req' = req { authData = Just authdata }
504524
src/Servant/Reflex/Multi.hs+43−30
@@ -16,13 +16,13 @@
1616module Servant.Reflex.Multi (
1717 -- * Compute servant client functions
1818 clientA
19+ , clientWithOptsA
1920 , BaseUrl(..)
2021 , Scheme(..)
2122
2223 -- * Build QueryParam arguments
2324 , QParam(..)
2425
25−
2626 -- * Access response data
2727 , ReqResult(..)
2828 , reqSuccess
@@ -59,9 +59,12 @@ import Reflex.Dom (Dynamic, Event, Reflex,
5959------------------------------------------------------------------------------
6060import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
6161 SupportsServantReflex)
62−import Servant.Common.Req (QParam (..), QueryPart (..), Req,
62+import Servant.Common.Req (ClientOptions,
63+ QParam (..), QueryPart (..), Req,
6364 ReqResult (..), addHeader, authData,
64− defReq, performRequestsCT,
65+ defReq,
66+ defaultClientOptions,
67+ performRequestsCT,
6568 performRequestsNoBody,
6669 performSomeRequestsAsync,
6770 prependToPathParts, qParamToQueryPart,
@@ -77,14 +80,24 @@ clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
7780 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
7881clientA p q f tag baseurl =
7982 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
83+ defaultClientOptions
84+
8085
86+-- | A version of @client@ that sets the withCredentials flag
87+-- on requests. Use this function for clients of CORS API's
88+clientWithOptsA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
89+ => Proxy layout -> Proxy m -> Proxy f -> Proxy tag
90+ -> Dynamic t BaseUrl -> ClientOptions -> ClientMulti t m layout f tag
91+clientWithOptsA p q f tag baseurl opts =
92+ clientWithRouteMulti p q f tag
93+ (constDyn (pure defReq)) baseurl opts
8194
8295------------------------------------------------------------------------------
8396class HasClientMulti t m layout f (tag :: *) where
8497 type ClientMulti t m layout f tag :: *
8598 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
8699 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
87− -> ClientMulti t m layout f tag
100+ -> ClientOptions -> ClientMulti t m layout f tag
88101
89102
90103------------------------------------------------------------------------------
@@ -92,9 +105,9 @@ instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>
92105 HasClientMulti t m (a :<|> b) f tag where
93106 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>
94107 ClientMulti t m b f tag
95− clientWithRouteMulti Proxy q f tag reqs baseurl =
96− clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl :<|>
97− clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl
108+ clientWithRouteMulti Proxy q f tag reqs baseurl opts =
109+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>
110+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts
98111
99112
100113------------------------------------------------------------------------------
@@ -107,8 +120,8 @@ instance (SupportsServantReflex t m,
107120 type ClientMulti t m (Capture capture a :> sublayout) f tag =
108121 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
109122
110− clientWithRouteMulti _ q f tag reqs baseurl vals =
111− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
123+ clientWithRouteMulti _ q f tag reqs baseurl opts vals =
124+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
112125 where
113126 reqs' = (prependToPathParts <$> ps <*>) <$> reqs
114127 ps = (fmap . fmap . fmap) toUrlPiece vals
@@ -128,8 +141,8 @@ instance {-# OVERLAPPABLE #-}
128141 type ClientMulti t m (Verb method status cts' a) f tag =
129142 Event t tag -> m (Event t (f (ReqResult tag a)))
130143
131− clientWithRouteMulti _ _ _ _ reqs baseurl =
132− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
144+ clientWithRouteMulti _ _ _ _ reqs baseurl opts =
145+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts
133146 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
134147 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
135148
@@ -143,8 +156,8 @@ instance {-# OVERLAPPING #-}
143156 Event t tag -> m (Event t (f (ReqResult tag NoContent)))
144157 -- TODO: how to access input types here?
145158 -- ExceptT ServantError IO NoContent
146− clientWithRouteMulti Proxy _ _ _ req baseurl =
147− performRequestsNoBody method req baseurl
159+ clientWithRouteMulti Proxy _ _ _ req baseurl opts =
160+ performRequestsNoBody method req baseurl opts
148161 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
149162
150163
@@ -158,9 +171,9 @@ instance {-# OVERLAPPABLE #-}
158171 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where
159172 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =
160173 Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))
161− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
174+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
162175 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
163− resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl triggers :: m (Event t (f (ReqResult tag a)))
176+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))
164177 return $ fmap toHeaders <$> resp
165178 where
166179 reqs' = fmap (\r ->
@@ -181,9 +194,9 @@ instance {-# OVERLAPPABLE #-}
181194 cts (Headers ls NoContent)) f tag where
182195 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag
183196 = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))
184− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
197+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
185198 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
186− resp <- performRequestsNoBody method reqs' baseurl triggers
199+ resp <- performRequestsNoBody method reqs' baseurl opts triggers
187200 return $ fmap toHeaders <$> resp
188201 where reqs' = fmap (\req ->
189202 req {respHeaders = OnlyHeaders (Set.fromList
@@ -203,11 +216,11 @@ instance (KnownSymbol sym,
203216 type ClientMulti t m (Header sym a :> sublayout) f tag =
204217 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
205218
206− clientWithRouteMulti Proxy f q tag reqs baseurl eVals =
219+ clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =
207220 clientWithRouteMulti (Proxy :: Proxy sublayout) f
208221 q tag
209222 reqs'
210− baseurl
223+ baseurl opts
211224 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
212225 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
213226 <$> eVals <*>) <$> reqs
@@ -237,9 +250,9 @@ instance (KnownSymbol sym,
237250
238251 -- if mparam = Nothing, we don't add it to the query string
239252 -- TODO: Check the above comment
240− clientWithRouteMulti Proxy q f tag reqs baseurl mparams =
253+ clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =
241254 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
242− reqs' baseurl
255+ reqs' baseurl opts
243256
244257 where pname = symbolVal (Proxy :: Proxy sym)
245258 p prm = QueryPartParam $ fmap qParamToQueryPart prm
@@ -260,8 +273,8 @@ instance (KnownSymbol sym,
260273 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
261274 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
262275
263− clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =
264− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
276+ clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =
277+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
265278
266279 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }
267280 pname = symbolVal (Proxy :: Proxy sym)
@@ -279,8 +292,8 @@ instance (KnownSymbol sym,
279292 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
280293 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
281294
282− clientWithRouteMulti Proxy q f' tag reqs baseurl flags =
283− clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl
295+ clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =
296+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts
284297
285298 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
286299 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
@@ -294,7 +307,7 @@ instance (SupportsServantReflex t m,
294307 -> Event t tag
295308 -> m (Event t (f (ReqResult tag ())))
296309
297− clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do
310+ clientWithRouteMulti _ _ _ _ _ _ _ rawReqs triggers = do
298311 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
299312 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
300313 resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync rawReqs''
@@ -313,8 +326,8 @@ instance (MimeRender ct a,
313326 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
314327 Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
315328
316− clientWithRouteMulti Proxy q f tag reqs baseurl bodies =
317− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
329+ clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
330+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
318331 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
319332 ctProxy = Proxy :: Proxy ct
320333 ctString = T.pack $ show $ contentType ctProxy
@@ -365,8 +378,8 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
365378 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))
366379 -> ClientMulti t m api f tag
367380
368− clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =
369− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl
381+ clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =
382+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts
370383 where
371384 req' a r = r { authData = Just (constDyn a) }
372385 reqs' = liftA2 req' <$> authdatas <*> reqs