02cc277 · servant-reflex

git.iko.soy/servant-reflex

on master help sign in

Fix path encoding bug and consolidate request-fixup logic

02cc277Greg Hale9 years ago

exec/Example.hs+4−6

compare with master

unifiedsplit

@@ -96,14 +96,12 @@ run = mdo

96 el "br" (return ())

98 -- Name the computed API client functions

99+ let tweakRequest = ClientOptions $ \r -> do

100+ putStrLn ("Got req: " ++ show r)

101+ return $ r & withCredentials .~ True

99 let (getUnit :<|> getInt :<|> sayhi :<|> dbl

102 let (getUnit :<|> getInt :<|> sayhi :<|> dbl

100 :<|> multi :<|> qna :<|> secret :<|> doRaw) =

103 :<|> multi :<|> qna :<|> secret :<|> doRaw) =

101− clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url

104+ clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest

102− (ClientOptions {

103− optsWithCredentials = True

104− , optsDebugRequests = \x -> putStrLn "Got a request!" >>

105− putStrLn (show x)

106− })

107

105

108 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now

106 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now

109

107

src/Servant/Common/Req.hs+31−44

@@ -11,11 +11,12 @@

11module Servant.Common.Req where

13-------------------------------------------------------------------------------

14−import Control.Concurrent

15import Control.Applicative (liftA2, liftA3)

14import Control.Applicative (liftA2, liftA3)

15+import Control.Concurrent

16import Control.Monad (join)

17import Control.Monad.IO.Class (MonadIO, liftIO)

18import Data.Bifunctor (first)

19+import qualified Data.ByteString.Builder as Builder

19import qualified Data.ByteString.Lazy.Char8 as BL

20import qualified Data.ByteString.Lazy.Char8 as BL

20import qualified Data.Map as Map

21import qualified Data.Map as Map

21import Data.Maybe (catMaybes, fromMaybe)

22import Data.Maybe (catMaybes, fromMaybe)

@@ -26,7 +27,7 @@ import Data.Text (Text)

26import qualified Data.Text as T

27import qualified Data.Text as T

27import qualified Data.Text.Encoding as TE

28import qualified Data.Text.Encoding as TE

28import Data.Traversable (forM)

29import Data.Traversable (forM)

29−import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)

30+import Language.Javascript.JSaddle.Monad (JSM, MonadJSM)

30import Reflex.Dom hiding (tag)

31import Reflex.Dom hiding (tag)

31import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

32import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

32 SupportsServantReflex)

33 SupportsServantReflex)

@@ -49,23 +50,22 @@ data ReqResult tag a

49 deriving (Functor)

50 deriving (Functor)

51data ClientOptions = ClientOptions

52data ClientOptions = ClientOptions

52− { optsWithCredentials :: Bool

53− -- ^ Set withCredentials field of xhr requests

54− , optsRequestFixup :: forall a.XhrRequest a -> IO (XhrRequest a)

53+ { optsRequestFixup :: forall a. Show a => XhrRequest a -> IO (XhrRequest a)

55 -- ^ Aribtrarily modify requests just before they are sent.

54 -- ^ Aribtrarily modify requests just before they are sent.

56 -- Warning: This escape hatch opens the possibility for your

55 -- Warning: This escape hatch opens the possibility for your

57 -- requests to diverge from what the server expects, when the

56 -- requests to diverge from what the server expects, when the

58 -- server is also derived from a servant API

57 -- server is also derived from a servant API

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

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

61 }

58 }

63defaultClientOptions :: ClientOptions

60defaultClientOptions :: ClientOptions

64−defaultClientOptions = ClientOptions

61+defaultClientOptions = ClientOptions { optsRequestFixup = return }

65− { optsWithCredentials = False

62+

66− , optsRequestFixup = return

63+-- withCredentials :: Lens' (XhrRequest a) Bool

67− , optsDebugRequests = const (return ())

64+withCredentials :: (Show a, Functor f) => (Bool -> f Bool) -> XhrRequest a -> f (XhrRequest a)

68− }

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'

70------------------------------------------------------------------------------

71-- | Simple filter/accessor for successful responses, when you want to

@@ -156,10 +156,9 @@ reqToReflexRequest

156 :: forall t. Reflex t

157 => Text

158 -> Dynamic t BaseUrl

159− -> ClientOptions

160 -> Req t

159 -> Req t

161 -> Dynamic t (Either Text (XhrRequest XhrPayload))

160 -> Dynamic t (Either Text (XhrRequest XhrPayload))

162−reqToReflexRequest reqMeth reqHost opts req =

161+reqToReflexRequest reqMeth reqHost req =

163 let t :: Dynamic t [Either Text Text]

162 let t :: Dynamic t [Either Text Text]

164 t = sequence $ reverse $ reqPathParts req

163 t = sequence $ reverse $ reqPathParts req

165

164

@@ -170,7 +169,9 @@ reqToReflexRequest reqMeth reqHost opts req =

170 urlParts = fmap sequence t

169 urlParts = fmap sequence t

171

170

172 urlPath :: Dynamic t (Either Text Text)

171 urlPath :: Dynamic t (Either Text Text)

173− urlPath = (fmap.fmap) (T.intercalate "/") urlParts

172+ urlPath = (fmap.fmap)

173+ (T.intercalate "/" . fmap (builderToText . toEncodedUrlPiece))

174+ urlParts

174

175

175 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))

176 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))

176 queryPartString (pName, qp) = case qp of

177 queryPartString (pName, qp) = case qp of

@@ -220,7 +221,7 @@ reqToReflexRequest reqMeth reqHost opts req =

220 , _xhrRequestConfig_user = Nothing

221 , _xhrRequestConfig_user = Nothing

221 , _xhrRequestConfig_password = Nothing

222 , _xhrRequestConfig_password = Nothing

222 , _xhrRequestConfig_responseType = Nothing

223 , _xhrRequestConfig_responseType = Nothing

223− , _xhrRequestConfig_withCredentials = optsWithCredentials opts

224+ , _xhrRequestConfig_withCredentials = False

224 , _xhrRequestConfig_responseHeaders = def

225 , _xhrRequestConfig_responseHeaders = def

225 }

226 }

226

227

@@ -233,7 +234,7 @@ reqToReflexRequest reqMeth reqHost opts req =

233 , _xhrRequestConfig_password = Nothing

234 , _xhrRequestConfig_password = Nothing

234 , _xhrRequestConfig_responseType = Nothing

235 , _xhrRequestConfig_responseType = Nothing

235 , _xhrRequestConfig_sendData = ""

236 , _xhrRequestConfig_sendData = ""

236− , _xhrRequestConfig_withCredentials = optsWithCredentials opts

237+ , _xhrRequestConfig_withCredentials = False

237 }

238 }

238 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

239 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

239

240

@@ -270,19 +271,18 @@ performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)

270performRequests reqMeth rs reqHost opts trigger = do

271performRequests reqMeth rs reqHost opts trigger = do

271 let xhrReqs =

272 let xhrReqs =

272 join $ (\(fxhr :: f (Req t)) -> sequence $

273 join $ (\(fxhr :: f (Req t)) -> sequence $

273− reqToReflexRequest reqMeth reqHost opts <$> fxhr) <$> rs

274+ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs

274

275

275 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

276 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

276 reqs = attachPromptlyDynWith

277 reqs = attachPromptlyDynWith

277 (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger

278 (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger

278

279

279− performEvent_ $ ffor (reqs) $

280− liftJSM . mapM_ (optsDebugRequests opts $)

281−

282 resps <- performSomeRequestsAsync opts reqs

280 resps <- performSomeRequestsAsync opts reqs

283 return $ getCompose <$> resps

281 return $ getCompose <$> resps

284

282

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.

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.

286performSomeRequestsAsync

287 :: (MonadIO (Performable m),

288 MonadJSM (Performable m),

@@ -290,18 +290,21 @@ performSomeRequestsAsync

290 PerformEvent t m,

291 TriggerEvent t m,

292 Traversable f,

293− IsXhrPayload a)

293+ IsXhrPayload a,

294+ Show a

295+ )

294 => ClientOptions

296 => ClientOptions

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

297 -> Event t (f (Either Text (XhrRequest a)))

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

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

299+performSomeRequestsAsync opts =

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

300+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

298

301

299

302

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

303------------------------------------------------------------------------------

301-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync

304-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync

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

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

303performSomeRequestsAsync'

306performSomeRequestsAsync'

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

307+ :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)

305 => ClientOptions

308 => ClientOptions

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

309 -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)

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

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

@@ -321,25 +324,6 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs

321

324

322

325

323

326

324−-- -- | This function performs the request

325−-- performRequest :: forall t m tag .(SupportsServantReflex t m)

326−-- => Text

327−-- -> Req t

328−-- -> Dynamic t BaseUrl

329−-- -> Event t tag

330−-- -> m (Event t (tag, XhrResponse), Event t (tag, Text))

331−-- performRequest reqMeth req reqHost trigger = do

332−

333−-- let xhrReq = reqToReflexRequest reqMeth reqHost req

334−-- let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger

335−-- okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) (snd e)) reqs

336−-- badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) (snd e)) reqs

337−

338−-- resps <- performRequestsAsync okReqs

339−

340−-- return (resps, badReqs)

341−

342−

343type XhrPayload = T.Text

327type XhrPayload = T.Text

344bytesToPayload :: BL.ByteString -> XhrPayload

328bytesToPayload :: BL.ByteString -> XhrPayload

345bytesToPayload = TE.decodeUtf8 . BL.toStrict

329bytesToPayload = TE.decodeUtf8 . BL.toStrict

@@ -413,3 +397,6 @@ note e = maybe (Left e) Right

413fmapL :: (e -> e') -> Either e a -> Either e' a

397fmapL :: (e -> e') -> Either e a -> Either e' a

414fmapL _ (Right a) = Right a

398fmapL _ (Right a) = Right a

415fmapL f (Left e) = Left (f e)

399fmapL 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+2−1

@@ -30,6 +30,7 @@ module Servant.Reflex

30 , toHeaders

31 , HasClient

32 , Client

33+ , withCredentials

33 , module Servant.Common.Req

34 , module Servant.Common.Req

34 , module Servant.Common.BaseUrl

35 , module Servant.Common.BaseUrl

35 ) where

36 ) where

@@ -83,7 +84,7 @@ import Servant.Common.Req (ClientOptions(..),

83 reqMethod, respHeaders,

84 reqMethod, respHeaders,

84 response,

85 response,

85 reqTag,

86 reqTag,

86− qParams)

87+ qParams, withCredentials)

89-- * Accessing APIs as a Client

90-- * Accessing APIs as a Client

src/Servant/Reflex/Multi.hs+4−1

@@ -23,6 +23,9 @@ module Servant.Reflex.Multi (

23 -- * Build QueryParam arguments

24 , QParam(..)

26+ -- * Access response data

27+ , withCredentials

28+

26 -- * Access response data

29 -- * Access response data

27 , ReqResult(..)

30 , ReqResult(..)

28 , reqSuccess

31 , reqSuccess

@@ -70,7 +73,7 @@ import Servant.Common.Req (ClientOptions,

70 prependToPathParts, qParamToQueryPart,

73 prependToPathParts, qParamToQueryPart,

71 qParams, reqBody, reqFailure,

74 qParams, reqBody, reqFailure,

72 reqMethod, reqSuccess, reqSuccess',

75 reqMethod, reqSuccess, reqSuccess',

73− respHeaders, response)

76+ respHeaders, response, withCredentials)

74import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)

77import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)