Sync opponent proposals

5 files changed, 47 insertions, 7 deletions

diff --git a/client/src/Client.elm b/client/src/Client.elm
index 94e33cf..178e406 100644
--- a/client/src/Client.elm
+++ b/client/src/Client.elm
@@ -45,6 +45,12 @@ parseRoomId url = case String.split "/" url.path of
     _ :: "rooms" :: roomId :: _ -> Ok roomId
     _ -> Err <| "Invalid path: " ++ url.path
 
+viewOpponent : Messages.Opponent -> Html msg
+viewOpponent opponent = Html.div [] <|
+    [ Html.text opponent.name
+    ] ++
+    if opponent.ready then [Html.text " ✅"] else []
+
 view : Model -> List (Html Msg)
 view model = case model of
     Error str ->
@@ -58,7 +64,7 @@ view model = case model of
     Game game ->
         [ Html.h1 [] [Html.text "Opponents"]
         , Html.ul [] <| List.map
-            (\p -> Html.li [] [Html.text p])
+            (\o -> Html.li [] [viewOpponent o])
             game.view.opponents
         , Html.h1 [] [Html.text "You"]
         , Html.form
diff --git a/client/src/Messages.elm b/client/src/Messages.elm
index 1188525..b38fbd5 100644
--- a/client/src/Messages.elm
+++ b/client/src/Messages.elm
@@ -56,6 +56,26 @@ jsonEncCards  val =
 
 
 
+type alias Opponent  =
+   { name: String
+   , ready: Bool
+   }
+
+jsonDecOpponent : Json.Decode.Decoder ( Opponent )
+jsonDecOpponent =
+   Json.Decode.succeed (\pname pready -> {name = pname, ready = pready})
+   |> required "name" (Json.Decode.string)
+   |> required "ready" (Json.Decode.bool)
+
+jsonEncOpponent : Opponent -> Value
+jsonEncOpponent  val =
+   Json.Encode.object
+   [ ("name", Json.Encode.string val.name)
+   , ("ready", Json.Encode.bool val.ready)
+   ]
+
+
+
 type TableView  =
     Proposing BlackCard (Maybe WhiteCard)
 
@@ -71,7 +91,7 @@ jsonEncTableView (Proposing v1 v2) =
 
 
 type alias GameView  =
-   { opponents: (List String)
+   { opponents: (List Opponent)
    , myName: String
    , table: TableView
    , hand: (List WhiteCard)
@@ -80,7 +100,7 @@ type alias GameView  =
 jsonDecGameView : Json.Decode.Decoder ( GameView )
 jsonDecGameView =
    Json.Decode.succeed (\popponents pmyName ptable phand -> {opponents = popponents, myName = pmyName, table = ptable, hand = phand})
-   |> required "opponents" (Json.Decode.list (Json.Decode.string))
+   |> required "opponents" (Json.Decode.list (jsonDecOpponent))
    |> required "myName" (Json.Decode.string)
    |> required "table" (jsonDecTableView)
    |> required "hand" (Json.Decode.list (jsonDecWhiteCard))
@@ -88,7 +108,7 @@ jsonDecGameView =
 jsonEncGameView : GameView -> Value
 jsonEncGameView  val =
    Json.Encode.object
-   [ ("opponents", (Json.Encode.list Json.Encode.string) val.opponents)
+   [ ("opponents", (Json.Encode.list jsonEncOpponent) val.opponents)
    , ("myName", Json.Encode.string val.myName)
    , ("table", jsonEncTableView val.table)
    , ("hand", (Json.Encode.list jsonEncWhiteCard) val.hand)
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs
index 336b85c..9c2d2e4 100644
--- a/server/lib/Cafp/Game.hs
+++ b/server/lib/Cafp/Game.hs
@@ -20,6 +20,7 @@ import           Cafp.Messages
 import           Control.Lens        (at, ix, over, to, (%~), (&), (.~), (^.),
                                       (^?), _2)
 import           Control.Lens.TH     (makeLenses, makePrisms)
+import           Control.Monad       (guard)
 import qualified Data.HashMap.Strict as HMS
 import           Data.Maybe          (fromMaybe)
 import           Data.Text           (Text)
@@ -73,14 +74,19 @@ processClientMessage pid msg game = case msg of
         -- Bad card proposed.
         | not $ validWhiteCard (game ^. gameCards) c -> game
         -- Proposal already made.
-        | Just _ <- game ^? gameTable . _TableProposing . _2 . at pid -> game
+        | Just _ <- game ^? gameTable . _TableProposing . _2 . ix 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 =
-    let opponents = map snd . HMS.toList . HMS.delete self $ game ^. gamePlayers
+    let opponents = do
+            (pid, oname) <- HMS.toList $ game ^. gamePlayers
+            guard $ pid /= self
+            pure $ Opponent oname $ case game ^. gameTable of
+                TableProposing _ proposals -> HMS.member pid proposals
+
         name = fromMaybe "" $ game ^. gamePlayers . at self
 
         table = case game ^. gameTable of
diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs
index 677bc5c..b1e6efe 100644
--- a/server/lib/Cafp/Main/GenerateElmTypes.hs
+++ b/server/lib/Cafp/Main/GenerateElmTypes.hs
@@ -13,6 +13,7 @@ main = putStrLn $ makeElmModule "Messages"
     [ DefineElm (Proxy :: Proxy BlackCard)
     , DefineElm (Proxy :: Proxy WhiteCard)
     , DefineElm (Proxy :: Proxy Cards)
+    , DefineElm (Proxy :: Proxy Opponent)
     , DefineElm (Proxy :: Proxy TableView)
     , DefineElm (Proxy :: Proxy GameView)
     , DefineElm (Proxy :: Proxy ServerMessage)
diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs
index ff3f612..dc17168 100644
--- a/server/lib/Cafp/Messages.hs
+++ b/server/lib/Cafp/Messages.hs
@@ -3,6 +3,7 @@ module Cafp.Messages
     ( BlackCard (..)
     , WhiteCard (..)
     , Cards (..)
+    , Opponent (..)
     , TableView (..)
     , GameView (..)
     , ServerMessage (..)
@@ -22,12 +23,17 @@ data Cards = Cards
     , cardsWhite        :: Vector Text
     } deriving (Show)
 
+data Opponent = Opponent
+    { opponentName  :: Text
+    , opponentReady :: Bool
+    } deriving (Show)
+
 data TableView
     = Proposing BlackCard (Maybe WhiteCard)
     deriving (Show)
 
 data GameView = GameView
-    { gameViewOpponents :: [Text]
+    { gameViewOpponents :: [Opponent]
     , gameViewMyName    :: Text
     , gameViewTable     :: TableView
     , gameViewHand      :: [WhiteCard]
@@ -48,6 +54,7 @@ data ClientMessage
 deriveBoth defaultOptions ''BlackCard
 deriveBoth defaultOptions ''WhiteCard
 deriveBoth (defaultOptionsDropLower 5) ''Cards
+deriveBoth (defaultOptionsDropLower 8) ''Opponent
 deriveBoth defaultOptions ''TableView
 deriveBoth (defaultOptionsDropLower 8) ''GameView
 deriveBoth defaultOptions ''ServerMessage