@@ -13,7 +13,10 @@ import Control.Concurrent
1313import Control.Applicative (liftA2, liftA3)
1414import Control.Monad (join)
1515import Control.Monad.IO.Class (MonadIO, liftIO)
16+import Data.Aeson
17+import qualified Data.Aeson as Aeson
1618import Data.Bifunctor (first)
19+import qualified Data.ByteString.Char8 as BS
1720import qualified Data.ByteString.Lazy.Char8 as BL
1821import qualified Data.Map as Map
1922import Data.Maybe (catMaybes, fromMaybe)
@@ -24,15 +27,27 @@ import Data.Text (Text)
2427import qualified Data.Text as T
2528import qualified Data.Text.Encoding as TE
2629import Data.Traversable (forM)
30+import Data.Typeable
2731import Reflex.Dom hiding (tag)
2832import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
2933 SupportsServantReflex)
30−import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
34+import Servant.API.ContentTypes (JSON, MimeUnrender(..),
35+ NoContent(..))
3136import Web.HttpApiData (ToHttpApiData(..))
3237-------------------------------------------------------------------------------
3338import Servant.API.BasicAuth
3439
3540
41+#ifdef ghcjs_HOST_OS
42+import Control.Exception
43+import System.IO.Unsafe (unsafePerformIO)
44+import GHCJS.Buffer (create, fromByteString, getArrayBuffer)
45+import GHCJS.Types (JSVal, jsval)
46+import GHCJS.Marshal (FromJSVal(..), fromJSVal)
47+import GHCJS.Marshal.Pure (pToJSVal)
48+#endif
49+
50+
3651------------------------------------------------------------------------------
3752-- | The result of a request event
3853data ReqResult tag a
@@ -374,6 +389,40 @@ performRequestsCT ct reqMeth reqs reqHost trigger = do
374389 )
375390 resps
376391
392+mimeUnrender' :: (MimeUnrender ct a, Typeable ct, FromJSON a) => Proxy ct -> BS.ByteString -> Either String a
393+mimeUnrender' p bs
394+ | cantRawJson = mimeUnrender p (BL.fromStrict bs)
395+ | otherwise = note "Raw JSON decode failure" $ rawDecode bs
396+ where
397+ cantRawJson = typeOf (Proxy :: Proxy JSON) /= typeOf p
398+
399+-- copied from http://lpaste.net/6122658287709061120
400+#ifdef ghcjs_HOST_OS
401+foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
402+foreign import javascript unsafe "JSON['parse']($1)" js_jsonParse :: JSVal -> JSVal
403+rawDecode :: (FromJSON a) => BS.ByteString -> Maybe a
404+rawDecode bs = do
405+ -- Below copied from Reflex.Dom.WebSocket.Foreign
406+ -- let (b, off, len) = fromByteString bs
407+ -- -- x = return $ js_dataView off len $ jsval $ getArrayBuffer b :: _
408+ -- jsv :: JSVal <- if BS.length bs == 0
409+ -- then undefined -- jsval . getArrayBuffer <$> create 0
410+ -- else undefined -- return $ js_dataView off len $ jsval $ getArrayBuffer b
411+
412+ let jsv = _ bs
413+ -- TODO pFromJSVal to avoid unsafePerformIO
414+ let res = unsafePerformIO $ try $ fromJSVal $ js_jsonParse jsv
415+ case res of
416+ Left (_e :: SomeException) -> Nothing
417+ Right (v :: (Maybe Aeson.Value)) -> maybe Nothing go v
418+ where
419+ go v = case Aeson.fromJSON v of
420+ Aeson.Success a -> Just a
421+ _ -> Nothing
422+#else
423+rawDecode :: FromJSON a => BS.ByteString -> Maybe a
424+rawDecode = decode . BL.fromStrict
425+#endif
377426
378427performRequestsNoBody
379428 :: (SupportsServantReflex t m,
@@ -396,7 +445,7 @@ evalResponse
396445 :: (XhrResponse -> Either Text a)
397446 -> (tag, XhrResponse)
398447 -> ReqResult tag a
399−evalResponse decode (tag, xhr) =
448+evalResponse decodeFun (tag, xhr) =
400449 let okStatus = _xhrResponse_status xhr < 400
401450 errMsg = fromMaybe
402451 ("Empty response with error code " <>
@@ -406,7 +455,7 @@ evalResponse decode (tag, xhr) =
406455 then either
407456 (\e -> ResponseFailure tag e xhr)
408457 (\v -> ResponseSuccess tag v xhr)
409− (decode xhr)
458+ (decodeFun xhr)
410459 else ResponseFailure tag errMsg xhr
411460 in respPayld
412461