53 lines
1.5 KiB
Haskell
53 lines
1.5 KiB
Haskell
|
module WebSocket (broadcast, initMVarState, runWebSocketServer, ServerState, Client) where
|
||
|
|
|
||
|
|
import ClassyPrelude
|
||
|
|
import Network.WebSockets qualified as WS
|
||
|
|
|
||
|
|
type Client = (Text, WS.Connection)
|
||
|
|
|
||
|
|
type ServerState = [Client]
|
||
|
|
|
||
|
|
addClient :: Client -> ServerState -> ServerState
|
||
|
|
addClient client clients = client : clients
|
||
|
|
|
||
|
|
removeClient :: Client -> ServerState -> ServerState
|
||
|
|
removeClient client = filter ((/= fst client) . fst)
|
||
|
|
|
||
|
|
newServerState :: ServerState
|
||
|
|
newServerState = []
|
||
|
|
|
||
|
|
broadcast :: Text -> ServerState -> IO ()
|
||
|
|
broadcast message clients = do
|
||
|
|
putStrLn message
|
||
|
|
forM_ clients $ \(_, conn) -> WS.sendTextData conn message
|
||
|
|
|
||
|
|
initMVarState :: IO (MVar ServerState)
|
||
|
|
initMVarState = newMVar newServerState
|
||
|
|
|
||
|
|
runWebSocketServer :: MVar ServerState -> IO ()
|
||
|
|
runWebSocketServer state = do
|
||
|
|
WS.runServer "127.0.0.1" 9160 $ webSocketApplication state
|
||
|
|
|
||
|
|
webSocketApplication :: MVar ServerState -> WS.ServerApp
|
||
|
|
webSocketApplication state pending = do
|
||
|
|
putStrLn "pending request"
|
||
|
|
conn <- WS.acceptRequest pending
|
||
|
|
WS.withPingThread conn 30 (return ()) $ do
|
||
|
|
msg <- WS.receiveData conn
|
||
|
|
putStrLn msg
|
||
|
|
let client = ("hall", conn)
|
||
|
|
flip finally (disconnect client) $ do
|
||
|
|
modifyMVar_ state $ \s -> do
|
||
|
|
let s' = addClient client s
|
||
|
|
return s'
|
||
|
|
forever $ do
|
||
|
|
currentMsg <- WS.receiveData conn
|
||
|
|
putStrLn currentMsg
|
||
|
|
where
|
||
|
|
disconnect client = do
|
||
|
|
putStrLn "disconnect"
|
||
|
|
modifyMVar state $ \s ->
|
||
|
|
let s' = removeClient client s
|
||
|
|
in return
|
||
|
|
(s', s')
|