diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/lib/Cafp/Game.hs | 18 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/Server.hs | 3 | ||||
| -rw-r--r-- | server/lib/Cafp/Messages.hs | 8 |
3 files changed, 23 insertions, 6 deletions
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs index 3a67ef6..336b85c 100644 --- a/server/lib/Cafp/Game.hs +++ b/server/lib/Cafp/Game.hs @@ -18,12 +18,13 @@ module Cafp.Game import Cafp.Messages import Control.Lens (at, ix, over, to, (%~), (&), (.~), (^.), - (^?)) -import Control.Lens.TH (makeLenses) + (^?), _2) +import Control.Lens.TH (makeLenses, makePrisms) import qualified Data.HashMap.Strict as HMS import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Vector as V type PlayerId = Int @@ -38,6 +39,7 @@ data Game = Game , _gameNextPlayerId :: !Int } deriving (Show) +makePrisms ''Table makeLenses ''Game newGame :: Cards -> Game @@ -59,10 +61,22 @@ joinGame game = leaveGame :: PlayerId -> Game -> Game leaveGame pid = over gamePlayers $ HMS.delete pid +validWhiteCard :: Cards -> WhiteCard -> Bool +validWhiteCard cards (WhiteCard c) = + let len = V.length $ cardsWhite cards in c >= 0 && c < len + 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 + -- Proposal already made. + | Just _ <- game ^? gameTable . _TableProposing . _2 . at pid -> game + -- TODO: Check that the card is in the hand of the player. + | otherwise -> + game & gameTable . _TableProposing . _2 . at pid .~ Just c gameViewForPlayer :: PlayerId -> Game -> GameView gameViewForPlayer self game = diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs index e6e353f..13b1f6b 100644 --- a/server/lib/Cafp/Main/Server.hs +++ b/server/lib/Cafp/Main/Server.hs @@ -22,6 +22,7 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.Vector as V +import qualified Data.Vector as V import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WebSockets as WaiWs @@ -51,7 +52,7 @@ readCards = Cards <$> fmap parseCards (T.readFile "assets/black.txt") <*> fmap parseCards (T.readFile "assets/white.txt") where - parseCards = + parseCards = V.fromList . filter (not . T.isPrefixOf "#") . filter (not . T.null) . T.lines newServer :: IO Server diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs index de0ae26..ff3f612 100644 --- a/server/lib/Cafp/Messages.hs +++ b/server/lib/Cafp/Messages.hs @@ -9,7 +9,8 @@ module Cafp.Messages , ClientMessage (..) ) where -import Data.Text (Text) +import Data.Text (Text) +import Data.Vector (Vector) import Elm.Derive data BlackCard = BlackCard Int deriving (Show) @@ -17,8 +18,8 @@ data BlackCard = BlackCard Int deriving (Show) data WhiteCard = WhiteCard Int deriving (Show) data Cards = Cards - { cardsBlack :: [Text] - , cardsWhite :: [Text] + { cardsBlack :: Vector Text + , cardsWhite :: Vector Text } deriving (Show) data TableView @@ -41,6 +42,7 @@ data ServerMessage data ClientMessage = ChangeMyName Text + | ProposeWhiteCards WhiteCard -- TODO: Needs to be a list? deriving (Show) deriveBoth defaultOptions ''BlackCard |