diff options
| -rw-r--r-- | server/lib/Cafp/Game.hs | 18 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/Server.hs | 66 |
2 files changed, 52 insertions, 32 deletions
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs index 96b24dc..2df1ee5 100644 --- a/server/lib/Cafp/Game.hs +++ b/server/lib/Cafp/Game.hs @@ -8,7 +8,7 @@ module Cafp.Game , Table (..) , Player (..) , Game (..) - , gameCards, gamePlayers, gameNextPlayerId + , gameLog, gameCards, gamePlayers, gameNextPlayerId , newGame , joinGame @@ -70,6 +70,7 @@ data Player = Player data Game = Game { _gameCards :: !Cards , _gameSeed :: !StdGen + , _gameLog :: ![Text] , _gameBlack :: ![BlackCard] , _gameWhite :: ![WhiteCard] , _gamePlayers :: !(HMS.HashMap PlayerId Player) @@ -108,6 +109,7 @@ newGame cards gen = flip execState state0 $ do state0 = Game { _gameCards = cards , _gameSeed = gen + , _gameLog = [] , _gameBlack = [] , _gameWhite = [] , _gamePlayers = HMS.empty @@ -191,6 +193,19 @@ tallyVotes game shuffled votes = where byScore = V.modify $ V.sortBy . comparing $ Down . votedScore +-- | Create nice messages about the winners in the logs. +votedMessages :: Cards -> BlackCard -> V.Vector VotedView -> [T.Text] +votedMessages cards (BlackCard black) voteds = do + voted <- V.toList voteds + guard $ V.length (votedWinners voted) > 0 + pure $ + T.intercalate ", " (V.toList $ votedWinners voted) <> " won with " <> + cardsBlack cards V.! black <> " | " <> + T.intercalate " / " + [ cardsWhite cards V.! i + | WhiteCard i <- V.toList $ votedProposal voted + ] + stepGame :: Game -> Game stepGame game = case game ^. gameTable of TableProposing black proposals @@ -218,6 +233,7 @@ stepGame game = case game ^. gameTable of flip execState game $ do for_ wins $ \win -> gamePlayers . ix win . playerPoints += 1 gameTable .= TableTally black voted + gameLog %= (votedMessages (game ^. gameCards) black voted ++) | otherwise -> game where hasVoted pid _ = HMS.member pid votes || diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs index 28949ed..ba2425d 100644 --- a/server/lib/Cafp/Main/Server.hs +++ b/server/lib/Cafp/Main/Server.hs @@ -11,7 +11,7 @@ import qualified Control.Concurrent.MVar as MVar import Control.Concurrent.STM (STM, TVar, atomically) import qualified Control.Concurrent.STM as STM import Control.Exception (bracket) -import Control.Lens ((^.)) +import Control.Lens ((^.), (&), (.~)) import Control.Monad (forever, when) import qualified Data.Aeson as Aeson import qualified Data.ByteString as B @@ -40,7 +40,8 @@ type RoomId = T.Text type Sink = BL.ByteString -> IO () data Room = Room - { roomGame :: TVar Game + { roomId :: RoomId + , roomGame :: TVar Game , roomSinks :: TVar (HMS.HashMap PlayerId Sink) } @@ -63,9 +64,9 @@ withServer :: FL.FastLogger -> (Server -> IO a) -> IO a withServer fl f = CookieSocket.withHandle 5 $ \cs -> do f =<< Server fl cs <$> readCards <*> MVar.newMVar HMS.empty -newRoom :: Server -> StdGen -> STM Room -newRoom server gen = Room - <$> (STM.newTVar $ newGame (serverCards server) gen) +newRoom :: RoomId -> Cards -> StdGen -> STM Room +newRoom rid cards gen = Room rid + <$> STM.newTVar (newGame cards gen) <*> STM.newTVar HMS.empty parseRoomId :: T.Text -> Either String T.Text @@ -76,8 +77,8 @@ parseRoomId txt scottyApp :: IO Wai.Application scottyApp = Scotty.scottyApp $ do Scotty.get "/rooms/:id/" $ do - roomId <- Scotty.param "id" - when (T.length roomId < 6) $ + rid <- Scotty.param "id" + when (T.length rid < 6) $ Scotty.raise "Room ID should be at least 6 characters" Scotty.setHeader "Content-Type" "text/html" Scotty.file "assets/client.html" @@ -98,19 +99,19 @@ routePendingConnection pending = _ -> Nothing getOrCreateRoom :: Server -> RoomId -> IO Room -getOrCreateRoom server roomId = MVar.modifyMVar (serverRooms server) $ \rooms -> - case HMS.lookup roomId rooms of +getOrCreateRoom server rid = MVar.modifyMVar (serverRooms server) $ \rooms -> + case HMS.lookup rid rooms of Just room -> pure (rooms, room) Nothing -> do gen <- newStdGen - serverLogger server $ "[" <> FL.toLogStr roomId <> "] Created room" - room <- atomically $ newRoom server gen - pure (HMS.insert roomId room rooms, room) + serverLogger server $ "[" <> FL.toLogStr rid <> "] Created room" + room <- atomically $ newRoom rid (serverCards server) gen + pure (HMS.insert rid room rooms, room) deleteRoom :: Server -> RoomId -> IO () -deleteRoom server roomId = do - serverLogger server $ "[" <> FL.toLogStr roomId <> "] Deleting room" - MVar.modifyMVar_ (serverRooms server) $ pure . HMS.delete roomId +deleteRoom server rid = do + serverLogger server $ "[" <> FL.toLogStr rid <> "] Deleting room" + MVar.modifyMVar_ (serverRooms server) $ pure . HMS.delete rid joinRoom :: Room -> Sink -> Maybe Player -> STM PlayerId joinRoom room sink mbRecovered = do @@ -125,11 +126,14 @@ leaveRoom room pid = do let sinks' = HMS.delete pid sinks in ((HMS.null sinks', player), sinks') -syncRoom :: Room -> IO () -syncRoom room = do +syncRoom :: Server -> Room -> IO () +syncRoom server room = do (game, sinks) <- atomically $ (,) - <$> STM.readTVar (roomGame room) + <$> STM.stateTVar (roomGame room) (\g -> (g, g & gameLog .~ [])) <*> STM.readTVar (roomSinks room) + for_ (reverse $ game ^. gameLog) $ \msg -> + serverLogger server $ "[" <> FL.toLogStr (roomId room) <> "] " <> + FL.toLogStr msg for_ (HMS.toList sinks) $ \(pid, sink) -> do let view = gameViewForPlayer pid game sink . Aeson.encode $ SyncGameView view @@ -137,44 +141,44 @@ syncRoom room = do wsApp :: Server -> WS.ServerApp wsApp server pc = case routePendingConnection pc of Nothing -> WS.rejectRequest pc "Invalid URL" - Just roomId -> do - room <- getOrCreateRoom server roomId + Just rid -> do + room <- getOrCreateRoom server rid (conn, secret, mbRecovered) <- - CookieSocket.acceptRequest (serverCookieSocket server) roomId pc + CookieSocket.acceptRequest (serverCookieSocket server) rid pc let sink = WS.sendTextData conn WS.withPingThread conn 30 (pure ()) $ bracket (do pid <- atomically $ joinRoom room sink mbRecovered - serverLogger server $ "[" <> FL.toLogStr roomId <> + serverLogger server $ "[" <> FL.toLogStr rid <> "] Player " <> FL.toLogStr pid <> if isNothing mbRecovered then " joined" else " rejoined" pure pid) (\pid -> do (roomEmpty, mbPlayer) <- atomically $ leaveRoom room pid - serverLogger server $ "[" <> FL.toLogStr roomId <> + serverLogger server $ "[" <> FL.toLogStr rid <> "] Player " <> FL.toLogStr pid <> " left" if roomEmpty - then deleteRoom server roomId + then deleteRoom server rid else do for_ mbPlayer $ CookieSocket.persist (serverCookieSocket server) secret - syncRoom room) + syncRoom server room) (\playerId -> do - sink . Aeson.encode $ Welcome roomId - syncRoom room + sink . Aeson.encode $ Welcome rid + syncRoom server room cards <- fmap (^. gameCards) . atomically . STM.readTVar $ roomGame room sink . Aeson.encode $ SyncCards cards - loop conn roomId playerId) + loop conn rid playerId) where - loop conn roomId playerId = forever $ do + loop conn rid playerId = forever $ do msg <- WS.receiveData conn case Aeson.decode msg of Just cm -> do - room <- getOrCreateRoom server roomId -- TODO: only get? + room <- getOrCreateRoom server rid -- TODO: only get? atomically . STM.modifyTVar' (roomGame room) $ processClientMessage playerId cm - syncRoom room + syncRoom server room Nothing -> do serverLogger server $ "Could not decode client message: " <> FL.toLogStr (show msg) |