102 lines
4.1 KiB
Haskell
102 lines
4.1 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module WebSocketApp (newServerState, ServerState) where
|
|
|
|
-- Maybe strict MVar?? but then we need NFData instenaces for TickLeiste
|
|
import Control.Concurrent.MVar
|
|
import Control.Exception
|
|
import Data.Aeson.TickLeiste
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import qualified Data.Text as T
|
|
import qualified Data.TickLeiste as TL
|
|
import qualified Data.UUID as U
|
|
import qualified Data.UUID.V4 as U
|
|
import qualified Network.WebSockets as WS
|
|
import System.IO
|
|
|
|
----------------------------------------------------------------------------------
|
|
------------------------ NEVER USE putMVar OR takeMVar ---------------------------
|
|
----------------------------------------------------------------------------------
|
|
|
|
-- if use ask yourself why this warning above me exists, this code relies upon the
|
|
-- atomicity of modifyMVar, which is only the case if no one produces MVar. It is
|
|
-- realy easy to archive this using putMVar. So not using it will make reasoning
|
|
-- about the code much simpler. takeMVar on the other hand may produce deadlocks
|
|
-- as an MVar is gone and nobody will produce a new one.
|
|
-- putMVar and takeMVar are not evil in general, but it contradicts the way this
|
|
-- code uses MVar to synchronize.
|
|
-- In theory you could write fine code using them, but then you need to make sure
|
|
-- to use them as a pair and mask yourself from asynchronous exceptions. But
|
|
-- that is basically a reimplementation of modifyMVar
|
|
|
|
-- maybe this should be T.Text instead, but right now I try
|
|
-- to get away without the need of parsing the request Path
|
|
-- in any way. If we need, then we should probably change this to T.Text
|
|
type SessionId = B.ByteString
|
|
|
|
-- we only use the uuids here, because 'WS.WS.Connection' has no Eq, and we need
|
|
-- to delete clients
|
|
type Client = (U.UUID, WS.Connection)
|
|
|
|
type SessionState = (TL.TickLeiste, [Client], Integer)
|
|
|
|
type ServerState = M.Map SessionId (MVar SessionState)
|
|
|
|
newServerState :: ServerState
|
|
newServerState = M.empty
|
|
|
|
application :: MVar ServerState -> WS.ServerApp
|
|
application ssMV pending = do
|
|
-- maybe we want to check that the Path has a maximum length or something
|
|
let requestPath = WS.requestPath $ WS.pendingRequest pending
|
|
if B.null requestPath
|
|
then do
|
|
-- TODO reject Body should probably not empty...
|
|
-- this may need a better logic
|
|
WS.rejectRequestWith pending WS.defaultRejectRequest
|
|
else do
|
|
conn <- WS.acceptRequest pending
|
|
WS.withPingThread conn 30 (return ()) $ do
|
|
clientUUID <- U.nextRandom
|
|
bracket
|
|
(addClient requestPath (clientUUID, conn) ssMV)
|
|
(const $ removeClient requestPath (clientUUID, conn) ssMV)
|
|
(eventHandler conn)
|
|
|
|
eventHandler :: WS.Connection -> MVar SessionState -> IO ()
|
|
eventHandler = undefined
|
|
|
|
addClient :: SessionId -> Client -> MVar ServerState -> IO (MVar SessionState)
|
|
addClient sessionId client serverStateMVar = modifyMVar serverStateMVar $ \serverState ->
|
|
maybe
|
|
( do
|
|
let sessionState = (TL.newTickLeiste, [client], 1)
|
|
sessionStateMVar <- newMVar sessionState
|
|
let serverState' = M.insert sessionId sessionStateMVar serverState
|
|
return (serverState', sessionStateMVar)
|
|
)
|
|
( \sessionStateMVar -> do
|
|
modifyMVar_ sessionStateMVar (\(tl, cls, sem) -> return (tl, client : cls, sem + 1))
|
|
return (serverState, sessionStateMVar)
|
|
)
|
|
(serverState M.!? sessionId)
|
|
|
|
removeClient :: SessionId -> Client -> MVar ServerState -> IO ()
|
|
removeClient sessionId client serverStateMVar = modifyMVar_ serverStateMVar $ \serverState ->
|
|
maybe
|
|
( do
|
|
hPutStrLn stderr "Tried to remove client, but the session didn't exist anymore, THIS IS A BUG"
|
|
return serverState
|
|
)
|
|
( \sessionStateMVar -> do
|
|
modifyMVar sessionStateMVar $ \(tl, cls, sem) -> do
|
|
let sem' = sem - 1
|
|
removedClient = (tl, filter ((/= fst client) . fst) cls, sem')
|
|
if sem - 1 == 0
|
|
then return (removedClient, sessionId `M.delete` serverState)
|
|
else do
|
|
return (removedClient, serverState)
|
|
)
|
|
(serverState M.!? sessionId)
|