aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--server/lib/Cafp/Game.hs18
-rw-r--r--server/lib/Cafp/Main/Server.hs66
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)