@@ -1,65 +1,46 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE ExistentialQuantification #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE LambdaCase #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE NamedFieldPuns #-}
11−{-# LANGUAGE OverloadedStrings #-}
12−{-# LANGUAGE RankNTypes #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE TupleSections #-}
15−{-# OPTIONS_GHC -fno-warn-orphans #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TupleSections #-}
1610
1711module Servant.Common.Req where
1812
1913-------------------------------------------------------------------------------
20−import Control.Applicative (liftA2, liftA3)
14+import Control.Applicative (liftA2, liftA3)
15+import Control.Arrow ((&&&))
2116import Control.Concurrent
22−import Control.Monad (join)
23−import Control.Monad.IO.Class (MonadIO, liftIO)
24−import Data.Aeson
25−import Data.Bifunctor (first)
26−import qualified Data.ByteString as BS
27−import qualified Data.ByteString.Builder as BB
28−import Data.ByteString.Lazy (ByteString)
29−import qualified Data.ByteString.Lazy.Char8 as BL
17+import Control.Monad (join)
18+import Control.Monad.IO.Class (MonadIO, liftIO)
19+import Data.Bifunctor (first)
20+import qualified Data.ByteString.Builder as Builder
21+import qualified Data.ByteString.Lazy.Char8 as BL
22+import Data.ByteString (ByteString)
23+import qualified Data.Map as Map
24+import Data.Maybe (catMaybes, fromMaybe)
3025import Data.Functor.Compose
31−import qualified Data.JSString.Text as JS (lazyTextFromJSString)
32−import qualified Data.Map as Map
33−import Data.Maybe (catMaybes, fromMaybe)
34−import Data.Monoid ((<>))
35−import Data.Proxy (Proxy (..))
36−import Data.Text (Text)
37−import qualified Data.Text as T
38−import qualified Data.Text.Encoding as T
39−import qualified Data.Text.Lazy as TL
40−import Data.Traversable (forM)
41−import qualified Language.Javascript.JSaddle as JS
26+import Data.Monoid ((<>))
27+import Data.Proxy (Proxy(..))
28+import Data.Text (Text)
29+import qualified Data.Text as T
30+import qualified Data.Text.Encoding as TE
31+import Data.Traversable (forM)
4232import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
43−import qualified Network.URI as N
44−import Reflex.Dom.Core hiding (tag)
45−import Servant.API.ContentTypes (Accept, FormUrlEncoded,
46− JSON, NoContent (..),
47− OctetStream, PlainText)
48−import Servant.Common.BaseUrl (BaseUrl,
49− SupportsServantReflex,
50− showBaseUrl)
51−import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)
52−import Web.HttpApiData (ToHttpApiData (..))
33+import qualified Network.URI as N
34+import Reflex.Dom.Core hiding (tag)
35+import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
36+ SupportsServantReflex)
37+import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
38+import Web.HttpApiData (ToHttpApiData(..))
5339-------------------------------------------------------------------------------
5440import Servant.API.BasicAuth
55−-------------------------------------------------------------------------------
5641
57−-- #ifndef __GHCJS__
58−-- jsonDecode :: JS.JSString -> Maybe a
59−-- jsonDecode = error "jsonDecode is only available in GHCJS"
60−-- #endif
6142
62−-----------------------------------------------------------------------------
43+------------------------------------------------------------------------------
6344-- | The result of a request event
6445data ReqResult tag a
6546 = ResponseSuccess tag a XhrResponse
@@ -112,6 +93,13 @@ reqFailure (ResponseFailure _ s _) = Just s
11293reqFailure (RequestFailure _ s) = Just s
11394reqFailure _ = Nothing
11495
96+------------------------------------------------------------------------------
97+-- | Simple filter/accessor like 'reqFailure', but keeping the request tag
98+reqFailure' :: ReqResult tag a -> Maybe (tag,Text)
99+reqFailure' (ResponseFailure tag s _) = Just (tag,s)
100+reqFailure' (RequestFailure tag s) = Just (tag,s)
101+reqFailure' _ = Nothing
102+
115103
116104------------------------------------------------------------------------------
117105-- | Simple filter/accessor for the raw XHR response
@@ -153,35 +141,34 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
153141-------------------------------------------------------------------------------
154142-- The data structure used to build up request information while traversing
155143-- the shape of a servant API
156−data Req t = forall o. (IsXhrPayload o, Show o) => Req
144+data Req t = Req
157145 { reqMethod :: Text
158146 , reqPathParts :: [Dynamic t (Either Text Text)]
159147 , qParams :: [(Text, QueryPart t)]
160− , reqBody :: Maybe (Dynamic t (Either Text (o, Text)))
148+ , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))
161149 , headers :: [(Text, Dynamic t (Either Text Text))]
162150 , respHeaders :: XhrResponseHeaders
163151 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))
164152 }
165153
166−data SomeXhrRequest = forall o. (IsXhrPayload o, Show o) => SomeXhrRequest (XhrRequest (Maybe o))
167−
168154defReq :: Req t
169−defReq = Req "GET" [] [] (Nothing :: Maybe (Dynamic t (Either Text ((), Text)))) [] def Nothing
155+defReq = Req "GET" [] [] Nothing [] def Nothing
170156
171157prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t
172158prependToPathParts p req =
173159 req { reqPathParts = p : reqPathParts req }
174160
175161addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
176−addHeader name val req = req { headers = (name, (fmap . fmap) (T.decodeUtf8 . toHeader) val) : headers req }
162+addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
163+
177164
178165reqToReflexRequest
179− :: forall t. Reflex t
180− => Text
181− -> Dynamic t BaseUrl
182− -> Req t
183− -> Dynamic t (Either Text SomeXhrRequest)
184−reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (Either Text (o, Text)))) _ _ _) =
166+ :: forall t. Reflex t
167+ => Text
168+ -> Dynamic t BaseUrl
169+ -> Req t
170+ -> Dynamic t (Either Text (XhrRequest XhrPayload))
171+reqToReflexRequest reqMeth reqHost req =
185172 let t :: Dynamic t [Either Text Text]
186173 t = sequence $ reverse $ reqPathParts req
187174
@@ -233,33 +220,33 @@ reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (
233220 fmap (fmap (\rightVal -> (headerName, rightVal))) dynam
234221
235222 mkConfigBody :: Either Text [(Text,Text)]
236− -> (Either Text (o, Text))
237− -> Either Text (XhrRequestConfig (Maybe o))
223+ -> (Either Text (BL.ByteString, Text))
224+ -> Either Text (XhrRequestConfig XhrPayload)
238225 mkConfigBody ehs rb = case (ehs, rb) of
239226 (_, Left e) -> Left e
240227 (Left e, _) -> Left e
241228 (Right hs, Right (bBytes, bCT)) ->
242229 Right $ XhrRequestConfig
243− { _xhrRequestConfig_sendData = Just bBytes
230+ { _xhrRequestConfig_sendData = bytesToPayload bBytes
244231 , _xhrRequestConfig_headers =
245232 Map.insert "Content-Type" bCT (Map.fromList hs)
246233 , _xhrRequestConfig_user = Nothing
247234 , _xhrRequestConfig_password = Nothing
248− , _xhrRequestConfig_responseType = Nothing
235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
249236 , _xhrRequestConfig_withCredentials = False
250237 , _xhrRequestConfig_responseHeaders = def
251238 }
252239
253− xhrOpts :: Dynamic t (Either Text (XhrRequestConfig (Maybe o)))
254− xhrOpts = case reqBody of
240+ xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))
241+ xhrOpts = case reqBody req of
255242 Nothing -> ffor xhrHeaders $ \case
256243 Left e -> Left e
257244 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
258245 , _xhrRequestConfig_user = Nothing
259246 , _xhrRequestConfig_password = Nothing
260− , _xhrRequestConfig_responseType = Nothing
247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
248+ , _xhrRequestConfig_sendData = mempty
261249 , _xhrRequestConfig_withCredentials = False
262− , _xhrRequestConfig_sendData = Nothing
263250 }
264251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
265252
@@ -267,16 +254,16 @@ reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (
267254 mkAuth _ (Left e) = Left e
268255 mkAuth Nothing r = r
269256 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config
270− { _xhrRequestConfig_user = Just $ T.decodeUtf8 u
271− , _xhrRequestConfig_password = Just $ T.decodeUtf8 p}
257+ { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
258+ , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
272259
273260 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
274261 -> Dynamic t (Either Text (XhrRequestConfig x))
275262 addAuth xhr = case authData req of
276− Nothing -> xhr
263+ Nothing -> xhr
277264 Just auth -> liftA2 mkAuth auth xhr
278265
279− xhrReq = (liftA2 . liftA2) (\p opt -> SomeXhrRequest $ XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
266+ xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
280267
281268 in xhrReq
282269
@@ -285,14 +272,8 @@ reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (
285272displayHttpRequest :: Text -> Text
286273displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
287274
288−instance IsXhrPayload o => IsXhrPayload (Maybe o) where
289− sendXhrPayload xhr = maybe (sendXhrPayload xhr ()) (sendXhrPayload xhr)
290−
291−instance (IsXhrPayload o, IsXhrPayload o') => IsXhrPayload (Either o o') where
292− sendXhrPayload xhr = either (sendXhrPayload xhr) (sendXhrPayload xhr)
293−
294275-- | This function performs the request
295−performRequests :: forall t m f tag. (SupportsServantReflex t m, Traversable f)
276+performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
296277 => Text
297278 -> Dynamic t (f (Req t))
298279 -> Dynamic t BaseUrl
@@ -305,7 +286,6 @@ performRequests reqMeth rs reqHost opts trigger = do
305286 reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
306287
307288 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
308− reqs :: Event t (Compose ((,) tag) f (Either Text SomeXhrRequest))
309289 reqs = attachPromptlyDynWith
310290 (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
311291
@@ -321,31 +301,32 @@ performSomeRequestsAsync
321301 HasWebView (Performable m),
322302 PerformEvent t m,
323303 TriggerEvent t m,
324− Traversable f
304+ Traversable f,
305+ IsXhrPayload a,
306+ Show a
325307 )
326308 => ClientOptions
327− -> Event t (f (Either Text SomeXhrRequest))
309+ -> Event t (f (Either Text (XhrRequest a)))
328310 -> m (Event t (f (Either Text XhrResponse)))
329−performSomeRequestsAsync opts sxhr =
330− performSomeRequestsAsync' opts newXMLHttpRequest $ return <$> sxhr
311+performSomeRequestsAsync opts =
312+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
331313
332314
333315------------------------------------------------------------------------------
334316-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
335317-- that accepts 'f (Either e (XhrRequestb))' events
336318performSomeRequestsAsync'
337− :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
319+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
338320 => ClientOptions
339− -> (forall b. IsXhrPayload b => XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
340− -> Event t (Performable m (f (Either Text SomeXhrRequest)))
341− -> m (Event t (f (Either Text a)))
321+ -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
322+ -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
342323performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
343324 rs <- hrs
344325 resps <- forM rs $ \r -> case r of
345326 Left e -> do
346327 resp <- liftIO $ newMVar (Left e)
347328 return resp
348− Right (SomeXhrRequest r') -> do
329+ Right r' -> do
349330 resp <- liftIO newEmptyMVar
350331 r'' <- liftJSM $ (optsRequestFixup opts) r'
351332 _ <- newXhr r'' $ liftIO . putMVar resp . Right
@@ -354,6 +335,12 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs
354335 return ()
355336
356337
338+
339+type XhrPayload = ByteString
340+bytesToPayload :: BL.ByteString -> XhrPayload
341+bytesToPayload = BL.toStrict
342+
343+
357344performRequestsCT
358345 :: (SupportsServantReflex t m,
359346 MimeUnrender ct a, Traversable f)
@@ -366,14 +353,15 @@ performRequestsCT
366353 -> m (Event t (f (ReqResult tag a)))
367354performRequestsCT ct reqMeth reqs reqHost opts trigger = do
368355 resps <- performRequests reqMeth reqs reqHost opts trigger
369− let decodeResp x = first T.pack
370− . mimeUnrender ct
371− . JS.textToJSString
372− =<< note "No body text" (_xhrResponse_responseText x)
356+ let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
357+ first T.pack .
358+ mimeUnrender ct $
359+ BL.fromStrict x
360+ decodeResp _ = Left "No body"
373361 return $ fmap
374362 (\(t,rs) -> ffor rs $ \r -> case r of
375363 Left e -> RequestFailure t e
376− Right g -> evalResponse decodeResp (t,g)
364+ Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
377365 )
378366 resps
379367
@@ -400,7 +388,7 @@ evalResponse
400388 :: (XhrResponse -> Either Text a)
401389 -> (tag, XhrResponse)
402390 -> ReqResult tag a
403−evalResponse decodeRes (tag, xhr) =
391+evalResponse decode (tag, xhr) =
404392 let status = _xhrResponse_status xhr
405393 okStatus = status >= 200 && status < 400
406394 errMsg = fromMaybe
@@ -411,56 +399,33 @@ evalResponse decodeRes (tag, xhr) =
411399 then either
412400 (\e -> ResponseFailure tag e xhr)
413401 (\v -> ResponseSuccess tag v xhr)
414− (decodeRes xhr)
402+ (decode xhr)
415403 else ResponseFailure tag errMsg xhr
416404 in respPayld
417405
406+------------------------------------------------------------------------------
407+-- | Utility for simultaneously accessing/filtering Success and Failure
408+-- response 'Event's,
409+fanReqResult :: Reflex t => Event t (ReqResult tag a) -> (Event t Text, Event t a)
410+fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess
418411
419−-- | Similar to 'Servant.API.ContentType.MimeUnrender' but with the differnce that
420−-- the second argument expects a JSString instead of ByteString.
421−-- This can lead to better performance ghcjs.
422−class Accept contentType => MimeUnrender contentType a where
423− mimeUnrender :: Proxy contentType -> JS.JSString -> Either String a
424−
425−instance FromJSON a => MimeUnrender JSON a where
426− mimeUnrender _ = note "Failed to decode response" . jsonDecode
427−
428−-- | @urlDecodeAsForm@
429−-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
430−-- holds if every element of x is non-null (i.e., not @("", "")@)
431−instance FromForm a => MimeUnrender FormUrlEncoded a where
432− mimeUnrender _ = first T.unpack . urlDecodeAsForm . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
433−
434−-- | @left show . TextL.decodeUtf8'@
435−instance MimeUnrender PlainText TL.Text where
436− mimeUnrender _ = pure . JS.lazyTextFromJSString
437−
438−-- | @left show . TextS.decodeUtf8' . toStrict@
439−instance MimeUnrender PlainText T.Text where
440− mimeUnrender _ = pure . JS.textFromJSString
441−
442−-- | @Right . BC.unpack@
443−instance MimeUnrender PlainText String where
444− mimeUnrender _ = Right . T.unpack . JS.textFromJSString
445−
446−-- | @Right . id@
447−instance MimeUnrender OctetStream ByteString where
448− mimeUnrender _ = pure . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
412+------------------------------------------------------------------------------
413+-- | Utility for simultaneously accessing/filtering Success and Failure
414+-- response 'Event's, but keeping the request tag
415+fanReqResult' :: Reflex t => Event t (ReqResult tag a) -> (Event t (tag, Text), Event t (tag, a))
416+fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'
449417
450−-- | @Right . toStrict@
451−instance MimeUnrender OctetStream BS.ByteString where
452− mimeUnrender _ = pure . T.encodeUtf8 . JS.textFromJSString
453418
454419note :: e -> Maybe a -> Either e a
455−note e Nothing = Left e
456−note _ (Just a) = Right a
420+note e = maybe (Left e) Right
457421
458422fmapL :: (e -> e') -> Either e a -> Either e' a
459423fmapL _ (Right a) = Right a
460424fmapL f (Left e) = Left (f e)
461425
462−builderToText :: BB.Builder -> T.Text
463−builderToText = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString
426+builderToText :: Builder.Builder -> T.Text
427+builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
464428
465429escape :: T.Text -> T.Text
466−escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . toEncodedUrlPiece
430+escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
431+