@@ -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,27 @@ 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 System.IO.Unsafe (unsafePerformIO)
45+import GHCJS.Buffer (create, fromByteString, getArrayBuffer)
46+import GHCJS.Types (JSVal, jsval)
47+import GHCJS.Marshal (FromJSVal(..), fromJSVal)
48+import GHCJS.Marshal.Pure (pToJSVal)
49+#endif
50+
51+
3752------------------------------------------------------------------------------
3853-- | The result of a request event
3954data ReqResult tag a
@@ -369,6 +384,40 @@ performRequestsCT ct reqMeth reqs reqHost trigger = do
369384 )
370385 resps
371386
387+mimeUnrender' :: (MimeUnrender ct a, Typeable ct, FromJSON a) => Proxy ct -> BS.ByteString -> Either String a
388+mimeUnrender' p bs
389+ | cantRawJson = mimeUnrender p (BL.fromStrict bs)
390+ | otherwise = note "Raw JSON decode failure" $ rawDecode bs
391+ where
392+ cantRawJson = typeOf (Proxy :: Proxy JSON) /= typeOf p
393+
394+-- copied from http://lpaste.net/6122658287709061120
395+#ifdef ghcjs_HOST_OS
396+foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
397+foreign import javascript unsafe "JSON['parse']($1)" js_jsonParse :: JSVal -> JSVal
398+rawDecode :: (FromJSON a) => BS.ByteString -> Maybe a
399+rawDecode bs = do
400+ -- Below copied from Reflex.Dom.WebSocket.Foreign
401+ -- let (b, off, len) = fromByteString bs
402+ -- -- x = return $ js_dataView off len $ jsval $ getArrayBuffer b :: _
403+ -- jsv :: JSVal <- if BS.length bs == 0
404+ -- then undefined -- jsval . getArrayBuffer <$> create 0
405+ -- else undefined -- return $ js_dataView off len $ jsval $ getArrayBuffer b
406+
407+ let jsv = _ bs
408+ -- TODO pFromJSVal to avoid unsafePerformIO
409+ let res = unsafePerformIO $ try $ fromJSVal $ js_jsonParse jsv
410+ case res of
411+ Left (_e :: SomeException) -> Nothing
412+ Right (v :: (Maybe Aeson.Value)) -> maybe Nothing go v
413+ where
414+ go v = case Aeson.fromJSON v of
415+ Aeson.Success a -> Just a
416+ _ -> Nothing
417+#else
418+rawDecode :: FromJSON a => BS.ByteString -> Maybe a
419+rawDecode = decode . BL.fromStrict
420+#endif
372421
373422performRequestsNoBody
374423 :: (SupportsServantReflex t m,
@@ -391,7 +440,7 @@ evalResponse
391440 :: (XhrResponse -> Either Text a)
392441 -> (tag, XhrResponse)
393442 -> ReqResult tag a
394−evalResponse decode (tag, xhr) =
443+evalResponse decodeFun (tag, xhr) =
395444 let okStatus = _xhrResponse_status xhr < 400
396445 errMsg = fromMaybe
397446 ("Empty response with error code " <>
@@ -401,7 +450,7 @@ evalResponse decode (tag, xhr) =
401450 then either
402451 (\e -> ResponseFailure tag e xhr)
403452 (\v -> ResponseSuccess tag v xhr)
404− (decode xhr)
453+ (decodeFun xhr)
405454 else ResponseFailure tag errMsg xhr
406455 in respPayld
407456