@@ -9,6 +9,7 @@
99{-# LANGUAGE GADTs #-}
1010{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1111{-# LANGUAGE JavaScriptFFI #-}
12+{-# LANGUAGE LambdaCase #-}
1213{-# LANGUAGE MultiParamTypeClasses #-}
1314{-# LANGUAGE NoMonomorphismRestriction #-}
1415{-# LANGUAGE PolyKinds #-}
@@ -35,19 +36,38 @@ import Reflex.TriggerEvent.Class
3536
3637import Control.Concurrent
3738import Control.Concurrent.STM
38−import Control.Exception (SomeException)
39+import Control.Exception
3940import Control.Lens
4041import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
4142import Control.Monad.IO.Class
4243import Control.Monad.State
44+import Data.Aeson hiding (json)
4345import Data.ByteString (ByteString)
4446import Data.Default
4547import Data.IORef
48+import Data.JSString (JSString)
4649import Data.Maybe (isJust)
4750import Data.Text
51+import Data.Text.Encoding
4852import GHCJS.DOM.Types (runJSM, askJSM, MonadJSM, liftJSM, JSM)
53+import GHCJS.Marshal
54+import qualified Language.Javascript.JSaddle as JS (jsg, js1)
4955import qualified Language.Javascript.JSaddle.Monad as JS (catch)
5056
57+#ifdef ghcjs_HOST_OS
58+import GHCJS.DOM.Types ()
59+import System.IO.Unsafe
60+#else
61+import Data.JSString.Text
62+import qualified Data.ByteString.Lazy as LBS
63+#endif
64+-- When on ghcjs and using packages with jsstring patches it removes the FromJSVal
65+-- instance for Value from ghcjs-base. This makes it so that if the patches
66+-- are used then the instance comes from ghcjs-json
67+#if defined(ghcjs_HOST_OS) && defined(USE_TEXT_JSSTRING)
68+import JavaScript.JSON.Types.FromJSVal ()
69+#endif
70+
5171data WebSocketConfig t a
5272 = WebSocketConfig { _webSocketConfig_send :: Event t [a]
5373 , _webSocketConfig_close :: Event t (Word, Text)
@@ -122,6 +142,32 @@ webSocket' url config onRawMessage = do
122142 unless success $ atomically $ unGetTQueue payloadQueue payload
123143 return $ RawWebSocket eRecv eOpen eError eClose
124144
145+textWebSocket :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t) => Text -> WebSocketConfig t Text -> m (RawWebSocket t Text)
146+textWebSocket url cfg = webSocket' url cfg (either (return . decodeUtf8) fromJSValUnchecked)
147+
148+-- | Deserialize a JSON value from a JSString.
149+-- When on ghcjs it uses JSON.parse which is usually faster than using aeson's decode to get a Value
150+-- When on ghc the JSString is converted to Text and then to ByteString in order to use aeson's decode
151+jsonDecode :: FromJSON a => JSString -> Maybe a
152+jsonDecode t = do
153+#ifdef ghcjs_HOST_OS
154+ result <- unsafePerformIO $ handle (\(_ :: SomeException) -> pure Nothing) $ do
155+ safeJsonParse t >>= \case
156+ Nothing -> pure Nothing
157+ Just a -> fromJSVal a
158+ case fromJSON result of
159+ Success a -> pure a
160+ Error _ -> Nothing
161+#else
162+ decode $ LBS.fromStrict $ encodeUtf8 $ textFromJSString t
163+#endif
164+
165+safeJsonParse :: JSString -> JSM (Maybe JSVal)
166+safeJsonParse a = (Just <$> jsonParse a) `JS.catch` \(_ :: SomeException) -> return Nothing
167+
168+jsonParse :: JSString -> JSM JSVal
169+jsonParse a = JS.jsg "JSON" ^. JS.js1 "parse" a
170+
125171#ifdef USE_TEMPLATE_HASKELL
126172makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig
127173makeLensesWith (lensRules & simpleLenses .~ True) ''RawWebSocket