module Test.WebSockets.Simple where
import Network.WebSockets.Simple (WebSocketsApp (..), WebSocketsAppParams (..))
import Control.Monad (forever, void)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Concurrent.Async (Async, async)
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TChan (TChan, newTChanIO, writeTChan, readTChan)
runConnected :: forall send receive m
. ( MonadIO m
, MonadBaseControl IO m
)
=> WebSocketsApp send receive m
-> WebSocketsApp receive send m
-> m (Async (), Async (), TChan send, TChan receive)
runConnected sendsSreceivesR sendsRreceivesS = do
(sendChan, receiveChan) <- liftIO $ (,) <$> newTChanIO <*> newTChanIO
let sendToSend :: send -> m ()
sendToSend s = liftIO $ atomically $ writeTChan sendChan s
sendToReceive :: receive -> m ()
sendToReceive r = liftIO $ atomically $ writeTChan receiveChan r
close :: m ()
close = do
onClose sendsRreceivesS Nothing
onClose sendsSreceivesR Nothing
sToR <- liftBaseWith $ \runInBase -> async $ forever $ do
s <- atomically $ readTChan sendChan
void $ runInBase $ onReceive sendsRreceivesS WebSocketsAppParams
{ send = sendToReceive
, close
} s
rToS <- liftBaseWith $ \runInBase -> async $ forever $ do
r <- atomically $ readTChan receiveChan
void $ runInBase $ onReceive sendsSreceivesR WebSocketsAppParams
{ send = sendToSend
, close
} r
onOpen sendsRreceivesS WebSocketsAppParams
{ send = sendToReceive
, close
}
onOpen sendsSreceivesR WebSocketsAppParams
{ send = sendToSend
, close
}
pure (sToR,rToS,sendChan,receiveChan)