@@ -1,46 +1,65 @@
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 #-}
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 #-}
1016
1117module Servant.Common.Req where
1218
1319-------------------------------------------------------------------------------
14−import Control.Applicative (liftA2, liftA3)
15−import Control.Arrow ((&&&))
20+import Control.Applicative (liftA2, liftA3)
1621import Control.Concurrent
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)
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
2530import Data.Functor.Compose
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)
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
3242import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
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(..))
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 (..))
3953-------------------------------------------------------------------------------
4054import Servant.API.BasicAuth
55+-------------------------------------------------------------------------------
4156
57+-- #ifndef __GHCJS__
58+-- jsonDecode :: JS.JSString -> Maybe a
59+-- jsonDecode = error "jsonDecode is only available in GHCJS"
60+-- #endif
4261
43−------------------------------------------------------------------------------
62+-----------------------------------------------------------------------------
4463-- | The result of a request event
4564data ReqResult tag a
4665 = ResponseSuccess tag a XhrResponse
@@ -93,13 +112,6 @@ reqFailure (ResponseFailure _ s _) = Just s
93112reqFailure (RequestFailure _ s) = Just s
94113reqFailure _ = Nothing
95114
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−
103115
104116------------------------------------------------------------------------------
105117-- | Simple filter/accessor for the raw XHR response
@@ -141,34 +153,35 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
141153-------------------------------------------------------------------------------
142154-- The data structure used to build up request information while traversing
143155-- the shape of a servant API
144−data Req t = Req
156+data Req t = forall o. (IsXhrPayload o, Show o) => Req
145157 { reqMethod :: Text
146158 , reqPathParts :: [Dynamic t (Either Text Text)]
147159 , qParams :: [(Text, QueryPart t)]
148− , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))
160+ , reqBody :: Maybe (Dynamic t (Either Text (o, Text)))
149161 , headers :: [(Text, Dynamic t (Either Text Text))]
150162 , respHeaders :: XhrResponseHeaders
151163 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))
152164 }
153165
166+data SomeXhrRequest = forall o. (IsXhrPayload o, Show o) => SomeXhrRequest (XhrRequest (Maybe o))
167+
154168defReq :: Req t
155−defReq = Req "GET" [] [] Nothing [] def Nothing
169+defReq = Req "GET" [] [] (Nothing :: Maybe (Dynamic t (Either Text ((), Text)))) [] def Nothing
156170
157171prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t
158172prependToPathParts p req =
159173 req { reqPathParts = p : reqPathParts req }
160174
161175addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
162−addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
163−
176+addHeader name val req = req { headers = (name, (fmap . fmap) (T.decodeUtf8 . toHeader) val) : headers req }
164177
165178reqToReflexRequest
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 =
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)))) _ _ _) =
172185 let t :: Dynamic t [Either Text Text]
173186 t = sequence $ reverse $ reqPathParts req
174187
@@ -220,33 +233,33 @@ reqToReflexRequest reqMeth reqHost req =
220233 fmap (fmap (\rightVal -> (headerName, rightVal))) dynam
221234
222235 mkConfigBody :: Either Text [(Text,Text)]
223− -> (Either Text (BL.ByteString, Text))
224− -> Either Text (XhrRequestConfig XhrPayload)
236+ -> (Either Text (o, Text))
237+ -> Either Text (XhrRequestConfig (Maybe o))
225238 mkConfigBody ehs rb = case (ehs, rb) of
226239 (_, Left e) -> Left e
227240 (Left e, _) -> Left e
228241 (Right hs, Right (bBytes, bCT)) ->
229242 Right $ XhrRequestConfig
230− { _xhrRequestConfig_sendData = bytesToPayload bBytes
243+ { _xhrRequestConfig_sendData = Just bBytes
231244 , _xhrRequestConfig_headers =
232245 Map.insert "Content-Type" bCT (Map.fromList hs)
233246 , _xhrRequestConfig_user = Nothing
234247 , _xhrRequestConfig_password = Nothing
235− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
248+ , _xhrRequestConfig_responseType = Nothing
236249 , _xhrRequestConfig_withCredentials = False
237250 , _xhrRequestConfig_responseHeaders = def
238251 }
239252
240− xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))
241− xhrOpts = case reqBody req of
253+ xhrOpts :: Dynamic t (Either Text (XhrRequestConfig (Maybe o)))
254+ xhrOpts = case reqBody of
242255 Nothing -> ffor xhrHeaders $ \case
243256 Left e -> Left e
244257 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
245258 , _xhrRequestConfig_user = Nothing
246259 , _xhrRequestConfig_password = Nothing
247− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
248− , _xhrRequestConfig_sendData = mempty
260+ , _xhrRequestConfig_responseType = Nothing
249261 , _xhrRequestConfig_withCredentials = False
262+ , _xhrRequestConfig_sendData = Nothing
250263 }
251264 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
252265
@@ -254,16 +267,16 @@ reqToReflexRequest reqMeth reqHost req =
254267 mkAuth _ (Left e) = Left e
255268 mkAuth Nothing r = r
256269 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config
257− { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
258− , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
270+ { _xhrRequestConfig_user = Just $ T.decodeUtf8 u
271+ , _xhrRequestConfig_password = Just $ T.decodeUtf8 p}
259272
260273 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
261274 -> Dynamic t (Either Text (XhrRequestConfig x))
262275 addAuth xhr = case authData req of
263− Nothing -> xhr
276+ Nothing -> xhr
264277 Just auth -> liftA2 mkAuth auth xhr
265278
266− xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
279+ xhrReq = (liftA2 . liftA2) (\p opt -> SomeXhrRequest $ XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
267280
268281 in xhrReq
269282
@@ -272,8 +285,14 @@ reqToReflexRequest reqMeth reqHost req =
272285displayHttpRequest :: Text -> Text
273286displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
274287
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+
275294-- | This function performs the request
276−performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
295+performRequests :: forall t m f tag. (SupportsServantReflex t m, Traversable f)
277296 => Text
278297 -> Dynamic t (f (Req t))
279298 -> Dynamic t BaseUrl
@@ -286,6 +305,7 @@ performRequests reqMeth rs reqHost opts trigger = do
286305 reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
287306
288307 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
308+ reqs :: Event t (Compose ((,) tag) f (Either Text SomeXhrRequest))
289309 reqs = attachPromptlyDynWith
290310 (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
291311
@@ -301,32 +321,31 @@ performSomeRequestsAsync
301321 HasWebView (Performable m),
302322 PerformEvent t m,
303323 TriggerEvent t m,
304− Traversable f,
305− IsXhrPayload a,
306− Show a
324+ Traversable f
307325 )
308326 => ClientOptions
309− -> Event t (f (Either Text (XhrRequest a)))
327+ -> Event t (f (Either Text SomeXhrRequest))
310328 -> m (Event t (f (Either Text XhrResponse)))
311−performSomeRequestsAsync opts =
312− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
329+performSomeRequestsAsync opts sxhr =
330+ performSomeRequestsAsync' opts newXMLHttpRequest $ return <$> sxhr
313331
314332
315333------------------------------------------------------------------------------
316334-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
317335-- that accepts 'f (Either e (XhrRequestb))' events
318336performSomeRequestsAsync'
319− :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
337+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
320338 => ClientOptions
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)))
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)))
323342performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
324343 rs <- hrs
325344 resps <- forM rs $ \r -> case r of
326345 Left e -> do
327346 resp <- liftIO $ newMVar (Left e)
328347 return resp
329− Right r' -> do
348+ Right (SomeXhrRequest r') -> do
330349 resp <- liftIO newEmptyMVar
331350 r'' <- liftJSM $ (optsRequestFixup opts) r'
332351 _ <- newXhr r'' $ liftIO . putMVar resp . Right
@@ -335,12 +354,6 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs
335354 return ()
336355
337356
338−
339−type XhrPayload = ByteString
340−bytesToPayload :: BL.ByteString -> XhrPayload
341−bytesToPayload = BL.toStrict
342−
343−
344357performRequestsCT
345358 :: (SupportsServantReflex t m,
346359 MimeUnrender ct a, Traversable f)
@@ -353,15 +366,14 @@ performRequestsCT
353366 -> m (Event t (f (ReqResult tag a)))
354367performRequestsCT ct reqMeth reqs reqHost opts trigger = do
355368 resps <- performRequests reqMeth reqs reqHost opts trigger
356− let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
357− first T.pack .
358− mimeUnrender ct $
359− BL.fromStrict x
360− decodeResp _ = Left "No body"
369+ let decodeResp x = first T.pack
370+ . mimeUnrender ct
371+ . JS.textToJSString
372+ =<< note "No body text" (_xhrResponse_responseText x)
361373 return $ fmap
362374 (\(t,rs) -> ffor rs $ \r -> case r of
363375 Left e -> RequestFailure t e
364− Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
376+ Right g -> evalResponse decodeResp (t,g)
365377 )
366378 resps
367379
@@ -388,7 +400,7 @@ evalResponse
388400 :: (XhrResponse -> Either Text a)
389401 -> (tag, XhrResponse)
390402 -> ReqResult tag a
391−evalResponse decode (tag, xhr) =
403+evalResponse decodeRes (tag, xhr) =
392404 let status = _xhrResponse_status xhr
393405 okStatus = status >= 200 && status < 400
394406 errMsg = fromMaybe
@@ -399,33 +411,56 @@ evalResponse decode (tag, xhr) =
399411 then either
400412 (\e -> ResponseFailure tag e xhr)
401413 (\v -> ResponseSuccess tag v xhr)
402− (decode xhr)
414+ (decodeRes xhr)
403415 else ResponseFailure tag errMsg xhr
404416 in respPayld
405417
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
411418
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'
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
417433
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
449+
450+-- | @Right . toStrict@
451+instance MimeUnrender OctetStream BS.ByteString where
452+ mimeUnrender _ = pure . T.encodeUtf8 . JS.textFromJSString
418453
419454note :: e -> Maybe a -> Either e a
420−note e = maybe (Left e) Right
455+note e Nothing = Left e
456+note _ (Just a) = Right a
421457
422458fmapL :: (e -> e') -> Either e a -> Either e' a
423459fmapL _ (Right a) = Right a
424460fmapL f (Left e) = Left (f e)
425461
426−builderToText :: Builder.Builder -> T.Text
427−builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
462+builderToText :: BB.Builder -> T.Text
463+builderToText = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString
428464
429465escape :: T.Text -> T.Text
430−escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
431−
466+escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . toEncodedUrlPiece