@@ -1,50 +1,38 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE FlexibleContexts #-}
32{-# LANGUAGE OverloadedStrings #-}
43{-# LANGUAGE RecursiveDo #-}
5−module Reflex.Dom.WebSocket.Query (runQuery, runWebSocketQuery) where
4+module Reflex.Dom.WebSocket.Query (cropQueryT, runWebSocketQuery) where
65
76import Data.Default
87import Control.Monad.Fix
9−import qualified Data.ByteString.Lazy as LBS
108import Data.Text (Text)
11−import Data.Text.Encoding
129import Data.Aeson
1310import Reflex
1411import Reflex.Dom.WebSocket
15−import Reflex.Dom.WebSocket.Internal
1612import Foreign.JavaScript.TH
1713import Data.Maybe
18−import Data.JSString.Text
1914import Language.Javascript.JSaddle.Types (MonadJSM)
2015
2116runWebSocketQuery :: (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)
22− => Text
23− -> QueryT t q m a
24− -> m a
25−runWebSocketQuery url app = do
26− rec ws <- textWebSocket url $ def { _webSocketConfig_send = pure . decodeUtf8 . LBS.toStrict . encode <$> reqE }
27− let notifications = fromMaybe mempty . jsonDecode . textToJSString <$> _webSocket_recv ws
28− (a, reqE) <- runQuery notifications app
17+ => QueryT t q m a
18+ -> Text -- ^ WebSocket url
19+ -> m a
20+runWebSocketQuery app url = do
21+ postBuild <- getPostBuild
22+ rec ws <- jsonWebSocket url $ def { _webSocketConfig_send = pure <$> updatedRequest }
23+ (a, request) <- cropQueryT app $ fromMaybe mempty <$> _webSocket_recv ws
24+ let updatedRequest = leftmost [updated request, tag (current request) postBuild]
2925 return a
3026
31−runQuery :: (MonadHold t m, PostBuild t m, MonadFix m, Query q, Additive q, Group q, Eq q)
32− => Event t (QueryResult q)
33− -> QueryT t q m a
34− -> m (a, Event t q)
35−runQuery notifications app = do
36− postBuild <- getPostBuild
37− rec (a, requestPatch) <- runQueryT app e
27+cropQueryT :: (Reflex t, MonadHold t m, MonadFix m, Query q, Additive q, Group q, Eq q)
28+ => QueryT t q m a
29+ -> Event t (QueryResult q)
30+ -> m (a, Dynamic t q)
31+cropQueryT app result = do
32+ rec (a, requestPatch) <- runQueryT app croppedResult
3833 requestUniq <- holdUniqDyn $ incrementalToDynamic requestPatch
39− e <- fromNotifications requestUniq notifications
40− let request = leftmost
41− [ updated requestUniq
42− , tag (current requestUniq) postBuild
43− ]
44− return (a, request)
34+ croppedResult <- cropDyn requestUniq result
35+ return (a, requestUniq)
4536
46−fromNotifications :: (Query q, MonadHold t m, Reflex t, MonadFix m)
47− => Dynamic t q
48− -> Event t (QueryResult q)
49− -> m (Dynamic t (QueryResult q))
50−fromNotifications q = foldDyn (\(q', qr) v -> crop q' (qr `mappend` v)) mempty . attach (current q)
37+cropDyn :: (Query q, MonadHold t m, Reflex t, MonadFix m) => Dynamic t q -> Event t (QueryResult q) -> m (Dynamic t (QueryResult q))
38+cropDyn q = foldDyn (\(q', qr) v -> crop q' (qr `mappend` v)) mempty . attach (current q)