git.iko.soy/typeable/servant-reflex
on master help sign in
Merge pull request #47 from imalsogreg/set-withCredentials

Add ClientOptions to support withCredentials and request debugging Fix path part encoding bug

commit838a97fb57c5932c136f59618ffd52368d8ec4a2 authorGreg Hale <ImAlsoGreg@gmail.com> dateMon 25 Sep 2017, 16:47 (9 years ago) parent810a32b001d57e
6 files changed+174−150
compare with master
unifiedsplit
deps/reflex-platform+1−1 exec/Example.hs+4−1 servant-reflex.cabal+2−2 src/Servant/Common/Req.hs+62−78 src/Servant/Reflex.hs+58−37 src/Servant/Reflex/Multi.hs+47−31
deps/reflex-platform+1−1

Submodule changed.

exec/Example.hs+4−1
@@ -96,9 +96,12 @@ run = mdo
9696 el "br" (return ())
9797
9898 -- Name the computed API client functions
99+ let tweakRequest = ClientOptions $ \r -> do
100+ putStrLn ("Got req: " ++ show r)
101+ return $ r & withCredentials .~ True
99102 let (getUnit :<|> getInt :<|> sayhi :<|> dbl
100103 :<|> multi :<|> qna :<|> secret :<|> doRaw) =
101− client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url
104+ clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest
102105
103106 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
104107
servant-reflex.cabal+2−2
@@ -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
@@ -33,7 +33,7 @@ library
3333 data-default >= 0.5 && < 0.8,
3434 exceptions >= 0.8 && < 0.9,
3535 ghcjs-dom >= 0.2 && < 0.10,
36− http-api-data >= 0.2 && < 0.4,
36+ http-api-data >= 0.3.6 && < 0.4,
3737 http-media >= 0.6 && < 0.7,
3838 jsaddle >= 0.8 && < 0.10,
3939 mtl >= 2.2.1 && < 2.3,
src/Servant/Common/Req.hs+62−78
@@ -4,17 +4,19 @@
44{-# LANGUAGE GADTs #-}
55{-# LANGUAGE OverloadedStrings #-}
66{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE RankNTypes #-}
78{-# LANGUAGE ScopedTypeVariables #-}
89{-# LANGUAGE TupleSections #-}
910
1011module Servant.Common.Req where
1112
1213-------------------------------------------------------------------------------
13−import Control.Concurrent
1414import Control.Applicative (liftA2, liftA3)
15+import Control.Concurrent
1516import Control.Monad (join)
1617import Control.Monad.IO.Class (MonadIO, liftIO)
1718import Data.Bifunctor (first)
19+import qualified Data.ByteString.Builder as Builder
1820import qualified Data.ByteString.Lazy.Char8 as BL
1921import qualified Data.Map as Map
2022import Data.Maybe (catMaybes, fromMaybe)
@@ -47,6 +49,23 @@ data ReqResult tag a
4749 -- ^ A failure to construct the request tagged with 'tag' at trigger time
4850 deriving (Functor)
4951
52+data ClientOptions = ClientOptions
53+ { optsRequestFixup :: forall a. Show a => XhrRequest a -> IO (XhrRequest a)
54+ -- ^ Aribtrarily modify requests just before they are sent.
55+ -- Warning: This escape hatch opens the possibility for your
56+ -- requests to diverge from what the server expects, when the
57+ -- server is also derived from a servant API
58+ }
59+
60+defaultClientOptions :: ClientOptions
61+defaultClientOptions = ClientOptions { optsRequestFixup = return }
62+
63+-- withCredentials :: Lens' (XhrRequest a) Bool
64+withCredentials :: (Show a, Functor f) => (Bool -> f Bool) -> XhrRequest a -> f (XhrRequest a)
65+withCredentials inj r@(XhrRequest _ _ cfg) =
66+ let cfg' = (\b -> cfg { _xhrRequestConfig_withCredentials = b}) <$>
67+ inj (_xhrRequestConfig_withCredentials cfg)
68+ in (\c' -> r {_xhrRequest_config = c' }) <$> cfg'
5069
5170------------------------------------------------------------------------------
5271-- | Simple filter/accessor for successful responses, when you want to
@@ -138,7 +157,7 @@ reqToReflexRequest
138157 => Text
139158 -> Dynamic t BaseUrl
140159 -> Req t
141− -> (Dynamic t (Either Text (XhrRequest XhrPayload)))
160+ -> Dynamic t (Either Text (XhrRequest XhrPayload))
142161reqToReflexRequest reqMeth reqHost req =
143162 let t :: Dynamic t [Either Text Text]
144163 t = sequence $ reverse $ reqPathParts req
@@ -150,7 +169,9 @@ reqToReflexRequest reqMeth reqHost req =
150169 urlParts = fmap sequence t
151170
152171 urlPath :: Dynamic t (Either Text Text)
153− urlPath = (fmap.fmap) (T.intercalate "/") urlParts
172+ urlPath = (fmap.fmap)
173+ (T.intercalate "/" . fmap (builderToText . toEncodedUrlPiece))
174+ urlParts
154175
155176 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
156177 queryPartString (pName, qp) = case qp of
@@ -196,7 +217,7 @@ reqToReflexRequest reqMeth reqHost req =
196217 Right $ XhrRequestConfig
197218 { _xhrRequestConfig_sendData = bytesToPayload bBytes
198219 , _xhrRequestConfig_headers =
199− Map.insert "Content-Type" bCT (Map.fromList hs)
220+ Map.insert "Content-Type" bCT (Map.fromList hs)
200221 , _xhrRequestConfig_user = Nothing
201222 , _xhrRequestConfig_password = Nothing
202223 , _xhrRequestConfig_responseType = Nothing
@@ -239,21 +260,29 @@ reqToReflexRequest reqMeth reqHost req =
239260displayHttpRequest :: Text -> Text
240261displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
241262
242−-- | This function actually performs the request.
263+-- | This function performs the request
243264performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
244265 => Text
245266 -> Dynamic t (f (Req t))
246267 -> Dynamic t BaseUrl
268+ -> ClientOptions
247269 -> Event t tag
248270 -> 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
253− resps <- performSomeRequestsAsync reqs
271+performRequests reqMeth rs reqHost opts trigger = do
272+ let xhrReqs =
273+ join $ (\(fxhr :: f (Req t)) -> sequence $
274+ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
275+
276+ -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
277+ reqs = attachPromptlyDynWith
278+ (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
279+
280+ resps <- performSomeRequestsAsync opts reqs
254281 return $ getCompose <$> resps
255282
256−-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.
283+-- | Issues a collection of requests when the supplied Event fires.
284+-- When ALL requests from a given firing complete, the results are
285+-- collected and returned via the return Event.
257286performSomeRequestsAsync
258287 :: (MonadIO (Performable m),
259288 MonadJSM (Performable m),
@@ -261,20 +290,25 @@ performSomeRequestsAsync
261290 PerformEvent t m,
262291 TriggerEvent t m,
263292 Traversable f,
264− IsXhrPayload a)
265− => Event t (f (Either Text (XhrRequest a)))
293+ IsXhrPayload a,
294+ Show a
295+ )
296+ => ClientOptions
297+ -> Event t (f (Either Text (XhrRequest a)))
266298 -> m (Event t (f (Either Text XhrResponse)))
267−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return
299+performSomeRequestsAsync opts =
300+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
268301
269302
270303------------------------------------------------------------------------------
271304-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
272305-- that accepts 'f (Either e (XhrRequestb))' events
273306performSomeRequestsAsync'
274− :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
275− => (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
307+ :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
308+ => ClientOptions
309+ -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
276310 -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
277−performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
311+performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
278312 rs <- hrs
279313 resps <- forM rs $ \r -> case r of
280314 Left e -> do
@@ -282,72 +316,19 @@ performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb ->
282316 return resp
283317 Right r' -> do
284318 resp <- liftIO newEmptyMVar
285− _ <- newXhr r' $ liftIO . putMVar resp . Right
319+ r'' <- liftIO $ (optsRequestFixup opts) r'
320+ _ <- newXhr r'' $ liftIO . putMVar resp . Right
286321 return resp
287322 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
288323 return ()
289324
290325
291326
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
300−
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
305−
306− resps <- performRequestsAsync okReqs
307−
308− return (resps, badReqs)
309−
310−
311327type XhrPayload = T.Text
312328bytesToPayload :: BL.ByteString -> XhrPayload
313329bytesToPayload = TE.decodeUtf8 . BL.toStrict
314330
315331
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−
351332performRequestsCT
352333 :: (SupportsServantReflex t m,
353334 MimeUnrender ct a, Traversable f)
@@ -355,10 +336,11 @@ performRequestsCT
355336 -> Text
356337 -> Dynamic t (f (Req t))
357338 -> Dynamic t BaseUrl
339+ -> ClientOptions
358340 -> Event t tag
359341 -> m (Event t (f (ReqResult tag a)))
360−performRequestsCT ct reqMeth reqs reqHost trigger = do
361− resps <- performRequests reqMeth reqs reqHost trigger
342+performRequestsCT ct reqMeth reqs reqHost opts trigger = do
343+ resps <- performRequests reqMeth reqs reqHost opts trigger
362344 let decodeResp x = first T.pack .
363345 mimeUnrender ct .
364346 BL.fromStrict .
@@ -378,10 +360,11 @@ performRequestsNoBody
378360 => Text
379361 -> Dynamic t (f (Req t))
380362 -> Dynamic t BaseUrl
363+ -> ClientOptions
381364 -> Event t tag
382365 -> m (Event t (f (ReqResult tag NoContent)))
383−performRequestsNoBody reqMeth reqs reqHost trigger = do
384− resps <- performRequests reqMeth reqs reqHost trigger
366+performRequestsNoBody reqMeth reqs reqHost opts trigger = do
367+ resps <- performRequests reqMeth reqs reqHost opts trigger
385368 let decodeResp = const $ Right NoContent
386369 return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
387370 Left e -> RequestFailure tag e
@@ -408,11 +391,12 @@ evalResponse decode (tag, xhr) =
408391 in respPayld
409392
410393
411−
412−
413394note :: e -> Maybe a -> Either e a
414395note e = maybe (Left e) Right
415396
416397fmapL :: (e -> e') -> Either e a -> Either e' a
417398fmapL _ (Right a) = Right a
418399fmapL f (Left e) = Left (f e)
400+
401+builderToText :: Builder.Builder -> T.Text
402+builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
src/Servant/Reflex.hs+58−37
@@ -24,9 +24,13 @@
2424-- API.
2525module Servant.Reflex
2626 ( client
27+ , clientWithOpts
28+ , clientWithRoute
2729 , BuildHeaderKeysTo(..)
2830 , toHeaders
29− , HasClient(..)
31+ , HasClient
32+ , Client
33+ , withCredentials
3034 , module Servant.Common.Req
3135 , module Servant.Common.BaseUrl
3236 ) where
@@ -65,7 +69,9 @@ import Reflex.Dom (Dynamic, Event, Reflex,
6569import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
6670 showBaseUrl,
6771 SupportsServantReflex)
68−import Servant.Common.Req (Req, ReqResult(..), QParam(..),
72+import Servant.Common.Req (ClientOptions(..),
73+ defaultClientOptions,
74+ Req, ReqResult(..), QParam(..),
6975 QueryPart(..), addHeader, authData,
7076 defReq, evalResponse, prependToPathParts,
7177 -- performRequestCT,
@@ -75,9 +81,10 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),
7581 performSomeRequestsAsync,
7682 qParamToQueryPart, reqBody,
7783 reqSuccess, reqFailure,
78− reqMethod, respHeaders, response,
84+ reqMethod, respHeaders,
85+ response,
7986 reqTag,
80− qParams)
87+ qParams, withCredentials)
8188
8289
8390-- * Accessing APIs as a Client
@@ -95,9 +102,24 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),
95102-- -> m (Event t (l, ReqResult Book)))
96103-- > (getAllBooks :<|> postNewBook) = client myApi host
97104-- > 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
105+client
106+ :: (HasClient t m layout tag)
107+ => Proxy layout
108+ -> Proxy m
109+ -> Proxy tag
110+ -> Dynamic t BaseUrl
111+ -> Client t m layout tag
112+client p q t baseurl = clientWithRoute p q t defReq baseurl defaultClientOptions
113+
114+clientWithOpts
115+ :: (HasClient t m layout tag)
116+ => Proxy layout
117+ -> Proxy m
118+ -> Proxy tag
119+ -> Dynamic t BaseUrl
120+ -> ClientOptions
121+ -> Client t m layout tag
122+clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
101123
102124
103125-- | This class lets us define how each API combinator
@@ -105,15 +127,15 @@ client p q t baseurl = clientWithRoute p q t defReq baseurl
105127-- an internal class, you can just use 'client'.
106128class HasClient t m layout (tag :: *) where
107129 type Client t m layout tag :: *
108− clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> Client t m layout tag
130+ clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag
109131
110132
111133instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
112134 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
113135
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
136+ clientWithRoute Proxy q pTag req baseurl opts =
137+ clientWithRoute (Proxy :: Proxy a) q pTag req baseurl opts :<|>
138+ clientWithRoute (Proxy :: Proxy b) q pTag req baseurl opts
117139
118140
119141-- Capture. Example:
@@ -134,11 +156,11 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
134156 type Client t m (Capture capture a :> sublayout) tag =
135157 Dynamic t (Either Text a) -> Client t m sublayout tag
136158
137− clientWithRoute Proxy q t req baseurl val =
159+ clientWithRoute Proxy q t req baseurl opts val =
138160 clientWithRoute (Proxy :: Proxy sublayout)
139161 q t
140162 (prependToPathParts p req)
141− baseurl
163+ baseurl opts
142164 where p = (fmap . fmap) (toUrlPiece) val
143165
144166
@@ -151,9 +173,8 @@ instance {-# OVERLAPPABLE #-}
151173 Event t tag -> m (Event t (ReqResult tag a))
152174 -- TODO how to access input types here?
153175 -- 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
176+ clientWithRoute Proxy _ _ req baseurl opts trigs =
177+ fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
157178 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
158179 req' = req { reqMethod = method }
159180
@@ -166,8 +187,8 @@ instance {-# OVERLAPPING #-}
166187 Event t tag -> m (Event t (ReqResult tag NoContent))
167188 -- TODO: how to access input types here?
168189 -- ExceptT ServantError IO NoContent
169− clientWithRoute Proxy _ _ req baseurl =
170− (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl
190+ clientWithRoute Proxy _ _ req baseurl opts =
191+ (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl opts
171192 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
172193
173194
@@ -203,9 +224,9 @@ instance {-# OVERLAPPABLE #-}
203224 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
204225 type Client t m (Verb method status cts' (Headers ls a)) tag =
205226 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
206− clientWithRoute Proxy _ _ req baseurl trigs = do
227+ clientWithRoute Proxy _ _ req baseurl opts trigs = do
207228 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
208− resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl trigs
229+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
209230 return $ toHeaders <$> resp
210231 where req' = req { respHeaders =
211232 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
@@ -219,9 +240,9 @@ instance {-# OVERLAPPABLE #-}
219240 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
220241 type Client t m (Verb method status cts (Headers ls NoContent)) tag
221242 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
222− clientWithRoute Proxy _ _ req baseurl trigs = do
243+ clientWithRoute Proxy _ _ req baseurl opts trigs = do
223244 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
224− resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl trigs
245+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
225246 return $ toHeaders <$> resp
226247 where req' = req {respHeaders =
227248 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
@@ -249,11 +270,11 @@ instance (KnownSymbol sym, ToHttpApiData a,
249270 type Client t m (Header sym a :> sublayout) tag =
250271 Dynamic t (Either Text a) -> Client t m sublayout tag
251272
252− clientWithRoute Proxy q t req baseurl eVal =
273+ clientWithRoute Proxy q t req baseurl opts eVal =
253274 clientWithRoute (Proxy :: Proxy sublayout)
254275 q t
255276 (Servant.Common.Req.addHeader hname eVal req)
256− baseurl
277+ baseurl opts
257278 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
258279
259280
@@ -304,9 +325,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
304325 Dynamic t (QParam a) -> Client t m sublayout tag
305326
306327 -- if mparam = Nothing, we don't add it to the query string
307− clientWithRoute Proxy q t req baseurl mparam =
328+ clientWithRoute Proxy q t req baseurl opts mparam =
308329 clientWithRoute (Proxy :: Proxy sublayout) q t
309− (req {qParams = paramPair : qParams req}) baseurl
330+ (req {qParams = paramPair : qParams req}) baseurl opts
310331
311332 where pname = symbolVal (Proxy :: Proxy sym)
312333 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -350,8 +371,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
350371 type Client t m (QueryParams sym a :> sublayout) tag =
351372 Dynamic t [a] -> Client t m sublayout tag
352373
353− clientWithRoute Proxy q t req baseurl paramlist =
354− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
374+ clientWithRoute Proxy q t req baseurl opts paramlist =
375+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
355376
356377 where req' = req { qParams = (T.pack pname, params') : qParams req }
357378 pname = symbolVal (Proxy :: Proxy sym)
@@ -390,8 +411,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
390411 type Client t m (QueryFlag sym :> sublayout) tag =
391412 Dynamic t Bool -> Client t m sublayout tag
392413
393− clientWithRoute Proxy q t req baseurl flag =
394− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
414+ clientWithRoute Proxy q t req baseurl opts flag =
415+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
395416
396417 where req' = req { qParams = thisPair : qParams req }
397418 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -405,7 +426,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
405426 -> Event t tag
406427 -> m (Event t (ReqResult tag ()))
407428
408− clientWithRoute _ _ _ _ baseurl xhrs triggers = do
429+ clientWithRoute _ _ _ _ baseurl _ xhrs triggers = do
409430
410431 let xhrs' = liftA2 (\x path -> case x of
411432 Left e -> Left e
@@ -447,8 +468,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
447468 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
448469 Dynamic t (Either Text a) -> Client t m sublayout tag
449470
450− clientWithRoute Proxy q t req baseurl body =
451− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
471+ clientWithRoute Proxy q t req baseurl opts body =
472+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
452473 where req' = req { reqBody = bodyBytesCT }
453474 ctProxy = Proxy :: Proxy ct
454475 ctString = T.pack $ show $ contentType ctProxy
@@ -462,9 +483,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
462483instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
463484 type Client t m (path :> sublayout) tag = Client t m sublayout tag
464485
465− clientWithRoute Proxy q t req baseurl =
486+ clientWithRoute Proxy q t req baseurl opts =
466487 clientWithRoute (Proxy :: Proxy sublayout) q t
467− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl
488+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts
468489
469490 where p = symbolVal (Proxy :: Proxy path)
470491
@@ -497,8 +518,8 @@ instance (HasClient t m api tag, Reflex t)
497518 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
498519 -> Client t m api tag
499520
500− clientWithRoute Proxy q t req baseurl authdata =
501− clientWithRoute (Proxy :: Proxy api) q t req' baseurl
521+ clientWithRoute Proxy q t req baseurl opts authdata =
522+ clientWithRoute (Proxy :: Proxy api) q t req' baseurl opts
502523 where
503524 req' = req { authData = Just authdata }
504525
src/Servant/Reflex/Multi.hs+47−31
@@ -16,12 +16,15 @@
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
26+ -- * Access response data
27+ , withCredentials
2528
2629 -- * Access response data
2730 , ReqResult(..)
@@ -59,15 +62,18 @@ import Reflex.Dom (Dynamic, Event, Reflex,
5962------------------------------------------------------------------------------
6063import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
6164 SupportsServantReflex)
62−import Servant.Common.Req (QParam (..), QueryPart (..), Req,
65+import Servant.Common.Req (ClientOptions,
66+ QParam (..), QueryPart (..), Req,
6367 ReqResult (..), addHeader, authData,
64− defReq, performRequestsCT,
68+ defReq,
69+ defaultClientOptions,
70+ performRequestsCT,
6571 performRequestsNoBody,
6672 performSomeRequestsAsync,
6773 prependToPathParts, qParamToQueryPart,
6874 qParams, reqBody, reqFailure,
6975 reqMethod, reqSuccess, reqSuccess',
70− respHeaders, response)
76+ respHeaders, response, withCredentials)
7177import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
7278
7379
@@ -77,14 +83,24 @@ clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
7783 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
7884clientA p q f tag baseurl =
7985 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
86+ defaultClientOptions
87+
8088
89+-- | A version of @client@ that sets the withCredentials flag
90+-- on requests. Use this function for clients of CORS API's
91+clientWithOptsA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
92+ => Proxy layout -> Proxy m -> Proxy f -> Proxy tag
93+ -> Dynamic t BaseUrl -> ClientOptions -> ClientMulti t m layout f tag
94+clientWithOptsA p q f tag baseurl opts =
95+ clientWithRouteMulti p q f tag
96+ (constDyn (pure defReq)) baseurl opts
8197
8298------------------------------------------------------------------------------
8399class HasClientMulti t m layout f (tag :: *) where
84100 type ClientMulti t m layout f tag :: *
85101 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
86102 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
87− -> ClientMulti t m layout f tag
103+ -> ClientOptions -> ClientMulti t m layout f tag
88104
89105
90106------------------------------------------------------------------------------
@@ -92,9 +108,9 @@ instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>
92108 HasClientMulti t m (a :<|> b) f tag where
93109 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>
94110 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
111+ clientWithRouteMulti Proxy q f tag reqs baseurl opts =
112+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>
113+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts
98114
99115
100116------------------------------------------------------------------------------
@@ -107,8 +123,8 @@ instance (SupportsServantReflex t m,
107123 type ClientMulti t m (Capture capture a :> sublayout) f tag =
108124 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
109125
110− clientWithRouteMulti _ q f tag reqs baseurl vals =
111− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
126+ clientWithRouteMulti _ q f tag reqs baseurl opts vals =
127+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
112128 where
113129 reqs' = (prependToPathParts <$> ps <*>) <$> reqs
114130 ps = (fmap . fmap . fmap) toUrlPiece vals
@@ -128,8 +144,8 @@ instance {-# OVERLAPPABLE #-}
128144 type ClientMulti t m (Verb method status cts' a) f tag =
129145 Event t tag -> m (Event t (f (ReqResult tag a)))
130146
131− clientWithRouteMulti _ _ _ _ reqs baseurl =
132− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
147+ clientWithRouteMulti _ _ _ _ reqs baseurl opts =
148+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts
133149 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
134150 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
135151
@@ -143,8 +159,8 @@ instance {-# OVERLAPPING #-}
143159 Event t tag -> m (Event t (f (ReqResult tag NoContent)))
144160 -- TODO: how to access input types here?
145161 -- ExceptT ServantError IO NoContent
146− clientWithRouteMulti Proxy _ _ _ req baseurl =
147− performRequestsNoBody method req baseurl
162+ clientWithRouteMulti Proxy _ _ _ req baseurl opts =
163+ performRequestsNoBody method req baseurl opts
148164 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
149165
150166
@@ -158,9 +174,9 @@ instance {-# OVERLAPPABLE #-}
158174 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where
159175 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =
160176 Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))
161− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
177+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
162178 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)))
179+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))
164180 return $ fmap toHeaders <$> resp
165181 where
166182 reqs' = fmap (\r ->
@@ -181,9 +197,9 @@ instance {-# OVERLAPPABLE #-}
181197 cts (Headers ls NoContent)) f tag where
182198 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag
183199 = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))
184− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
200+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
185201 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
186− resp <- performRequestsNoBody method reqs' baseurl triggers
202+ resp <- performRequestsNoBody method reqs' baseurl opts triggers
187203 return $ fmap toHeaders <$> resp
188204 where reqs' = fmap (\req ->
189205 req {respHeaders = OnlyHeaders (Set.fromList
@@ -203,11 +219,11 @@ instance (KnownSymbol sym,
203219 type ClientMulti t m (Header sym a :> sublayout) f tag =
204220 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
205221
206− clientWithRouteMulti Proxy f q tag reqs baseurl eVals =
222+ clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =
207223 clientWithRouteMulti (Proxy :: Proxy sublayout) f
208224 q tag
209225 reqs'
210− baseurl
226+ baseurl opts
211227 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
212228 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
213229 <$> eVals <*>) <$> reqs
@@ -237,9 +253,9 @@ instance (KnownSymbol sym,
237253
238254 -- if mparam = Nothing, we don't add it to the query string
239255 -- TODO: Check the above comment
240− clientWithRouteMulti Proxy q f tag reqs baseurl mparams =
256+ clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =
241257 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
242− reqs' baseurl
258+ reqs' baseurl opts
243259
244260 where pname = symbolVal (Proxy :: Proxy sym)
245261 p prm = QueryPartParam $ fmap qParamToQueryPart prm
@@ -260,8 +276,8 @@ instance (KnownSymbol sym,
260276 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
261277 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
262278
263− clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =
264− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
279+ clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =
280+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
265281
266282 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }
267283 pname = symbolVal (Proxy :: Proxy sym)
@@ -279,8 +295,8 @@ instance (KnownSymbol sym,
279295 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
280296 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
281297
282− clientWithRouteMulti Proxy q f' tag reqs baseurl flags =
283− clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl
298+ clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =
299+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts
284300
285301 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
286302 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
@@ -294,10 +310,10 @@ instance (SupportsServantReflex t m,
294310 -> Event t tag
295311 -> m (Event t (f (ReqResult tag ())))
296312
297− clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do
313+ clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do
298314 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
299315 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
300− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync rawReqs''
316+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''
301317 return resps
302318 where
303319 aux (tag, Right r) = ResponseSuccess tag () r
@@ -313,8 +329,8 @@ instance (MimeRender ct a,
313329 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
314330 Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
315331
316− clientWithRouteMulti Proxy q f tag reqs baseurl bodies =
317− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
332+ clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
333+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
318334 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
319335 ctProxy = Proxy :: Proxy ct
320336 ctString = T.pack $ show $ contentType ctProxy
@@ -365,8 +381,8 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
365381 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))
366382 -> ClientMulti t m api f tag
367383
368− clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =
369− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl
384+ clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =
385+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts
370386 where
371387 req' a r = r { authData = Just (constDyn a) }
372388 reqs' = liftA2 req' <$> authdatas <*> reqs