git.iko.soy/reflex-dom
on c83487e help sign in
reflex-dom/src/Reflex/Dom/WebSocket.hs
68 lines 2.9 kB history raw
1{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}
3module Reflex.Dom.WebSocket where
5import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)
7import Reflex
8import Reflex.Host.Class
9import Reflex.Dom.Class
10import Reflex.Dom.WebSocket.Foreign
12import Control.Concurrent
13import Control.Lens
14import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
15import Control.Monad.IO.Class
16import Control.Monad.Ref
17import Control.Monad.State
18import Data.ByteString (ByteString)
19import Data.Default
20import Data.Dependent.Map (DSum (..))
21import Data.IORef
23data WebSocketConfig t
24 = WebSocketConfig { _webSocketConfig_send :: Event t [ByteString]
25 }
27instance Reflex t => Default (WebSocketConfig t) where
28 def = WebSocketConfig never
30data WebSocket t
31 = WebSocket { _webSocket_recv :: Event t ByteString
32 , _webSocket_open :: Event t ()
33 }
35webSocket :: forall t m. (HasWebView m, MonadWidget t m) => String -> WebSocketConfig t -> m (WebSocket t)
36webSocket url config = do
37 wv <- askWebView
38 postGui <- askPostGui
39 runWithActions <- askRunWithActions
40 (eRecv, eRecvTriggerRef) <- newEventWithTriggerRef
41 currentSocketRef <- liftIO $ newIORef Nothing
42 --TODO: Disconnect if value no longer needed
43 (eOpen, eOpenTriggerRef) <- newEventWithTriggerRef
44 let onMessage :: ByteString -> IO ()
45 onMessage m = postGui $ do
46 mt <- readRef eRecvTriggerRef
47 forM_ mt $ \t -> runWithActions [t :=> Identity m]
48 onOpen = postGui $ do
49 mt <- readRef eOpenTriggerRef
50 forM_ mt $ \t -> runWithActions [t :=> Identity ()]
51 start = do
52 ws <- liftIO $ newWebSocket wv url onMessage onOpen $ do
53 void $ forkIO $ do --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?
54 liftIO $ writeIORef currentSocketRef Nothing
55 liftIO $ threadDelay 1000000
56 start
57 liftIO $ writeIORef currentSocketRef $ Just ws
58 return ()
59 schedulePostBuild $ liftIO start
60 performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload -> do
61 mws <- liftIO $ readIORef currentSocketRef
62 case mws of
63 Nothing -> return () -- Discard --TODO: should we do something better here? probably buffer it, since we handle reconnection logic; how do we verify that the server has received things?
64 Just ws -> do
65 liftIO $ webSocketSend ws payload
66 return $ WebSocket eRecv eOpen
68makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig