Allow people to change their name

5 files changed, 57 insertions, 12 deletions

diff --git a/server/cafp.cabal b/server/cafp.cabal
index 7f0f3b4..0dc068b 100644
--- a/server/cafp.cabal
+++ b/server/cafp.cabal
@@ -26,6 +26,7 @@ Library
     base                 >= 4.9  && < 5,
     bytestring           >= 0.10 && < 0.11,
     elm-bridge           >= 0.5  && < 0.6,
+    lens                 >= 4.18 && < 4.19,
     scotty               >= 0.11 && < 0.12,
     stm                  >= 2.5  && < 2.6,
     text                 >= 1.2  && < 1.3,
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs
index a5f367a..f3d500f 100644
--- a/server/lib/Cafp/Game.hs
+++ b/server/lib/Cafp/Game.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
 module Cafp.Game
     ( PlayerId
     , Game (..)
@@ -8,33 +9,53 @@ module Cafp.Game
     , joinGame
     , leaveGame
 
+    , processClientMessage
+
     , gameViewForPlayer
     ) where
 
 import           Cafp.Messages
+import           Control.Lens        (at, ix, over, (%~), (&), (.~), (^.))
+import           Control.Lens.TH     (makeLenses)
 import qualified Data.HashMap.Strict as HMS
+import           Data.Maybe          (fromMaybe)
 import           Data.Text           (Text)
 import qualified Data.Text           as T
 
 type PlayerId = Int
 
 data Game = Game
-    { gamePlayers      :: !(HMS.HashMap Int Text)
-    , gameNextPlayerId :: !Int
+    { _gamePlayers      :: !(HMS.HashMap Int Text)
+    , _gameNextPlayerId :: !Int
     } deriving (Show)
 
+makeLenses ''Game
+
 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})
+joinGame game =
+    let pid = game ^. gameNextPlayerId
+        name = "Player " <> T.pack (show pid) in
+    ( pid
+    , game & gameNextPlayerId %~ succ & gamePlayers %~ HMS.insert pid name
+    )
+
 
 leaveGame :: PlayerId -> Game -> Game
-leaveGame pid game = game {gamePlayers = HMS.delete pid $ gamePlayers game}
+leaveGame pid = over gamePlayers $ HMS.delete pid
+
+processClientMessage :: PlayerId -> ClientMessage -> Game -> Game
+processClientMessage pid msg game = case msg of
+    ChangeName name ->
+        game & gamePlayers . ix pid .~ name
 
 gameViewForPlayer :: PlayerId -> Game -> GameView
-gameViewForPlayer _ = GameView . map snd . HMS.toList . gamePlayers
+gameViewForPlayer self game =
+    let opponents = map snd . HMS.toList . HMS.delete self $ game ^. gamePlayers
+        name = fromMaybe "" $ game ^. gamePlayers . at self in
+    GameView
+        { gameViewOpponents  = opponents
+        , gameViewPlayerName = name
+        }
diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs
index 3728850..9c72027 100644
--- a/server/lib/Cafp/Main/GenerateElmTypes.hs
+++ b/server/lib/Cafp/Main/GenerateElmTypes.hs
@@ -12,4 +12,5 @@ main :: IO ()
 main = putStrLn $ makeElmModule "Messages"
     [ 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 c71709e..e87bfb5 100644
--- a/server/lib/Cafp/Main/Server.hs
+++ b/server/lib/Cafp/Main/Server.hs
@@ -23,8 +23,12 @@ import qualified Network.Wai                    as Wai
 import qualified Network.Wai.Handler.Warp       as Warp
 import qualified Network.Wai.Handler.WebSockets as WaiWs
 import qualified Network.WebSockets             as WS
+import qualified System.IO                      as IO
 import qualified Web.Scotty                     as Scotty
 
+warning :: String -> IO ()
+warning = IO.hPutStrLn IO.stderr
+
 type RoomId = T.Text
 
 type Sink = BL.ByteString -> IO ()
@@ -90,6 +94,7 @@ syncRoom room = do
     (game, sinks) <- atomically $ (,)
         <$> STM.readTVar (roomGame room)
         <*> STM.readTVar (roomSinks room)
+    warning $ "New state: " ++ show game
     for_ (HMS.toList sinks) $ \(pid, sink) ->
         sink . Aeson.encode . SyncGameView $ gameViewForPlayer pid game
 
@@ -109,8 +114,18 @@ wsApp server pc = case routePendingConnection pc of
                 loop conn roomId playerId)
   where
     loop conn roomId playerId = forever $ do
-        WS.sendTextData conn $ Aeson.encode Bye
-        threadDelay $ 1 * 1000000
+        msg <- WS.receiveData conn
+        case Aeson.decode msg of
+            Just cm -> do
+                warning $ "Client: " ++ show cm
+                room <- atomically $ do
+                    room <- getOrCreateRoom server roomId
+                    STM.modifyTVar' (roomGame room) $
+                        processClientMessage playerId cm
+                    pure room
+                syncRoom room
+            Nothing -> do
+                warning $ "Could not decode client message: " ++ show msg
 
 main :: IO ()
 main = do
diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs
index 871037e..d92ce80 100644
--- a/server/lib/Cafp/Messages.hs
+++ b/server/lib/Cafp/Messages.hs
@@ -2,13 +2,15 @@
 module Cafp.Messages
     ( GameView (..)
     , ServerMessage (..)
+    , ClientMessage (..)
     ) where
 
 import           Data.Text  (Text)
 import           Elm.Derive
 
 data GameView = GameView
-    { gameViewPlayers :: [Text]
+    { gameViewOpponents  :: [Text]
+    , gameViewPlayerName :: Text
     } deriving (Show)
 
 data ServerMessage
@@ -17,5 +19,10 @@ data ServerMessage
     | Bye
     deriving (Show)
 
+data ClientMessage
+    = ChangeName Text
+    deriving (Show)
+
 deriveBoth (defaultOptionsDropLower 8) ''GameView
 deriveBoth defaultOptions ''ServerMessage
+deriveBoth defaultOptions ''ClientMessage