git.iko.soy/reflex-dom
on develop help sign in
Add websocket variant that works with Text instead of ByteString.
67d217eLuigy Leon
reflex-dom-core/reflex-dom-core.cabal+10
compare with develop
unifiedsplit
@@ -38,6 +38,11 @@ flag profile-reflex
38 default: False
38 default: False
39 manual: True
39 manual: True
40
40
41+flag use-text-jsstring
42+ description: Defines an identifier to determine if the package is being built with text-jsstring patched packages
43+ default: False
44+ manual: True
45+
41library
46library
42 hs-source-dirs: src
47 hs-source-dirs: src
43 build-depends:
48 build-depends:
@@ -83,6 +88,11 @@ library
83 if !os(windows)
88 if !os(windows)
84 build-depends: unix == 2.7.*
89 build-depends: unix == 2.7.*
85
90
91+ if impl(ghcjs) && flag(use-text-jsstring)
92+ build-depends:
93+ ghcjs-json
94+ cpp-options: -DUSE_TEXT_JSSTRING
95+
86 exposed-modules:
96 exposed-modules:
87 Foreign.JavaScript.TH
97 Foreign.JavaScript.TH
88 Foreign.JavaScript.Orphans
98 Foreign.JavaScript.Orphans
reflex-dom-core/src/Reflex/Dom/WebSocket.hs+47−1
@@ -9,6 +9,7 @@
9{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GADTs #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE JavaScriptFFI #-}
11{-# LANGUAGE JavaScriptFFI #-}
12+{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE MultiParamTypeClasses #-}
13{-# LANGUAGE MultiParamTypeClasses #-}
13{-# LANGUAGE NoMonomorphismRestriction #-}
14{-# LANGUAGE NoMonomorphismRestriction #-}
14{-# LANGUAGE PolyKinds #-}
15{-# LANGUAGE PolyKinds #-}
@@ -35,19 +36,38 @@ import Reflex.TriggerEvent.Class
35
36
36import Control.Concurrent
37import Control.Concurrent
37import Control.Concurrent.STM
38import Control.Concurrent.STM
38−import Control.Exception (SomeException)
39+import Control.Exception
39import Control.Lens
40import Control.Lens
40import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
41import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
41import Control.Monad.IO.Class
42import Control.Monad.IO.Class
42import Control.Monad.State
43import Control.Monad.State
44+import Data.Aeson hiding (json)
43import Data.ByteString (ByteString)
45import Data.ByteString (ByteString)
44import Data.Default
46import Data.Default
45import Data.IORef
47import Data.IORef
48+import Data.JSString (JSString)
46import Data.Maybe (isJust)
49import Data.Maybe (isJust)
47import Data.Text
50import Data.Text
51+import Data.Text.Encoding
48import GHCJS.DOM.Types (runJSM, askJSM, MonadJSM, liftJSM, JSM)
52import GHCJS.DOM.Types (runJSM, askJSM, MonadJSM, liftJSM, JSM)
53+import GHCJS.Marshal
54+import qualified Language.Javascript.JSaddle as JS (jsg, js1)
49import qualified Language.Javascript.JSaddle.Monad as JS (catch)
55import qualified Language.Javascript.JSaddle.Monad as JS (catch)
50
56
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+
51data WebSocketConfig t a
71data WebSocketConfig t a
52 = WebSocketConfig { _webSocketConfig_send :: Event t [a]
72 = WebSocketConfig { _webSocketConfig_send :: Event t [a]
53 , _webSocketConfig_close :: Event t (Word, Text)
73 , _webSocketConfig_close :: Event t (Word, Text)
@@ -122,6 +142,32 @@ webSocket' url config onRawMessage = do
122 unless success $ atomically $ unGetTQueue payloadQueue payload
142 unless success $ atomically $ unGetTQueue payloadQueue payload
123 return $ RawWebSocket eRecv eOpen eError eClose
143 return $ RawWebSocket eRecv eOpen eError eClose
124
144
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+
125#ifdef USE_TEMPLATE_HASKELL
171#ifdef USE_TEMPLATE_HASKELL
126makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig
172makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig
127makeLensesWith (lensRules & simpleLenses .~ True) ''RawWebSocket
173makeLensesWith (lensRules & simpleLenses .~ True) ''RawWebSocket