diff options
Diffstat (limited to 'server/lib')
| -rw-r--r-- | server/lib/Cafp/Game.hs | 25 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/Server.hs | 7 | ||||
| -rw-r--r-- | server/lib/Cafp/Messages.hs | 4 |
3 files changed, 24 insertions, 12 deletions
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs index 9c2d2e4..bb734a1 100644 --- a/server/lib/Cafp/Game.hs +++ b/server/lib/Cafp/Game.hs @@ -17,8 +17,9 @@ module Cafp.Game ) where import Cafp.Messages +import Debug.Trace import Control.Lens (at, ix, over, to, (%~), (&), (.~), (^.), - (^?), _2) + (^?), _1, _2) import Control.Lens.TH (makeLenses, makePrisms) import Control.Monad (guard) import qualified Data.HashMap.Strict as HMS @@ -30,7 +31,7 @@ import qualified Data.Vector as V type PlayerId = Int data Table - = TableProposing BlackCard (HMS.HashMap PlayerId WhiteCard) + = TableProposing BlackCard (HMS.HashMap PlayerId [WhiteCard]) deriving (Show) data Game = Game @@ -62,6 +63,10 @@ joinGame game = leaveGame :: PlayerId -> Game -> Game leaveGame pid = over gamePlayers $ HMS.delete pid +blackCardBlanks :: Cards -> BlackCard -> Int +blackCardBlanks cards (BlackCard c) = + maybe 0 (length . T.breakOnAll "\\BLANK") $ cardsBlack cards V.!? c + validWhiteCard :: Cards -> WhiteCard -> Bool validWhiteCard cards (WhiteCard c) = let len = V.length $ cardsWhite cards in c >= 0 && c < len @@ -70,14 +75,20 @@ processClientMessage :: PlayerId -> ClientMessage -> Game -> Game processClientMessage pid msg game = case msg of ChangeMyName name -> game & gamePlayers . ix pid .~ name - ProposeWhiteCards c - -- Bad card proposed. - | not $ validWhiteCard (game ^. gameCards) c -> game + ProposeWhiteCards cs + -- Bad card(s) proposed. + | any (not . validWhiteCard (game ^. gameCards)) cs -> game -- Proposal already made. | Just _ <- game ^? gameTable . _TableProposing . _2 . ix pid -> game + -- Not enough cards submitted. + | Just b <- game ^? gameTable . _TableProposing . _1 + , blackCardBlanks (game ^. gameCards) b /= length cs -> trace + ("bad length " ++ show (length cs) ++ + " expected " ++ show (blackCardBlanks (game ^. gameCards) b)) + game -- TODO: Check that the card is in the hand of the player. | otherwise -> - game & gameTable . _TableProposing . _2 . at pid .~ Just c + game & gameTable . _TableProposing . _2 . at pid .~ Just cs gameViewForPlayer :: PlayerId -> Game -> GameView gameViewForPlayer self game = @@ -91,7 +102,7 @@ gameViewForPlayer self game = table = case game ^. gameTable of TableProposing black proposals -> - Proposing black (HMS.lookup self proposals) in + Proposing black . fromMaybe [] $ HMS.lookup self proposals in GameView { gameViewOpponents = opponents , gameViewMyName = name diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs index 13b1f6b..3a99672 100644 --- a/server/lib/Cafp/Main/Server.hs +++ b/server/lib/Cafp/Main/Server.hs @@ -113,9 +113,10 @@ syncRoom room = do (game, sinks) <- atomically $ (,) <$> STM.readTVar (roomGame room) <*> STM.readTVar (roomSinks room) - warning $ "New state: " ++ show game - for_ (HMS.toList sinks) $ \(pid, sink) -> - sink . Aeson.encode . SyncGameView $ gameViewForPlayer pid game + for_ (HMS.toList sinks) $ \(pid, sink) -> do + let view = gameViewForPlayer pid game + warning $ "New state: " ++ show view + sink . Aeson.encode $ SyncGameView view wsApp :: Server -> WS.ServerApp wsApp server pc = case routePendingConnection pc of diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs index dc17168..1b37380 100644 --- a/server/lib/Cafp/Messages.hs +++ b/server/lib/Cafp/Messages.hs @@ -29,7 +29,7 @@ data Opponent = Opponent } deriving (Show) data TableView - = Proposing BlackCard (Maybe WhiteCard) + = Proposing BlackCard [WhiteCard] deriving (Show) data GameView = GameView @@ -48,7 +48,7 @@ data ServerMessage data ClientMessage = ChangeMyName Text - | ProposeWhiteCards WhiteCard -- TODO: Needs to be a list? + | ProposeWhiteCards [WhiteCard] deriving (Show) deriveBoth defaultOptions ''BlackCard |