@@ -11,11 +11,12 @@
1111module Servant.Common.Req where
1212
1313-------------------------------------------------------------------------------
14−import Control.Concurrent
1514import Control.Applicative (liftA2, liftA3)
15+import Control.Concurrent
1616import Control.Monad (join)
1717import Control.Monad.IO.Class (MonadIO, liftIO)
1818import Data.Bifunctor (first)
19+import qualified Data.ByteString.Builder as Builder
1920import qualified Data.ByteString.Lazy.Char8 as BL
2021import qualified Data.Map as Map
2122import Data.Maybe (catMaybes, fromMaybe)
@@ -26,7 +27,7 @@ import Data.Text (Text)
2627import qualified Data.Text as T
2728import qualified Data.Text.Encoding as TE
2829import Data.Traversable (forM)
29−import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
30+import Language.Javascript.JSaddle.Monad (JSM, MonadJSM)
3031import Reflex.Dom hiding (tag)
3132import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
3233 SupportsServantReflex)
@@ -49,23 +50,22 @@ data ReqResult tag a
4950 deriving (Functor)
5051
5152data 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)
5554 -- ^ Aribtrarily modify requests just before they are sent.
5655 -- Warning: This escape hatch opens the possibility for your
5756 -- requests to diverge from what the server expects, when the
5857 -- server is also derived from a servant API
59− , optsDebugRequests :: Either Text (XhrRequest XhrPayload) -> JSM ()
60− -- ^ JSM action to run on each triggered request
6158 }
6259
6360defaultClientOptions :: ClientOptions
64−defaultClientOptions = ClientOptions
65− { optsWithCredentials = False
66− , optsRequestFixup = return
67− , optsDebugRequests = const (return ())
68− }
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'
6969
7070------------------------------------------------------------------------------
7171-- | Simple filter/accessor for successful responses, when you want to
@@ -156,10 +156,9 @@ reqToReflexRequest
156156 :: forall t. Reflex t
157157 => Text
158158 -> Dynamic t BaseUrl
159− -> ClientOptions
160159 -> Req t
161160 -> Dynamic t (Either Text (XhrRequest XhrPayload))
162−reqToReflexRequest reqMeth reqHost opts req =
161+reqToReflexRequest reqMeth reqHost req =
163162 let t :: Dynamic t [Either Text Text]
164163 t = sequence $ reverse $ reqPathParts req
165164
@@ -170,7 +169,9 @@ reqToReflexRequest reqMeth reqHost opts req =
170169 urlParts = fmap sequence t
171170
172171 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
174175
175176 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
176177 queryPartString (pName, qp) = case qp of
@@ -220,7 +221,7 @@ reqToReflexRequest reqMeth reqHost opts req =
220221 , _xhrRequestConfig_user = Nothing
221222 , _xhrRequestConfig_password = Nothing
222223 , _xhrRequestConfig_responseType = Nothing
223− , _xhrRequestConfig_withCredentials = optsWithCredentials opts
224+ , _xhrRequestConfig_withCredentials = False
224225 , _xhrRequestConfig_responseHeaders = def
225226 }
226227
@@ -233,7 +234,7 @@ reqToReflexRequest reqMeth reqHost opts req =
233234 , _xhrRequestConfig_password = Nothing
234235 , _xhrRequestConfig_responseType = Nothing
235236 , _xhrRequestConfig_sendData = ""
236− , _xhrRequestConfig_withCredentials = optsWithCredentials opts
237+ , _xhrRequestConfig_withCredentials = False
237238 }
238239 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
239240
@@ -270,19 +271,18 @@ performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
270271performRequests reqMeth rs reqHost opts trigger = do
271272 let xhrReqs =
272273 join $ (\(fxhr :: f (Req t)) -> sequence $
273− reqToReflexRequest reqMeth reqHost opts <$> fxhr) <$> rs
274+ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
274275
275276 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
276277 reqs = attachPromptlyDynWith
277278 (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
278279
279− performEvent_ $ ffor (reqs) $
280− liftJSM . mapM_ (optsDebugRequests opts $)
281−
282280 resps <- performSomeRequestsAsync opts reqs
283281 return $ getCompose <$> resps
284282
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.
286286performSomeRequestsAsync
287287 :: (MonadIO (Performable m),
288288 MonadJSM (Performable m),
@@ -290,18 +290,21 @@ performSomeRequestsAsync
290290 PerformEvent t m,
291291 TriggerEvent t m,
292292 Traversable f,
293− IsXhrPayload a)
293+ IsXhrPayload a,
294+ Show a
295+ )
294296 => ClientOptions
295297 -> Event t (f (Either Text (XhrRequest a)))
296298 -> m (Event t (f (Either Text XhrResponse)))
297−performSomeRequestsAsync opts = performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
299+performSomeRequestsAsync opts =
300+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
298301
299302
300303------------------------------------------------------------------------------
301304-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
302305-- that accepts 'f (Either e (XhrRequestb))' events
303306performSomeRequestsAsync'
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)
305308 => ClientOptions
306309 -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
307310 -> 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
321324
322325
323326
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−
343327type XhrPayload = T.Text
344328bytesToPayload :: BL.ByteString -> XhrPayload
345329bytesToPayload = TE.decodeUtf8 . BL.toStrict
@@ -413,3 +397,6 @@ note e = maybe (Left e) Right
413397fmapL :: (e -> e') -> Either e a -> Either e' a
414398fmapL _ (Right a) = Right a
415399fmapL f (Left e) = Left (f e)
400+
401+builderToText :: Builder.Builder -> T.Text
402+builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString