a89ae84 · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

on master help sign in

Add optsRequestFiuxp field to ClientOptions

a89ae84Greg Hale9 years ago

src/Servant/Common/Req.hs+16−9

compare with master

unifiedsplit

@@ -4,6 +4,7 @@

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TupleSections #-}

9{-# LANGUAGE TupleSections #-}

@@ -50,6 +51,11 @@ data ReqResult tag a

50data ClientOptions = ClientOptions

51data ClientOptions = ClientOptions

51 { optsWithCredentials :: Bool

52 { optsWithCredentials :: Bool

52 -- ^ Set withCredentials field of xhr requests

53 -- ^ 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

53 , optsDebugRequests :: Either Text (XhrRequest XhrPayload) -> JSM ()

59 , optsDebugRequests :: Either Text (XhrRequest XhrPayload) -> JSM ()

54 -- ^ JSM action to run on each triggered request

60 -- ^ JSM action to run on each triggered request

55 }

61 }

@@ -57,6 +63,7 @@ data ClientOptions = ClientOptions

57defaultClientOptions :: ClientOptions

63defaultClientOptions :: ClientOptions

58defaultClientOptions = ClientOptions

64defaultClientOptions = ClientOptions

59 { optsWithCredentials = False

65 { optsWithCredentials = False

66+ , optsRequestFixup = return

60 , optsDebugRequests = const (return ())

67 , optsDebugRequests = const (return ())

61 }

68 }

@@ -132,9 +139,6 @@ data Req t = Req

132 , headers :: [(Text, Dynamic t (Either Text Text))]

139 , headers :: [(Text, Dynamic t (Either Text Text))]

133 , respHeaders :: XhrResponseHeaders

140 , respHeaders :: XhrResponseHeaders

134 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))

141 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))

135− -- , reqWithCreds :: Bool

136− -- ^ set the withCredentials XHR flag

137− -- , debugReq :: Either Text (XhrRequest XhrPayload) -> JSM ()

138 }

142 }

139

143

140defReq :: Req t

144defReq :: Req t

@@ -275,7 +279,7 @@ performRequests reqMeth rs reqHost opts trigger = do

275 performEvent_ $ ffor (reqs) $

279 performEvent_ $ ffor (reqs) $

276 liftJSM . mapM_ (optsDebugRequests opts $)

280 liftJSM . mapM_ (optsDebugRequests opts $)

277

281

278− resps <- performSomeRequestsAsync reqs

282+ resps <- performSomeRequestsAsync opts reqs

279 return $ getCompose <$> resps

283 return $ getCompose <$> resps

280

284

281-- | 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.

285-- | 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

287 TriggerEvent t m,

291 TriggerEvent t m,

288 Traversable f,

292 Traversable f,

289 IsXhrPayload a)

293 IsXhrPayload a)

294+ => ClientOptions

290− => Event t (f (Either Text (XhrRequest a)))

295+ -> Event t (f (Either Text (XhrRequest a)))

291 -> m (Event t (f (Either Text XhrResponse)))

296 -> m (Event t (f (Either Text XhrResponse)))

292−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return

297+performSomeRequestsAsync opts = performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

293

298

294

299

295------------------------------------------------------------------------------

300------------------------------------------------------------------------------

@@ -297,9 +302,10 @@ performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap re

297-- that accepts 'f (Either e (XhrRequestb))' events

302-- that accepts 'f (Either e (XhrRequestb))' events

298performSomeRequestsAsync'

303performSomeRequestsAsync'

299 :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)

304 :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)

305+ => ClientOptions

300− => (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)

306+ -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)

301 -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))

307 -> 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

303 rs <- hrs

309 rs <- hrs

304 resps <- forM rs $ \r -> case r of

310 resps <- forM rs $ \r -> case r of

305 Left e -> do

311 Left e -> do

@@ -307,7 +313,8 @@ performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb ->

307 return resp

313 return resp

308 Right r' -> do

314 Right r' -> do

309 resp <- liftIO newEmptyMVar

315 resp <- liftIO newEmptyMVar

316+ r'' <- liftIO $ (optsRequestFixup opts) r'

310− _ <- newXhr r' $ liftIO . putMVar resp . Right

317+ _ <- newXhr r'' $ liftIO . putMVar resp . Right

311 return resp

318 return resp

312 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar

319 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar

313 return ()

320 return ()

src/Servant/Reflex/Multi.hs+2−2

@@ -307,10 +307,10 @@ instance (SupportsServantReflex t m,

307 -> Event t tag

308 -> m (Event t (f (ReqResult tag ())))

309

310− clientWithRouteMulti _ _ _ _ _ _ _ rawReqs triggers = do

310+ clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do

311 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))

312 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers

313− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync rawReqs''

313+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''

314 return resps

315 where

316 aux (tag, Right r) = ResponseSuccess tag () r