@@ -4,6 +4,7 @@
44{-# LANGUAGE GADTs #-}
55{-# LANGUAGE OverloadedStrings #-}
66{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE RankNTypes #-}
78{-# LANGUAGE ScopedTypeVariables #-}
89{-# LANGUAGE TupleSections #-}
910
@@ -50,6 +51,11 @@ data ReqResult tag a
5051data ClientOptions = ClientOptions
5152 { optsWithCredentials :: Bool
5253 -- ^ Set withCredentials field of xhr requests
54+ , optsRequestFixup :: forall a.XhrRequest a -> IO (XhrRequest a)
55+ -- ^ Aribtrarily modify requests just before they are sent.
56+ -- Warning: This escape hatch opens the possibility for your
57+ -- requests to diverge from what the server expects, when the
58+ -- server is also derived from a servant API
5359 , optsDebugRequests :: Either Text (XhrRequest XhrPayload) -> JSM ()
5460 -- ^ JSM action to run on each triggered request
5561 }
@@ -57,6 +63,7 @@ data ClientOptions = ClientOptions
5763defaultClientOptions :: ClientOptions
5864defaultClientOptions = ClientOptions
5965 { optsWithCredentials = False
66+ , optsRequestFixup = return
6067 , optsDebugRequests = const (return ())
6168 }
6269
@@ -132,9 +139,6 @@ data Req t = Req
132139 , headers :: [(Text, Dynamic t (Either Text Text))]
133140 , respHeaders :: XhrResponseHeaders
134141 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))
135− -- , reqWithCreds :: Bool
136− -- ^ set the withCredentials XHR flag
137− -- , debugReq :: Either Text (XhrRequest XhrPayload) -> JSM ()
138142 }
139143
140144defReq :: Req t
@@ -275,7 +279,7 @@ performRequests reqMeth rs reqHost opts trigger = do
275279 performEvent_ $ ffor (reqs) $
276280 liftJSM . mapM_ (optsDebugRequests opts $)
277281
278− resps <- performSomeRequestsAsync reqs
282+ resps <- performSomeRequestsAsync opts reqs
279283 return $ getCompose <$> resps
280284
281285-- | 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.
@@ -287,9 +291,10 @@ performSomeRequestsAsync
287291 TriggerEvent t m,
288292 Traversable f,
289293 IsXhrPayload a)
290− => Event t (f (Either Text (XhrRequest a)))
294+ => ClientOptions
295+ -> Event t (f (Either Text (XhrRequest a)))
291296 -> m (Event t (f (Either Text XhrResponse)))
292−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return
297+performSomeRequestsAsync opts = performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
293298
294299
295300------------------------------------------------------------------------------
@@ -297,9 +302,10 @@ performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap re
297302-- that accepts 'f (Either e (XhrRequestb))' events
298303performSomeRequestsAsync'
299304 :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
300− => (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
305+ => ClientOptions
306+ -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
301307 -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
302−performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
308+performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
303309 rs <- hrs
304310 resps <- forM rs $ \r -> case r of
305311 Left e -> do
@@ -307,7 +313,8 @@ performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb ->
307313 return resp
308314 Right r' -> do
309315 resp <- liftIO newEmptyMVar
310− _ <- newXhr r' $ liftIO . putMVar resp . Right
316+ r'' <- liftIO $ (optsRequestFixup opts) r'
317+ _ <- newXhr r'' $ liftIO . putMVar resp . Right
311318 return resp
312319 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
313320 return ()