Sync cards only once

8 files changed, 85 insertions, 33 deletions

diff --git a/black.txt b/black.txt
index e7383a5..0c886bd 100644
--- a/black.txt
+++ b/black.txt
@@ -1,3 +1,4 @@
+# These are the old cards I copied.
 A crypto conference is never complete without \BLANK.
 A recent laboratory study shows that undergrads have 50\% less sex after being exposed to \BLANK.
 A romantic, candlelit dinner would be incomplete without \BLANK.
diff --git a/client/src/Client.elm b/client/src/Client.elm
index 41871e9..5c6d167 100644
--- a/client/src/Client.elm
+++ b/client/src/Client.elm
@@ -1,9 +1,10 @@
 port module Client exposing (main)
 
+import Array exposing (Array)
 import Browser
-import Html exposing (Html)
 import Html.Attributes
 import Html.Events
+import Html exposing (Html)
 import Json.Decode
 import Json.Encode
 import Messages exposing (GameView)
@@ -20,13 +21,16 @@ type Msg
     | ChangeMyName String
     | SubmitMyName
 
+type alias Cards = {black : Array String, white : Array String}
+
 type Model
     = Error String
     | Connecting
         { roomId : String
         }
     | Game
-        { view : GameView
+        { cards : Cards
+        , view : GameView
         , changeMyName : String
         }
 
@@ -70,21 +74,21 @@ view model = case model of
         ] ++
         (case game.view.blackCard of
             Nothing -> []
-            Just c -> [blackCard c]) ++
-        (List.map whiteCard game.view.hand)
+            Just c -> [blackCard game.cards c]) ++
+        (List.map (whiteCard game.cards) game.view.hand)
 
-blackCard : Messages.BlackCard -> Html a
-blackCard (Messages.BlackCard string) =
+blackCard : Cards -> Messages.BlackCard -> Html a
+blackCard cards (Messages.BlackCard idx) =
     let blank = Html.span [Html.Attributes.class "blank"] [] in
     Html.div [Html.Attributes.class "card", Html.Attributes.class "black"] <|
-    List.intersperse blank <|
-    List.map Html.text <|
-    String.split "\\BLANK" string
+    List.intersperse blank <| List.map Html.text <|
+    String.split "\\BLANK" <| Maybe.withDefault "" <|
+    Array.get idx cards.black
 
-whiteCard : Messages.WhiteCard -> Html a
-whiteCard (Messages.WhiteCard string) = Html.div
+whiteCard : Cards -> Messages.WhiteCard -> Html a
+whiteCard cards (Messages.WhiteCard idx) = Html.div
     [Html.Attributes.class "card", Html.Attributes.class "white"]
-    [Html.text string]
+    [Html.text <| Maybe.withDefault "" <| Array.get idx cards.white]
 
 subscriptions : Model -> Sub Msg
 subscriptions model = webSocketIn WebSocketIn
@@ -107,11 +111,20 @@ update msg model = case msg of
                     Game game -> (Game {game | view = gameView}, Cmd.none)
                     _ ->
                         ( Game
-                            { view = gameView
+                            { cards = {black = Array.empty, white = Array.empty}
+                            , view = gameView
                             , changeMyName = gameView.myName
                             }
                         , Cmd.none
                         )
+            Ok (Messages.SyncCards cards) ->
+                let arr =
+                        { black = Array.fromList cards.black
+                        , white = Array.fromList cards.white
+                        } in
+                case model of
+                    Game game -> (Game {game | cards = arr}, Cmd.none)
+                    _ -> (model, Cmd.none)
 
     ChangeMyName name -> case model of
         Game game -> (Game {game | changeMyName = name}, Cmd.none)
diff --git a/client/src/Messages.elm b/client/src/Messages.elm
index d2c2716..15a0d1c 100644
--- a/client/src/Messages.elm
+++ b/client/src/Messages.elm
@@ -9,30 +9,50 @@ import Set exposing (Set)
 
 
 type BlackCard  =
-    BlackCard String
+    BlackCard Int
 
 jsonDecBlackCard : Json.Decode.Decoder ( BlackCard )
 jsonDecBlackCard =
-    Json.Decode.lazy (\_ -> Json.Decode.map BlackCard (Json.Decode.string))
+    Json.Decode.lazy (\_ -> Json.Decode.map BlackCard (Json.Decode.int))
 
 
 jsonEncBlackCard : BlackCard -> Value
 jsonEncBlackCard (BlackCard v1) =
-    Json.Encode.string v1
+    Json.Encode.int v1
 
 
 
 type WhiteCard  =
-    WhiteCard String
+    WhiteCard Int
 
 jsonDecWhiteCard : Json.Decode.Decoder ( WhiteCard )
 jsonDecWhiteCard =
-    Json.Decode.lazy (\_ -> Json.Decode.map WhiteCard (Json.Decode.string))
+    Json.Decode.lazy (\_ -> Json.Decode.map WhiteCard (Json.Decode.int))
 
 
 jsonEncWhiteCard : WhiteCard -> Value
 jsonEncWhiteCard (WhiteCard v1) =
-    Json.Encode.string v1
+    Json.Encode.int v1
+
+
+
+type alias Cards  =
+   { black: (List String)
+   , white: (List String)
+   }
+
+jsonDecCards : Json.Decode.Decoder ( Cards )
+jsonDecCards =
+   Json.Decode.succeed (\pblack pwhite -> {black = pblack, white = pwhite})
+   |> required "black" (Json.Decode.list (Json.Decode.string))
+   |> required "white" (Json.Decode.list (Json.Decode.string))
+
+jsonEncCards : Cards -> Value
+jsonEncCards  val =
+   Json.Encode.object
+   [ ("black", (Json.Encode.list Json.Encode.string) val.black)
+   , ("white", (Json.Encode.list Json.Encode.string) val.white)
+   ]
 
 
 
@@ -64,6 +84,7 @@ jsonEncGameView  val =
 
 type ServerMessage  =
     Welcome Int
+    | SyncCards Cards
     | SyncGameView GameView
     | Bye 
 
@@ -71,6 +92,7 @@ jsonDecServerMessage : Json.Decode.Decoder ( ServerMessage )
 jsonDecServerMessage =
     let jsonDecDictServerMessage = Dict.fromList
             [ ("Welcome", Json.Decode.lazy (\_ -> Json.Decode.map Welcome (Json.Decode.int)))
+            , ("SyncCards", Json.Decode.lazy (\_ -> Json.Decode.map SyncCards (jsonDecCards)))
             , ("SyncGameView", Json.Decode.lazy (\_ -> Json.Decode.map SyncGameView (jsonDecGameView)))
             , ("Bye", Json.Decode.lazy (\_ -> Json.Decode.succeed Bye))
             ]
@@ -80,6 +102,7 @@ jsonEncServerMessage : ServerMessage -> Value
 jsonEncServerMessage  val =
     let keyval v = case v of
                     Welcome v1 -> ("Welcome", encodeValue (Json.Encode.int v1))
+                    SyncCards v1 -> ("SyncCards", encodeValue (jsonEncCards v1))
                     SyncGameView v1 -> ("SyncGameView", encodeValue (jsonEncGameView v1))
                     Bye  -> ("Bye", encodeValue (Json.Encode.list identity []))
     in encodeSumObjectWithSingleField keyval val
diff --git a/server/cafp.cabal b/server/cafp.cabal
index 0dc068b..9bb2250 100644
--- a/server/cafp.cabal
+++ b/server/cafp.cabal
@@ -31,6 +31,7 @@ Library
     stm                  >= 2.5  && < 2.6,
     text                 >= 1.2  && < 1.3,
     unordered-containers >= 0.2  && < 0.3,
+    vector               >= 0.12 && < 0.13,
     wai                  >= 3.2  && < 3.3,
     wai-websockets       >= 3.0  && < 3.1,
     warp                 >= 3.3  && < 3.4,
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs
index ad33368..740eac5 100644
--- a/server/lib/Cafp/Game.hs
+++ b/server/lib/Cafp/Game.hs
@@ -5,6 +5,7 @@ module Cafp.Game
     ( PlayerId
     , Cards (..)
     , Game (..)
+    , gameCards, gamePlayers, gameNextPlayerId
 
     , newGame
     , joinGame
@@ -16,7 +17,8 @@ module Cafp.Game
     ) where
 
 import           Cafp.Messages
-import           Control.Lens        (at, ix, over, (%~), (&), (.~), (^.), (^?))
+import           Control.Lens        (at, ix, over, to, (%~), (&), (.~), (^.),
+                                      (^?))
 import           Control.Lens.TH     (makeLenses)
 import qualified Data.HashMap.Strict as HMS
 import           Data.Maybe          (fromMaybe)
@@ -25,18 +27,12 @@ import qualified Data.Text           as T
 
 type PlayerId = Int
 
-data Cards = Cards
-    { _cardsBlack :: [BlackCard]
-    , _cardsWhite :: [WhiteCard]
-    } deriving (Show)
-
 data Game = Game
     { _gameCards        :: !Cards
     , _gamePlayers      :: !(HMS.HashMap Int Text)
     , _gameNextPlayerId :: !Int
     } deriving (Show)
 
-makeLenses ''Cards
 makeLenses ''Game
 
 newGame :: Cards -> Game
@@ -65,6 +61,6 @@ gameViewForPlayer self game =
     GameView
         { gameViewOpponents = opponents
         , gameViewMyName    = name
-        , gameViewBlackCard = game ^? gameCards . cardsBlack . ix 0
-        , gameViewHand      = take 10 $ game ^. gameCards . cardsWhite
+        , gameViewBlackCard = Just $ BlackCard 0
+        , gameViewHand      = [WhiteCard x | x <- [0 .. 9]]
         }
diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs
index 51376a5..7900b1c 100644
--- a/server/lib/Cafp/Main/GenerateElmTypes.hs
+++ b/server/lib/Cafp/Main/GenerateElmTypes.hs
@@ -12,6 +12,7 @@ main :: IO ()
 main = putStrLn $ makeElmModule "Messages"
     [ DefineElm (Proxy :: Proxy BlackCard)
     , DefineElm (Proxy :: Proxy WhiteCard)
+    , DefineElm (Proxy :: Proxy Cards)
     , DefineElm (Proxy :: Proxy GameView)
     , DefineElm (Proxy :: Proxy ServerMessage)
     , DefineElm (Proxy :: Proxy ClientMessage)
diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs
index 3edf039..e6e353f 100644
--- a/server/lib/Cafp/Main/Server.hs
+++ b/server/lib/Cafp/Main/Server.hs
@@ -9,6 +9,7 @@ import           Control.Concurrent             (threadDelay)
 import           Control.Concurrent.STM         (STM, TVar, atomically)
 import qualified Control.Concurrent.STM         as STM
 import           Control.Exception              (bracket)
+import           Control.Lens                   ((^.))
 import           Control.Monad                  (forever, when)
 import qualified Data.Aeson                     as Aeson
 import qualified Data.ByteString                as B
@@ -20,6 +21,7 @@ import qualified Data.Text                      as T
 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 Network.Wai                    as Wai
 import qualified Network.Wai.Handler.Warp       as Warp
 import qualified Network.Wai.Handler.WebSockets as WaiWs
@@ -46,8 +48,11 @@ data Server = Server
 
 readCards :: IO Cards
 readCards = Cards
-    <$> fmap (map BlackCard . T.lines) (T.readFile "assets/black.txt")
-    <*> fmap (map WhiteCard . T.lines) (T.readFile "assets/white.txt")
+    <$> fmap parseCards (T.readFile "assets/black.txt")
+    <*> fmap parseCards (T.readFile "assets/white.txt")
+  where
+    parseCards =
+        filter (not . T.isPrefixOf "#") . filter (not . T.null) . T.lines
 
 newServer :: IO Server
 newServer = Server <$> readCards <*> atomically (STM.newTVar HMS.empty)
@@ -117,13 +122,17 @@ wsApp server pc = case routePendingConnection pc of
     Just roomId -> do
         room <- atomically $ getOrCreateRoom server roomId
         conn <- WS.acceptRequest pc
+        let sink = WS.sendTextData conn
         WS.withPingThread conn 30 (pure ()) $ bracket
-            (atomically $ joinRoom room (WS.sendTextData conn))
+            (atomically $ joinRoom room sink)
             (\playerId -> do
                 atomically $ leaveRoom room playerId
                 syncRoom room)
             (\playerId -> do
                 syncRoom room
+                cards <- fmap (^. gameCards) . atomically . STM.readTVar $
+                    roomGame room
+                sink . Aeson.encode $ SyncCards cards
                 loop conn roomId playerId)
   where
     loop conn roomId playerId = forever $ do
diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs
index 542189f..219efb4 100644
--- a/server/lib/Cafp/Messages.hs
+++ b/server/lib/Cafp/Messages.hs
@@ -2,6 +2,7 @@
 module Cafp.Messages
     ( BlackCard (..)
     , WhiteCard (..)
+    , Cards (..)
     , GameView (..)
     , ServerMessage (..)
     , ClientMessage (..)
@@ -10,9 +11,14 @@ module Cafp.Messages
 import           Data.Text  (Text)
 import           Elm.Derive
 
-data BlackCard = BlackCard Text deriving (Show)
+data BlackCard = BlackCard Int deriving (Show)
 
-data WhiteCard = WhiteCard Text deriving (Show)
+data WhiteCard = WhiteCard Int deriving (Show)
+
+data Cards = Cards
+    { cardsBlack :: [Text]
+    , cardsWhite :: [Text]
+    } deriving (Show)
 
 data GameView = GameView
     { gameViewOpponents :: [Text]
@@ -23,6 +29,7 @@ data GameView = GameView
 
 data ServerMessage
     = Welcome Int
+    | SyncCards Cards
     | SyncGameView GameView
     | Bye
     deriving (Show)
@@ -33,6 +40,7 @@ data ClientMessage
 
 deriveBoth defaultOptions ''BlackCard
 deriveBoth defaultOptions ''WhiteCard
+deriveBoth (defaultOptionsDropLower 5) ''Cards
 deriveBoth (defaultOptionsDropLower 8) ''GameView
 deriveBoth defaultOptions ''ServerMessage
 deriveBoth defaultOptions ''ClientMessage