Basic syncing

7 files changed, 120 insertions, 30 deletions

diff --git a/client/src/Client.elm b/client/src/Client.elm
index 0644a12..442f089 100644
--- a/client/src/Client.elm
+++ b/client/src/Client.elm
@@ -3,7 +3,7 @@ port module Client exposing (main)
 import Browser
 import Html exposing (Html)
 import Json.Decode
-import Messages
+import Messages exposing (GameView)
 import Url exposing (Url)
 
 port webSocketIn : (String -> msg) -> Sub msg
@@ -19,6 +19,9 @@ type Model
     | Connecting
         { roomId : String
         }
+    | Game
+        { view : GameView
+        }
 
 parseRoomId : Url -> Result String String
 parseRoomId url = case String.split "/" url.path of
@@ -35,6 +38,13 @@ view model = case model of
         [ Html.h1 []
             [Html.text <| "Connecting to room " ++ state.roomId ++ "..."]
         ]
+    Game game ->
+        [ Html.h1 [] [Html.text "Players"]
+        , Html.ul [] <| List.map
+            (\p -> Html.li [] [Html.text p])
+            game.view.players
+        ]
+
 
 subscriptions : Model -> Sub Msg
 subscriptions model = webSocketIn WebSocketIn
@@ -49,6 +59,8 @@ update msg model = case msg of
             Ok (Messages.Welcome playerId) ->
                 Debug.log ("Welcome " ++ String.fromInt playerId) (model, Cmd.none)
             Ok Messages.Bye -> Debug.log "Bye" (model, Cmd.none)
+            Ok (Messages.SyncGameView gameView) ->
+                (Game {view = gameView}, Cmd.none)
 
 main : Program () Model Msg
 main = Browser.application
diff --git a/client/src/Messages.elm b/client/src/Messages.elm
index 76b24f5..2239a74 100644
--- a/client/src/Messages.elm
+++ b/client/src/Messages.elm
@@ -8,14 +8,29 @@ import Dict exposing (Dict)
 import Set exposing (Set)
 
 
+type alias GameView  =
+   { players: (List String)
+   }
+
+jsonDecGameView : Json.Decode.Decoder ( GameView )
+jsonDecGameView =
+   Json.Decode.succeed (\pplayers -> {players = pplayers}) |> custom (Json.Decode.list (Json.Decode.string))
+
+jsonEncGameView : GameView -> Value
+jsonEncGameView  val =
+   (Json.Encode.list Json.Encode.string) val.players
+
+
 type ServerMessage  =
     Welcome Int
+    | SyncGameView GameView
     | Bye 
 
 jsonDecServerMessage : Json.Decode.Decoder ( ServerMessage )
 jsonDecServerMessage =
     let jsonDecDictServerMessage = Dict.fromList
             [ ("Welcome", Json.Decode.lazy (\_ -> Json.Decode.map Welcome (Json.Decode.int)))
+            , ("SyncGameView", Json.Decode.lazy (\_ -> Json.Decode.map SyncGameView (jsonDecGameView)))
             , ("Bye", Json.Decode.lazy (\_ -> Json.Decode.succeed Bye))
             ]
     in  decodeSumObjectWithSingleField  "ServerMessage" jsonDecDictServerMessage
@@ -24,6 +39,7 @@ jsonEncServerMessage : ServerMessage -> Value
 jsonEncServerMessage  val =
     let keyval v = case v of
                     Welcome v1 -> ("Welcome", encodeValue (Json.Encode.int 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 df178c7..7f0f3b4 100644
--- a/server/cafp.cabal
+++ b/server/cafp.cabal
@@ -16,6 +16,7 @@ Library
   Hs-source-dirs:   lib
 
   Exposed-modules:
+    Cafp.Game
     Cafp.Messages
     Cafp.Main.GenerateElmTypes
     Cafp.Main.Server
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs
new file mode 100644
index 0000000..a5f367a
--- /dev/null
+++ b/server/lib/Cafp/Game.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+module Cafp.Game
+    ( PlayerId
+    , Game (..)
+
+    , newGame
+    , joinGame
+    , leaveGame
+
+    , gameViewForPlayer
+    ) where
+
+import           Cafp.Messages
+import qualified Data.HashMap.Strict as HMS
+import           Data.Text           (Text)
+import qualified Data.Text           as T
+
+type PlayerId = Int
+
+data Game = Game
+    { gamePlayers      :: !(HMS.HashMap Int Text)
+    , gameNextPlayerId :: !Int
+    } deriving (Show)
+
+newGame :: Game
+newGame = Game HMS.empty 1
+
+joinGame :: Game -> (PlayerId, Game)
+joinGame game@Game {..} =
+    let pid = gameNextPlayerId
+        name = "Player " <> T.pack (show pid)
+        players = HMS.insert pid name gamePlayers in
+    (pid, game {gameNextPlayerId = pid + 1, gamePlayers = players})
+
+leaveGame :: PlayerId -> Game -> Game
+leaveGame pid game = game {gamePlayers = HMS.delete pid $ gamePlayers game}
+
+gameViewForPlayer :: PlayerId -> Game -> GameView
+gameViewForPlayer _ = GameView . map snd . HMS.toList . gamePlayers
diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs
index 8d2c9c1..3728850 100644
--- a/server/lib/Cafp/Main/GenerateElmTypes.hs
+++ b/server/lib/Cafp/Main/GenerateElmTypes.hs
@@ -10,5 +10,6 @@ import           Elm.Module
 
 main :: IO ()
 main = putStrLn $ makeElmModule "Messages"
-    [ DefineElm (Proxy :: Proxy ServerMessage)
+    [ DefineElm (Proxy :: Proxy GameView)
+    , DefineElm (Proxy :: Proxy ServerMessage)
     ]
diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs
index b965f20..c71709e 100644
--- a/server/lib/Cafp/Main/Server.hs
+++ b/server/lib/Cafp/Main/Server.hs
@@ -3,17 +3,20 @@ module Cafp.Main.Server
     ( main
     ) where
 
+import           Cafp.Game
 import           Cafp.Messages
 import           Control.Concurrent             (threadDelay)
-import Control.Exception (bracket)
 import           Control.Concurrent.STM         (STM, TVar, atomically)
-import           qualified Control.Concurrent.STM         as STM
+import qualified Control.Concurrent.STM         as STM
+import           Control.Exception              (bracket)
 import           Control.Monad                  (forever, when)
 import qualified Data.Aeson                     as Aeson
+import qualified Data.ByteString                as B
+import qualified Data.ByteString.Lazy           as BL
+import           Data.Foldable                  (for_)
 import qualified Data.HashMap.Strict            as HMS
 import           Data.Text                      (Text)
 import qualified Data.Text                      as T
-import qualified Data.ByteString as B
 import qualified Data.Text.Encoding             as T
 import qualified Data.Text.Lazy                 as TL
 import qualified Network.Wai                    as Wai
@@ -24,24 +27,22 @@ import qualified Web.Scotty                     as Scotty
 
 type RoomId = T.Text
 
-type PlayerId = Int
-
-type Sink = B.ByteString -> IO ()
+type Sink = BL.ByteString -> IO ()
 
 data Room = Room
-    { roomSinks :: TVar (HMS.HashMap PlayerId Sink)
+    { roomGame    :: TVar Game
+    , roomSinks   :: TVar (HMS.HashMap PlayerId Sink)
     }
 
 data Server = Server
-    { serverRooms        :: TVar (HMS.HashMap RoomId Room)
-    , serverNextPlayerId :: TVar Int
+    { serverRooms :: TVar (HMS.HashMap RoomId Room)
     }
 
 newServer :: STM Server
-newServer = Server <$> STM.newTVar HMS.empty <*> STM.newTVar 0
+newServer = Server <$> STM.newTVar HMS.empty
 
 newRoom :: STM Room
-newRoom = Room <$> STM.newTVar HMS.empty
+newRoom = Room <$> STM.newTVar newGame <*> STM.newTVar HMS.empty
 
 scottyApp :: IO Wai.Application
 scottyApp = Scotty.scottyApp $ do
@@ -63,9 +64,6 @@ routePendingConnection pending =
         [_, "rooms", roomId, "events"] -> Just roomId
         _                              -> Nothing
 
-newPlayerId :: Server -> STM PlayerId
-newPlayerId s = STM.stateTVar (serverNextPlayerId s) $ \x -> (x, x + 1)
-
 getOrCreateRoom :: Server -> RoomId -> STM Room
 getOrCreateRoom server roomId = do
     rooms <- STM.readTVar $ serverRooms server
@@ -76,27 +74,41 @@ getOrCreateRoom server roomId = do
             STM.writeTVar (serverRooms server) $ HMS.insert roomId room rooms
             pure room
 
-joinPlayer :: Room -> PlayerId -> Sink -> STM ()
-joinPlayer room pid sink = STM.modifyTVar (roomSinks room) $ HMS.insert pid sink
-
-leavePlayer :: Room -> PlayerId -> STM ()
-leavePlayer room pid = STM.modifyTVar (roomSinks room) $ HMS.delete pid
+joinRoom :: Room -> Sink -> STM PlayerId
+joinRoom room sink = do
+    pid <- STM.stateTVar (roomGame room) joinGame
+    STM.modifyTVar' (roomSinks room) $ HMS.insert pid sink
+    pure pid
+
+leaveRoom :: Room -> PlayerId -> STM ()
+leaveRoom room pid = do
+    STM.modifyTVar' (roomGame room) $ leaveGame pid
+    STM.modifyTVar' (roomSinks room) $ HMS.delete pid
+
+syncRoom :: Room -> IO ()
+syncRoom room = do
+    (game, sinks) <- atomically $ (,)
+        <$> STM.readTVar (roomGame room)
+        <*> STM.readTVar (roomSinks room)
+    for_ (HMS.toList sinks) $ \(pid, sink) ->
+        sink . Aeson.encode . SyncGameView $ gameViewForPlayer pid game
 
 wsApp :: Server -> WS.ServerApp
 wsApp server pc = case routePendingConnection pc of
     Nothing -> WS.rejectRequest pc "Invalid URL"
     Just roomId -> do
-        playerId <- atomically $ newPlayerId server
         room <- atomically $ getOrCreateRoom server roomId
         conn <- WS.acceptRequest pc
-        WS.withPingThread conn 30 (pure ()) $ do
-            WS.sendTextData conn $ Aeson.encode $ Welcome playerId
-            bracket
-                (atomically $ joinPlayer room playerId (WS.sendTextData conn))
-                (\() -> atomically $ leavePlayer room playerId)
-                (\() -> loop conn)
+        WS.withPingThread conn 30 (pure ()) $ bracket
+            (atomically $ joinRoom room (WS.sendTextData conn))
+            (\playerId -> do
+                atomically $ leaveRoom room playerId
+                syncRoom room)
+            (\playerId -> do
+                syncRoom room
+                loop conn roomId playerId)
   where
-    loop conn = forever $ do
+    loop conn roomId playerId = forever $ do
         WS.sendTextData conn $ Aeson.encode Bye
         threadDelay $ 1 * 1000000
 
diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs
index 682e80b..871037e 100644
--- a/server/lib/Cafp/Messages.hs
+++ b/server/lib/Cafp/Messages.hs
@@ -1,13 +1,21 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Cafp.Messages
-    ( ServerMessage (..)
+    ( GameView (..)
+    , ServerMessage (..)
     ) where
 
+import           Data.Text  (Text)
 import           Elm.Derive
 
+data GameView = GameView
+    { gameViewPlayers :: [Text]
+    } deriving (Show)
+
 data ServerMessage
     = Welcome Int
+    | SyncGameView GameView
     | Bye
     deriving (Show)
 
+deriveBoth (defaultOptionsDropLower 8) ''GameView
 deriveBoth defaultOptions ''ServerMessage