aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--server/lib/Cafp/Main/Server.hs16
1 files changed, 12 insertions, 4 deletions
diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs
index 9ded571..799f26e 100644
--- a/server/lib/Cafp/Main/Server.hs
+++ b/server/lib/Cafp/Main/Server.hs
@@ -97,19 +97,27 @@ getOrCreateRoom server roomId = MVar.modifyMVar (serverRooms server) $ \rooms ->
Just room -> pure (rooms, room)
Nothing -> do
gen <- newStdGen
+ warning $ "[" <> T.unpack roomId <> "] Created room"
room <- atomically $ newRoom server gen
pure (HMS.insert roomId room rooms, room)
+deleteRoom :: Server -> RoomId -> IO ()
+deleteRoom server roomId = do
+ warning $ "[" <> T.unpack roomId <> "] Deleting room"
+ MVar.modifyMVar_ (serverRooms server) $ pure . HMS.delete roomId
+
joinRoom :: Room -> Sink -> STM PlayerId
joinRoom room sink = do
pid <- STM.stateTVar (roomGame room) joinGame
STM.modifyTVar' (roomSinks room) $ HMS.insert pid sink
pure pid
-leaveRoom :: Room -> PlayerId -> STM ()
+leaveRoom :: Room -> PlayerId -> STM Bool
leaveRoom room pid = do
STM.modifyTVar' (roomGame room) $ leaveGame pid
- STM.modifyTVar' (roomSinks room) $ HMS.delete pid
+ STM.stateTVar (roomSinks room) $ \sinks ->
+ let sinks' = HMS.delete pid sinks in
+ (HMS.null sinks', sinks')
syncRoom :: Room -> IO ()
syncRoom room = do
@@ -131,8 +139,8 @@ wsApp server pc = case routePendingConnection pc of
WS.withPingThread conn 30 (pure ()) $ bracket
(atomically $ joinRoom room sink)
(\playerId -> do
- atomically $ leaveRoom room playerId
- syncRoom room)
+ roomEmpty <- atomically $ leaveRoom room playerId
+ if roomEmpty then deleteRoom server roomId else syncRoom room)
(\playerId -> do
syncRoom room
cards <- fmap (^. gameCards) . atomically . STM.readTVar $