@@ -0,0 +1,53 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RecursiveDo #-}
5+#ifdef ghcjs_HOST_OS
6+{-# LANGUAGE ForeignFunctionInterface #-}
7+{-# LANGUAGE JavaScriptFFI #-}
8+#endif
9+module Reflex.Dom.WebSocket.Query (runQuery, runWebSocketQuery) where
10+
11+import Data.Default
12+import Control.Monad.Fix
13+import qualified Data.ByteString.Lazy as LBS
14+import Data.Text (Text)
15+import Data.Text.Encoding
16+import Data.Aeson
17+import Reflex
18+import Reflex.Dom.WebSocket
19+import Foreign.JavaScript.TH
20+import Data.Maybe
21+import Data.JSString.Text
22+import Language.Javascript.JSaddle.Types (MonadJSM)
23+
24+runWebSocketQuery :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t, ToJSON q, MonadFix m, Query q, FromJSON (QueryResult q), Additive q, Group q, Eq q)
25+ => Text
26+ -> QueryT t q m a
27+ -> m a
28+runWebSocketQuery url app = do
29+ rec ws <- textWebSocket url $ def { _webSocketConfig_send = pure . decodeUtf8 . LBS.toStrict . encode <$> reqE }
30+ let notifications = fromMaybe mempty . jsonDecode . textToJSString <$> _webSocket_recv ws
31+ (a, reqE) <- runQuery notifications app
32+ return a
33+
34+runQuery :: (MonadHold t m, PostBuild t m, MonadFix m, Query q, Additive q, Group q, Eq q)
35+ => Event t (QueryResult q)
36+ -> QueryT t q m a
37+ -> m (a, Event t q)
38+runQuery notifications app = do
39+ postBuild <- getPostBuild
40+ rec (a, requestPatch) <- runQueryT app e
41+ requestUniq <- holdUniqDyn $ incrementalToDynamic requestPatch
42+ e <- fromNotifications requestUniq notifications
43+ let request = leftmost
44+ [ updated requestUniq
45+ , tag (current requestUniq) postBuild
46+ ]
47+ return (a, request)
48+
49+fromNotifications :: (Query q, MonadHold t m, Reflex t, MonadFix m)
50+ => Dynamic t q
51+ -> Event t (QueryResult q)
52+ -> m (Dynamic t (QueryResult q))
53+fromNotifications q = foldDyn (\(q', qr) v -> crop q' (qr `mappend` v)) mempty . attach (current q)