@@ -8,6 +8,8 @@
88{-# LANGUAGE ScopedTypeVariables #-}
99{-# LANGUAGE TupleSections #-}
1010
11+{-# LANGUAGE MultiParamTypeClasses #-}
12+{-# LANGUAGE FlexibleInstances #-}
1113module Servant.Common.Req where
1214
1315-------------------------------------------------------------------------------
@@ -15,8 +17,11 @@ import Control.Applicative (liftA2, liftA3)
1517import Control.Concurrent
1618import Control.Monad (join)
1719import Control.Monad.IO.Class (MonadIO, liftIO)
20+import Data.Aeson
1821import 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)
2025import qualified Data.ByteString.Lazy.Char8 as BL
2126import qualified Data.Map as Map
2227import Data.Maybe (catMaybes, fromMaybe)
@@ -25,17 +30,24 @@ import Data.Monoid ((<>))
2530import Data.Proxy (Proxy(..))
2631import Data.Text (Text)
2732import 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
2935import Data.Traversable (forM)
3036import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
37+import qualified Language.Javascript.JSaddle as JS
38+import qualified Data.JSString.Text as JS (lazyTextFromJSString)
3139import qualified Network.URI as N
3240import Reflex.Dom.Core hiding (tag)
3341import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
3442 SupportsServantReflex)
35−import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
43+import Servant.API.ContentTypes ( NoContent(..), Accept, JSON
44+ , OctetStream, PlainText
45+ , FormUrlEncoded)
3646import Web.HttpApiData (ToHttpApiData(..))
47+import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)
3748-------------------------------------------------------------------------------
3849import Servant.API.BasicAuth
50+-------------------------------------------------------------------------------
3951
4052
4153------------------------------------------------------------------------------
@@ -150,7 +162,7 @@ prependToPathParts p req =
150162 req { reqPathParts = p : reqPathParts req }
151163
152164addHeader :: (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 }
154166
155167
156168reqToReflexRequest
@@ -245,8 +257,8 @@ reqToReflexRequest reqMeth reqHost req =
245257 mkAuth _ (Left e) = Left e
246258 mkAuth Nothing r = r
247259 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config
248− { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
249− , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
260+ { _xhrRequestConfig_user = Just $ T.decodeUtf8 u
261+ , _xhrRequestConfig_password = Just $ T.decodeUtf8 p}
250262
251263 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
252264 -> Dynamic t (Either Text (XhrRequestConfig x))
@@ -326,10 +338,9 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs
326338 return ()
327339
328340
329−
330341type XhrPayload = T.Text
331342bytesToPayload :: BL.ByteString -> XhrPayload
332−bytesToPayload = TE.decodeUtf8 . BL.toStrict
343+bytesToPayload = T.decodeUtf8 . BL.toStrict
333344
334345
335346performRequestsCT
@@ -344,11 +355,10 @@ performRequestsCT
344355 -> m (Event t (f (ReqResult tag a)))
345356performRequestsCT ct reqMeth reqs reqHost opts trigger = do
346357 resps <- performRequests reqMeth reqs reqHost opts trigger
347− let decodeResp x = first T.pack .
348− mimeUnrender ct .
349− BL.fromStrict .
350− TE.encodeUtf8 =<< note "No body text"
351− (_xhrResponse_responseText x)
358+ let decodeResp x = first T.pack
359+ . mimeUnrender ct
360+ . JS.textToJSString
361+ =<< note "No body text" (_xhrResponse_responseText x)
352362 return $ fmap
353363 (\(t,rs) -> ffor rs $ \r -> case r of
354364 Left e -> RequestFailure t e
@@ -379,7 +389,7 @@ evalResponse
379389 :: (XhrResponse -> Either Text a)
380390 -> (tag, XhrResponse)
381391 -> ReqResult tag a
382−evalResponse decode (tag, xhr) =
392+evalResponse decodeRes (tag, xhr) =
383393 let okStatus = _xhrResponse_status xhr < 400
384394 errMsg = fromMaybe
385395 ("Empty response with error code " <>
@@ -389,20 +399,56 @@ evalResponse decode (tag, xhr) =
389399 then either
390400 (\e -> ResponseFailure tag e xhr)
391401 (\v -> ResponseSuccess tag v xhr)
392− (decode xhr)
402+ (decodeRes xhr)
393403 else ResponseFailure tag errMsg xhr
394404 in respPayld
395405
396406
407+-- | Similar to 'Servant.API.ContentType.MimeUnrender' but with the differnce that
408+-- the second argument expects a JSString instead of ByteString.
409+-- This can lead to better performance ghcjs.
410+class Accept contentType => MimeUnrender contentType a where
411+ mimeUnrender :: Proxy contentType -> JS.JSString -> Either String a
412+
413+instance FromJSON a => MimeUnrender JSON a where
414+ mimeUnrender _ = note "Failed to decode response" . jsonDecode
415+
416+-- | @urlDecodeAsForm@
417+-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
418+-- holds if every element of x is non-null (i.e., not @("", "")@)
419+instance FromForm a => MimeUnrender FormUrlEncoded a where
420+ mimeUnrender _ = first T.unpack . urlDecodeAsForm . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
421+
422+-- | @left show . TextL.decodeUtf8'@
423+instance MimeUnrender PlainText TL.Text where
424+ mimeUnrender _ = pure . JS.lazyTextFromJSString
425+
426+-- | @left show . TextS.decodeUtf8' . toStrict@
427+instance MimeUnrender PlainText T.Text where
428+ mimeUnrender _ = pure . JS.textFromJSString
429+
430+-- | @Right . BC.unpack@
431+instance MimeUnrender PlainText String where
432+ mimeUnrender _ = Right . T.unpack . JS.textFromJSString
433+
434+-- | @Right . id@
435+instance MimeUnrender OctetStream ByteString where
436+ mimeUnrender _ = pure . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
437+
438+-- | @Right . toStrict@
439+instance MimeUnrender OctetStream BS.ByteString where
440+ mimeUnrender _ = pure . T.encodeUtf8 . JS.textFromJSString
441+
397442note :: e -> Maybe a -> Either e a
398−note e = maybe (Left e) Right
443+note e Nothing = Left e
444+note _ (Just a) = Right a
399445
400446fmapL :: (e -> e') -> Either e a -> Either e' a
401447fmapL _ (Right a) = Right a
402448fmapL f (Left e) = Left (f e)
403449
404−builderToText :: Builder.Builder -> T.Text
405−builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
450+builderToText :: BB.Builder -> T.Text
451+builderToText = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString
406452
407453escape :: T.Text -> T.Text
408−escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
454+escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . toEncodedUrlPiece