aboutsummaryrefslogtreecommitdiff
path: root/server/lib
diff options
context:
space:
mode:
Diffstat (limited to 'server/lib')
-rw-r--r--server/lib/Cafp/Game.hs25
-rw-r--r--server/lib/Cafp/Main/Server.hs7
-rw-r--r--server/lib/Cafp/Messages.hs4
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