Send proposals to server

5 files changed, 55 insertions, 12 deletions

diff --git a/client/src/Client.elm b/client/src/Client.elm
index ea1a737..94e33cf 100644
--- a/client/src/Client.elm
+++ b/client/src/Client.elm
@@ -22,6 +22,7 @@ type Msg
     | SubmitMyName
     -- Card selection
     | SelectWhiteCard WhiteCard
+    | ProposeWhiteCards
 
 type alias Cards = {black : Array String, white : Array String}
 
@@ -74,7 +75,7 @@ view model = case model of
                 , Html.Attributes.disabled <|
                     game.view.myName == game.changeMyName
                 ]
-                [Html.text "change"]
+                [Html.text "Update name"]
             ]
         ] ++
         [viewTable game] ++
@@ -96,6 +97,15 @@ viewTable game = case game.view.table of
         [ blackCard game.cards c <| case selectedWhiteCard game of
             Nothing -> []
             Just wc -> [wc]
+        , Html.button
+            [ Html.Attributes.disabled <| case my of
+                Just _ -> True
+                _ -> case selectedWhiteCard game of
+                    Nothing -> True
+                    Just _ -> False
+            , Html.Events.onClick ProposeWhiteCards
+            ]
+            [Html.text "Propose"]
         ]
 
 intersperseWith : List a -> a -> List a -> List a
@@ -174,13 +184,22 @@ update msg model = case msg of
         Game game -> (Game {game | changeMyName = name}, Cmd.none)
         _ -> (model, Cmd.none)
     SubmitMyName -> case model of
-        Game game -> (model , send <| Messages.ChangeMyName game.changeMyName)
+        Game game -> (model, send <| Messages.ChangeMyName game.changeMyName)
         _ -> (model, Cmd.none)
 
     SelectWhiteCard card -> case model of
         Game game -> (Game {game | selectedWhiteCard = Just card}, Cmd.none)
         _ -> (model, Cmd.none)
 
+    ProposeWhiteCards -> case model of
+        Game game ->
+            ( Game {game | selectedWhiteCard = Nothing}
+            , case game.selectedWhiteCard of
+                Nothing -> Cmd.none
+                Just c -> send <| Messages.ProposeWhiteCards c
+            )
+        _ -> (model, Cmd.none)
+
 main : Program () Model Msg
 main = Browser.application
     { init = \() url key -> case parseRoomId url of
diff --git a/client/src/Messages.elm b/client/src/Messages.elm
index 69d0eff..1188525 100644
--- a/client/src/Messages.elm
+++ b/client/src/Messages.elm
@@ -125,14 +125,21 @@ jsonEncServerMessage  val =
 
 type ClientMessage  =
     ChangeMyName String
+    | ProposeWhiteCards WhiteCard
 
 jsonDecClientMessage : Json.Decode.Decoder ( ClientMessage )
 jsonDecClientMessage =
-    Json.Decode.lazy (\_ -> Json.Decode.map ChangeMyName (Json.Decode.string))
-
+    let jsonDecDictClientMessage = Dict.fromList
+            [ ("ChangeMyName", Json.Decode.lazy (\_ -> Json.Decode.map ChangeMyName (Json.Decode.string)))
+            , ("ProposeWhiteCards", Json.Decode.lazy (\_ -> Json.Decode.map ProposeWhiteCards (jsonDecWhiteCard)))
+            ]
+    in  decodeSumObjectWithSingleField  "ClientMessage" jsonDecDictClientMessage
 
 jsonEncClientMessage : ClientMessage -> Value
-jsonEncClientMessage (ChangeMyName v1) =
-    Json.Encode.string v1
+jsonEncClientMessage  val =
+    let keyval v = case v of
+                    ChangeMyName v1 -> ("ChangeMyName", encodeValue (Json.Encode.string v1))
+                    ProposeWhiteCards v1 -> ("ProposeWhiteCards", encodeValue (jsonEncWhiteCard v1))
+    in encodeSumObjectWithSingleField keyval val
 
 
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