@@ -14,7 +14,10 @@ import Control.Concurrent
1414import Control.Applicative (liftA2, liftA3)
1515import Control.Monad (join)
1616import Control.Monad.IO.Class (MonadIO, liftIO)
17+import Data.Aeson
18+import qualified Data.Aeson as Aeson
1719import Data.Bifunctor (first)
20+import qualified Data.ByteString.Char8 as BS
1821import qualified Data.ByteString.Lazy.Char8 as BL
1922import qualified Data.Map as Map
2023import Data.Maybe (catMaybes, fromMaybe)
@@ -25,15 +28,40 @@ import Data.Text (Text)
2528import qualified Data.Text as T
2629import qualified Data.Text.Encoding as TE
2730import Data.Traversable (forM)
31+import Data.Typeable
2832import Reflex.Dom hiding (tag)
2933import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
3034 SupportsServantReflex)
31−import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
35+import Servant.API.ContentTypes (JSON, MimeUnrender(..),
36+ NoContent(..))
3237import Web.HttpApiData (ToHttpApiData(..))
3338-------------------------------------------------------------------------------
3439import Servant.API.BasicAuth
3540
3641
42+#ifdef ghcjs_HOST_OS
43+import Control.Exception
44+import Control.Monad (liftM)
45+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
46+import qualified Data.Aeson as A
47+import qualified Data.HashMap.Strict as H
48+import qualified Data.Text.Internal as T
49+import qualified Data.Vector as V
50+import System.IO.Unsafe (unsafePerformIO)
51+import GHCJS.Buffer (create, fromByteString, getArrayBuffer)
52+import GHCJS.Types (JSVal, jsval)
53+import GHCJS.Marshal (FromJSVal(..), fromJSVal)
54+import GHCJS.Marshal.Pure (pToJSVal)
55+import qualified JavaScript.Object.Internal as OI
56+import Data.Scientific (Scientific, scientific, fromFloatDigits)
57+import GHCJS.Types
58+import GHCJS.Marshal
59+import GHCJS.Marshal.Pure
60+import GHCJS.Foreign.Internal
61+import GHCJS.Marshal.Internal
62+#endif
63+
64+
3765------------------------------------------------------------------------------
3866-- | The result of a request event
3967data ReqResult tag a
@@ -369,6 +397,66 @@ performRequestsCT ct reqMeth reqs reqHost trigger = do
369397 )
370398 resps
371399
400+mimeUnrender' :: (MimeUnrender ct a, Typeable ct, FromJSON a) => Proxy ct -> BS.ByteString -> Either String a
401+mimeUnrender' p bs
402+ | cantRawJson = mimeUnrender p (BL.fromStrict bs)
403+ | otherwise = note "Raw JSON decode failure" $ rawDecode bs
404+ where
405+ cantRawJson = typeOf (Proxy :: Proxy JSON) /= typeOf p
406+
407+-- copied from http://lpaste.net/6122658287709061120
408+#ifdef ghcjs_HOST_OS
409+foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
410+foreign import javascript unsafe "JSON['parse']($1)" js_jsonParse :: JSVal -> JSVal
411+rawDecode :: (FromJSON a) => BS.ByteString -> Maybe a
412+rawDecode bs = do
413+ -- Below copied from Reflex.Dom.WebSocket.Foreign
414+ let (b, off, len) = fromByteString bs
415+ -- x = return $ js_dataView off len $ jsval $ getArrayBuffer b :: _
416+ let jsv = if BS.length bs == 0
417+ then unsafePerformIO $ jsval . getArrayBuffer <$> create 0
418+ else js_dataView off len $ jsval $ getArrayBuffer b
419+
420+ -- let jsv = _ bs
421+ -- TODO pFromJSVal to avoid unsafePerformIO
422+ let res = unsafePerformIO $ try $ aesonFromJSVal $ js_jsonParse jsv
423+ case res of
424+ Left (_e :: SomeException) -> Nothing
425+ Right (v :: (Maybe Aeson.Value)) -> maybe Nothing go v
426+ where
427+ go v = case Aeson.fromJSON v of
428+ Aeson.Success a -> Just a
429+ _ -> Nothing
430+
431+
432+-- copied from http://lpaste.net/raw/353535 Thanks ncl28!
433+aesonFromJSVal :: JSVal -> IO (Maybe A.Value)
434+aesonFromJSVal r = case jsonTypeOf r of
435+ JSONNull -> return (Just A.Null)
436+ JSONInteger -> liftM (A.Number . flip scientific 0 . (toInteger :: Int -> Integer))
437+ <$> fromJSVal r
438+ JSONFloat -> liftM (A.Number . (fromFloatDigits :: Double -> Scientific))
439+ <$> fromJSVal r
440+ JSONBool -> liftM A.Bool <$> fromJSVal r
441+ JSONString -> liftM A.String <$> fromJSVal r
442+ -- JSONArray -> liftM (A.Array . V.fromList) <$> (fromJSVal r :: _)
443+ JSONArray -> liftM (A.Array . V.fromList) <$>
444+ runMaybeT (traverse (MaybeT . aesonFromJSVal) =<<
445+ (MaybeT (fromJSVal r)))
446+ JSONObject -> do
447+ props <- OI.listProps (OI.Object r)
448+ runMaybeT $ do
449+ propVals <- forM props $ \p -> do
450+ v <- MaybeT (aesonFromJSVal =<< OI.getProp p (OI.Object r))
451+ -- return (JSS.textFromJSString p, v)
452+ return (T.Text p, v)
453+ return (A.Object (H.fromList propVals))
454+{-# INLINE aesonFromJSVal #-}
455+
456+#else
457+rawDecode :: FromJSON a => BS.ByteString -> Maybe a
458+rawDecode = decode . BL.fromStrict
459+#endif
372460
373461performRequestsNoBody
374462 :: (SupportsServantReflex t m,
@@ -391,7 +479,7 @@ evalResponse
391479 :: (XhrResponse -> Either Text a)
392480 -> (tag, XhrResponse)
393481 -> ReqResult tag a
394−evalResponse decode (tag, xhr) =
482+evalResponse decodeFun (tag, xhr) =
395483 let okStatus = _xhrResponse_status xhr < 400
396484 errMsg = fromMaybe
397485 ("Empty response with error code " <>
@@ -401,7 +489,7 @@ evalResponse decode (tag, xhr) =
401489 then either
402490 (\e -> ResponseFailure tag e xhr)
403491 (\v -> ResponseSuccess tag v xhr)
404− (decode xhr)
492+ (decodeFun xhr)
405493 else ResponseFailure tag errMsg xhr
406494 in respPayld
407495