@@ -8,6 +8,8 @@
8{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TupleSections #-}
9{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE MultiParamTypeClasses #-}
12+{-# LANGUAGE FlexibleInstances #-}
11module Servant.Common.Req where
13module Servant.Common.Req where
13-------------------------------------------------------------------------------
15-------------------------------------------------------------------------------
@@ -15,8 +17,11 @@ import Control.Applicative (liftA2, liftA3)
15import Control.Concurrent
17import Control.Concurrent
16import Control.Monad (join)
18import Control.Monad (join)
17import Control.Monad.IO.Class (MonadIO, liftIO)
19import Control.Monad.IO.Class (MonadIO, liftIO)
18import Data.Bifunctor (first)
21import Data.Bifunctor (first)
19−import qualified Data.ByteString.Builder as Builder
22+import qualified Data.ByteString.Builder as BB
23+import qualified Data.ByteString as BS
24+import Data.ByteString.Lazy (ByteString)
20import qualified Data.ByteString.Lazy.Char8 as BL
25import qualified Data.ByteString.Lazy.Char8 as BL
21import qualified Data.Map as Map
26import qualified Data.Map as Map
22import Data.Maybe (catMaybes, fromMaybe)
27import Data.Maybe (catMaybes, fromMaybe)
@@ -25,17 +30,24 @@ import Data.Monoid ((<>))
25import Data.Proxy (Proxy(..))
30import Data.Proxy (Proxy(..))
26import Data.Text (Text)
31import Data.Text (Text)
27import qualified Data.Text as T
32import qualified Data.Text as T
28−import qualified Data.Text.Encoding as TE
33+import qualified Data.Text.Lazy as TL
34+import qualified Data.Text.Encoding as T
29import Data.Traversable (forM)
35import Data.Traversable (forM)
30import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
36import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
37+import qualified Language.Javascript.JSaddle as JS
38+import qualified Data.JSString.Text as JS (lazyTextFromJSString)
31import qualified Network.URI as N
39import qualified Network.URI as N
32import Reflex.Dom.Core hiding (tag)
40import Reflex.Dom.Core hiding (tag)
33import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
41import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
34 SupportsServantReflex)
42 SupportsServantReflex)
35−import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
43+import Servant.API.ContentTypes ( NoContent(..), Accept, JSON
44+ , OctetStream, PlainText
36import Web.HttpApiData (ToHttpApiData(..))
46import Web.HttpApiData (ToHttpApiData(..))
47+import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)
37-------------------------------------------------------------------------------
48-------------------------------------------------------------------------------
38import Servant.API.BasicAuth
49import Servant.API.BasicAuth
50+-------------------------------------------------------------------------------
41------------------------------------------------------------------------------
53------------------------------------------------------------------------------
@@ -150,7 +162,7 @@ prependToPathParts p req =
150 req { reqPathParts = p : reqPathParts req }
162 req { reqPathParts = p : reqPathParts req }
152addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
164addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
153−addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
165+addHeader name val req = req { headers = (name, (fmap . fmap) (T.decodeUtf8 . toHeader) val) : headers req }
156reqToReflexRequest
168reqToReflexRequest
@@ -245,8 +257,8 @@ reqToReflexRequest reqMeth reqHost req =
245 mkAuth _ (Left e) = Left e
257 mkAuth _ (Left e) = Left e
246 mkAuth Nothing r = r
258 mkAuth Nothing r = r
247 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config
259 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config
248− { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
260+ { _xhrRequestConfig_user = Just $ T.decodeUtf8 u
249− , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
261+ , _xhrRequestConfig_password = Just $ T.decodeUtf8 p}
251 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
263 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
252 -> Dynamic t (Either Text (XhrRequestConfig x))
264 -> Dynamic t (Either Text (XhrRequestConfig x))
@@ -326,10 +338,9 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs
326 return ()
338 return ()
330type XhrPayload = T.Text
341type XhrPayload = T.Text
331bytesToPayload :: BL.ByteString -> XhrPayload
342bytesToPayload :: BL.ByteString -> XhrPayload
332−bytesToPayload = TE.decodeUtf8 . BL.toStrict
343+bytesToPayload = T.decodeUtf8 . BL.toStrict
335performRequestsCT
346performRequestsCT
@@ -344,11 +355,10 @@ performRequestsCT
344 -> m (Event t (f (ReqResult tag a)))
355 -> m (Event t (f (ReqResult tag a)))
345performRequestsCT ct reqMeth reqs reqHost opts trigger = do
356performRequestsCT ct reqMeth reqs reqHost opts trigger = do
346 resps <- performRequests reqMeth reqs reqHost opts trigger
357 resps <- performRequests reqMeth reqs reqHost opts trigger
347− let decodeResp x = first T.pack .
358+ let decodeResp x = first T.pack
348− mimeUnrender ct .
359+ . mimeUnrender ct
349− BL.fromStrict .
360+ . JS.textToJSString
350− TE.encodeUtf8 =<< note "No body text"
351− (_xhrResponse_responseText x)
361+ =<< note "No body text" (_xhrResponse_responseText x)
352 return $ fmap
362 return $ fmap
353 (\(t,rs) -> ffor rs $ \r -> case r of
363 (\(t,rs) -> ffor rs $ \r -> case r of
354 Left e -> RequestFailure t e
364 Left e -> RequestFailure t e
@@ -379,7 +389,7 @@ evalResponse
379 :: (XhrResponse -> Either Text a)
389 :: (XhrResponse -> Either Text a)
380 -> (tag, XhrResponse)
390 -> (tag, XhrResponse)
381 -> ReqResult tag a
391 -> ReqResult tag a
382−evalResponse decode (tag, xhr) =
392+evalResponse decodeRes (tag, xhr) =
383 let status = _xhrResponse_status xhr
393 let status = _xhrResponse_status xhr
384 okStatus = status >= 200 && status < 400
394 okStatus = status >= 200 && status < 400
385 errMsg = fromMaybe
395 errMsg = fromMaybe
@@ -390,20 +400,56 @@ evalResponse decode (tag, xhr) =
390 then either
400 then either
391 (\e -> ResponseFailure tag e xhr)
401 (\e -> ResponseFailure tag e xhr)
392 (\v -> ResponseSuccess tag v xhr)
402 (\v -> ResponseSuccess tag v xhr)
393− (decode xhr)
403+ (decodeRes xhr)
394 else ResponseFailure tag errMsg xhr
404 else ResponseFailure tag errMsg xhr
395 in respPayld
405 in respPayld
408+-- | Similar to 'Servant.API.ContentType.MimeUnrender' but with the differnce that
409+-- the second argument expects a JSString instead of ByteString.
410+-- This can lead to better performance ghcjs.
411+class Accept contentType => MimeUnrender contentType a where
412+ mimeUnrender :: Proxy contentType -> JS.JSString -> Either String a
414+instance FromJSON a => MimeUnrender JSON a where
415+ mimeUnrender _ = note "Failed to decode response" . jsonDecode
417+-- | @urlDecodeAsForm@
418+-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
419+-- holds if every element of x is non-null (i.e., not @("", "")@)
420+instance FromForm a => MimeUnrender FormUrlEncoded a where
421+ mimeUnrender _ = first T.unpack . urlDecodeAsForm . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
423+-- | @left show . TextL.decodeUtf8'@
424+instance MimeUnrender PlainText TL.Text where
425+ mimeUnrender _ = pure . JS.lazyTextFromJSString
427+-- | @left show . TextS.decodeUtf8' . toStrict@
428+instance MimeUnrender PlainText T.Text where
429+ mimeUnrender _ = pure . JS.textFromJSString
431+-- | @Right . BC.unpack@
432+instance MimeUnrender PlainText String where
433+ mimeUnrender _ = Right . T.unpack . JS.textFromJSString
436+instance MimeUnrender OctetStream ByteString where
437+ mimeUnrender _ = pure . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
439+-- | @Right . toStrict@
440+instance MimeUnrender OctetStream BS.ByteString where
441+ mimeUnrender _ = pure . T.encodeUtf8 . JS.textFromJSString
398note :: e -> Maybe a -> Either e a
443note :: e -> Maybe a -> Either e a
399−note e = maybe (Left e) Right
444+note e Nothing = Left e
445+note _ (Just a) = Right a
401fmapL :: (e -> e') -> Either e a -> Either e' a
447fmapL :: (e -> e') -> Either e a -> Either e' a
402fmapL _ (Right a) = Right a
448fmapL _ (Right a) = Right a
403fmapL f (Left e) = Left (f e)
449fmapL f (Left e) = Left (f e)
405−builderToText :: Builder.Builder -> T.Text
451+builderToText :: BB.Builder -> T.Text
406−builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
452+builderToText = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString
408escape :: T.Text -> T.Text
454escape :: T.Text -> T.Text
409−escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
455+escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . toEncodedUrlPiece