git.iko.soy/reflex-dom
on 4c028dc help sign in
reflex-dom/src/Reflex/Dom/WebSocket.hs
103 lines 3.9 kB history raw
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE EmptyDataDecls #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE ForeignFunctionInterface #-}
8{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE JavaScriptFFI #-}
11{-# LANGUAGE MultiParamTypeClasses #-}
12{-# LANGUAGE NoMonomorphismRestriction #-}
13{-# LANGUAGE PolyKinds #-}
14{-# LANGUAGE RankNTypes #-}
15{-# LANGUAGE RecursiveDo #-}
16{-# LANGUAGE ScopedTypeVariables #-}
17{-# LANGUAGE StandaloneDeriving #-}
18{-# LANGUAGE TemplateHaskell #-}
19{-# LANGUAGE TypeFamilies #-}
20{-# LANGUAGE UndecidableInstances #-}
22module Reflex.Dom.WebSocket where
24import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)
26import Reflex.Class
27import Reflex.Dom.Class
28import Reflex.PerformEvent.Class
29import Reflex.PostBuild.Class
30import Reflex.Dom.WebSocket.Foreign
32import Control.Concurrent
33import Control.Concurrent.STM
34import Control.Exception (SomeException, catch)
35import Control.Lens
36import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
37import Control.Monad.IO.Class
38import Control.Monad.State
39import Data.ByteString (ByteString)
40import Data.Default
41import Data.IORef
42import Data.Maybe (isJust)
43import Data.Text
45data WebSocketConfig t a
46 = WebSocketConfig { _webSocketConfig_send :: Event t [a]
47 }
49instance Reflex t => Default (WebSocketConfig t a) where
50 def = WebSocketConfig never
52data WebSocket t
53 = WebSocket { _webSocket_recv :: Event t ByteString
54 , _webSocket_open :: Event t ()
55 }
57-- This can be used to send either binary or text messages for the same websocket connection
58instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Either a b) where
59 webSocketSend jws (Left a) = webSocketSend jws a
60 webSocketSend jws (Right a) = webSocketSend jws a
63webSocket :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> m (WebSocket t)
64webSocket url config = do
65 wv <- fmap unWebViewSingleton askWebView
66 (eRecv, onMessage) <- newTriggerEvent
67 currentSocketRef <- liftIO $ newIORef Nothing
68 --TODO: Disconnect if value no longer needed
69 (eOpen, triggerEOpen) <- newTriggerEventWithOnComplete
70 payloadQueue <- liftIO newTQueueIO
71 isOpen <- liftIO newEmptyTMVarIO
72 let onOpen = triggerEOpen () $ do
73 liftIO $ void $ atomically $ tryPutTMVar isOpen ()
74 --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?
75 onClose = void $ forkIO $ do
76 _ <- liftIO $ atomically $ tryTakeTMVar isOpen
77 liftIO $ writeIORef currentSocketRef Nothing
78 liftIO $ threadDelay 1000000
79 start
80 start = do
81 ws <- liftIO $ newWebSocket wv url onMessage onOpen onClose
82 liftIO $ writeIORef currentSocketRef $ Just ws
83 return ()
84 performEvent_ . (liftIO start <$) =<< getPostBuild
85 performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload ->
86 liftIO $ atomically $ writeTQueue payloadQueue payload
88 _ <- liftIO $ forkIO $ forever $ do
89 payload <- atomically $ do
90 pl <- readTQueue payloadQueue
91 open <- tryReadTMVar isOpen
92 if isJust open then return pl else retry
94 mws <- liftIO $ readIORef currentSocketRef
95 success <- case mws of
96 Nothing -> return False
97 Just ws -> liftIO ((webSocketSend ws payload >> return True)
98 `catch`
99 (\(_ :: SomeException) -> return False))
100 unless success $ atomically $ unGetTQueue payloadQueue payload
101 return $ WebSocket eRecv eOpen
103makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig