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