73 lines
2.7 KiB
Haskell
73 lines
2.7 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Forest.Client.Websocket
|
|
( Event(..)
|
|
, runWithEventChan
|
|
) where
|
|
|
|
import Brick.BChan
|
|
import Control.Exception
|
|
import qualified Network.WebSockets as WS
|
|
import qualified Wuss as WSS
|
|
|
|
import Forest.Api
|
|
import Forest.Client.Options
|
|
import Forest.Node
|
|
import Forest.Util
|
|
|
|
data Event
|
|
= EventNode Node
|
|
| EventConnectionClosed
|
|
|
|
performInitialContact :: WS.Connection -> IO Node
|
|
performInitialContact conn = do
|
|
-- First, the client must send a hello packet containing the protocol
|
|
-- extensions it requests.
|
|
sendPacket conn $ ClientHello []
|
|
-- Then, the server must reply with a hello packet containing the extensions
|
|
-- that will be active for this connection, and an initial node.
|
|
serverReply <- receivePacket conn
|
|
case serverReply of
|
|
(ServerHello [] node) -> pure node
|
|
-- Since the client never requests any protocol extensions, the server must
|
|
-- also reply with an empty list of extensions.
|
|
(ServerHello _ _) -> closeWithErrorMessage conn "Invalid protocol extensions"
|
|
_ -> closeWithErrorMessage conn "Invalid packet: Expected hello"
|
|
|
|
receiveUpdates :: BChan Event -> Node -> WS.Connection -> IO ()
|
|
receiveUpdates eventChan node conn = do
|
|
packet <- receivePacket conn
|
|
case packet of
|
|
ServerUpdate path subnode -> do
|
|
let node' = replaceAt subnode path node
|
|
writeBChan eventChan $ EventNode node'
|
|
receiveUpdates eventChan node' conn -- Aaand close the loop :D
|
|
_ -> closeWithErrorMessage conn "Invalid packet: Expected update"
|
|
|
|
runCorrectClient :: ClientOptions -> WS.ClientApp a -> IO a
|
|
runCorrectClient opts app
|
|
| ssl = WSS.runSecureClient name (fromInteger $ toInteger port) path app
|
|
| otherwise = WS.runClient name port path app
|
|
where
|
|
-- I found this nicer to read than (ab-)using record syntax in the arguments
|
|
name = clientHostName opts
|
|
port = clientPort opts
|
|
path = clientPath opts
|
|
ssl = clientSsl opts
|
|
|
|
sendCloseEvent :: BChan Event -> SomeException -> IO ()
|
|
sendCloseEvent eventChan e = do
|
|
putStrLn $ "Encountered exception: " ++ show e
|
|
writeBChan eventChan EventConnectionClosed
|
|
|
|
runWithEventChan :: ClientOptions -> (WS.Connection -> BChan Event -> Node -> IO ()) -> IO ()
|
|
runWithEventChan opts f = do
|
|
putStrLn "Connecting to server"
|
|
runCorrectClient opts $ \conn -> do
|
|
putStrLn "Performing initialization ritual"
|
|
node <- performInitialContact conn
|
|
chan <- newBChan 100
|
|
putStrLn "Starting WS thread"
|
|
let wsThread = handle (sendCloseEvent chan) $ receiveUpdates chan node conn
|
|
withThread wsThread $ f conn chan node
|
|
putStrLn "Connection closed and UI stopped"
|