Multiple \BLANK in black cards

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