git.iko.soy/reflex-dom
on 76ef430 help sign in
reflex-dom/src/Reflex/Dom/WebSocket.hs
127 lines 5.4 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.Dom.WebSocket.Foreign
29import Reflex.PerformEvent.Class
30import Reflex.PostBuild.Class
31import Reflex.TriggerEvent.Class
33import Control.Concurrent
34import Control.Concurrent.STM
35import Control.Exception (SomeException, catch)
36import Control.Lens
37import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
38import Control.Monad.IO.Class
39import Control.Monad.State
40import Data.ByteString (ByteString)
41import Data.Default
42import Data.IORef
43import Data.Maybe (isJust)
44import Data.Text
46data WebSocketConfig t a
47 = WebSocketConfig { _webSocketConfig_send :: Event t [a]
48 , _webSocketConfig_close :: Event t (Word, Text)
49 , _webSocketConfig_reconnect :: Bool
50 }
52instance Reflex t => Default (WebSocketConfig t a) where
53 def = WebSocketConfig never never True
55type WebSocket t = RawWebSocket t ByteString
57data RawWebSocket t a
58 = RawWebSocket { _webSocket_recv :: Event t a
59 , _webSocket_open :: Event t ()
60 , _webSocket_error :: Event t () -- eror event does not carry any data and is always
61 -- followed by termination of the connection
62 -- for details see the close event
63 , _webSocket_close :: Event t ( Bool -- wasClean
64 , Word -- code
65 , Text -- reason
66 )
67 }
69-- This can be used to send either binary or text messages for the same websocket connection
70instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Either a b) where
71 webSocketSend jws (Left a) = webSocketSend jws a
72 webSocketSend jws (Right a) = webSocketSend jws a
75webSocket :: (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)
76webSocket url config = webSocket' url config onBSMessage
78webSocket' :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> (Either ByteString JSVal -> b) -> m (RawWebSocket t b)
79webSocket' url config onRawMessage = do
80 wv <- fmap unWebViewSingleton askWebView
81 (eRecv, onMessage) <- newTriggerEvent
82 currentSocketRef <- liftIO $ newIORef Nothing
83 (eOpen, triggerEOpen) <- newTriggerEventWithOnComplete
84 (eError, triggerEError) <- newTriggerEvent
85 (eClose, triggerEClose) <- newTriggerEvent
86 payloadQueue <- liftIO newTQueueIO
87 isOpen <- liftIO newEmptyTMVarIO
88 let onOpen = triggerEOpen () $ liftIO $ void $ atomically $ tryPutTMVar isOpen ()
89 onError = triggerEError ()
90 onClose args = do
91 triggerEClose args
92 --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?
93 void $ forkIO $ do
94 _ <- liftIO $ atomically $ tryTakeTMVar isOpen
95 liftIO $ writeIORef currentSocketRef Nothing
96 when (_webSocketConfig_reconnect config) $ do
97 liftIO $ threadDelay 1000000
98 start
99 start = do
100 ws <- liftIO $ newWebSocket wv url (onMessage . onRawMessage) onOpen onError onClose
101 liftIO $ writeIORef currentSocketRef $ Just ws
102 return ()
103 performEvent_ . (liftIO start <$) =<< getPostBuild
104 performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload ->
105 liftIO $ atomically $ writeTQueue payloadQueue payload
106 performEvent_ $ ffor (_webSocketConfig_close config) $ \(code,reason) -> liftIO $ do
107 mws <- readIORef currentSocketRef
108 case mws of
109 Nothing -> return ()
110 Just ws -> closeWebSocket ws (fromIntegral code) reason
112 _ <- liftIO $ forkIO $ forever $ do
113 payload <- atomically $ do
114 pl <- readTQueue payloadQueue
115 open <- tryReadTMVar isOpen
116 if isJust open then return pl else retry
118 mws <- liftIO $ readIORef currentSocketRef
119 success <- case mws of
120 Nothing -> return False
121 Just ws -> liftIO ((webSocketSend ws payload >> return True)
122 `catch`
123 (\(_ :: SomeException) -> return False))
124 unless success $ atomically $ unGetTQueue payloadQueue payload
125 return $ RawWebSocket eRecv eOpen eError eClose
127makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig