Allow people to change their name

7 files changed, 139 insertions, 19 deletions

diff --git a/client/src/Client.elm b/client/src/Client.elm
index 442f089..e5afa74 100644
--- a/client/src/Client.elm
+++ b/client/src/Client.elm
@@ -2,7 +2,10 @@ port module Client exposing (main)
 
 import Browser
 import Html exposing (Html)
+import Html.Attributes
+import Html.Events
 import Json.Decode
+import Json.Encode
 import Messages exposing (GameView)
 import Url exposing (Url)
 
@@ -13,6 +16,10 @@ type Msg
     = Ignore
     | Send
     | WebSocketIn String
+    -- Name changes
+    | StartChangingName
+    | ChangeName String
+    | SubmitNewName
 
 type Model
     = Error String
@@ -21,6 +28,7 @@ type Model
         }
     | Game
         { view : GameView
+        , changingName : Maybe String
         }
 
 parseRoomId : Url -> Result String String
@@ -39,16 +47,38 @@ view model = case model of
             [Html.text <| "Connecting to room " ++ state.roomId ++ "..."]
         ]
     Game game ->
-        [ Html.h1 [] [Html.text "Players"]
+        [ Html.h1 [] [Html.text "Opponents"]
         , Html.ul [] <| List.map
             (\p -> Html.li [] [Html.text p])
-            game.view.players
-        ]
+            game.view.opponents
+        , Html.h1 [] [Html.text "You"]
+        ] ++
+        (case game.changingName of
+            Nothing ->
+                [ Html.p []
+                    [Html.text game.view.playerName]
+                , Html.button
+                    [Html.Events.onClick StartChangingName]
+                    [Html.text "change"]
+                ]
+            Just name ->
+                [ Html.input
+                    [ Html.Attributes.value name
+                    , Html.Events.onInput ChangeName
+                    ]
+                    []
+                , Html.button
+                    [Html.Events.onClick SubmitNewName]
+                    [Html.text "change"]
+                ])
 
 
 subscriptions : Model -> Sub Msg
 subscriptions model = webSocketIn WebSocketIn
 
+send : Messages.ClientMessage -> Cmd Msg
+send = webSocketOut << Json.Encode.encode 0 << Messages.jsonEncClientMessage
+
 update : Msg -> Model -> (Model, Cmd Msg)
 update msg model = case msg of
     Ignore -> (model, Cmd.none)
@@ -60,7 +90,31 @@ update msg model = case msg of
                 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)
+                case model of
+                    Game game -> (Game {game | view = gameView}, Cmd.none)
+                    _ ->
+                        ( Game
+                            { view = gameView
+                            , changingName = Nothing
+                            }
+                        , Cmd.none
+                        )
+
+    StartChangingName -> case model of
+        Game game ->
+            (Game {game | changingName = Just game.view.playerName}, Cmd.none)
+        _ -> (model, Cmd.none)
+    ChangeName name -> case model of
+        Game game -> (Game {game | changingName = Just name}, Cmd.none)
+        _ -> (model, Cmd.none)
+    SubmitNewName -> case model of
+        Game game ->
+            ( Game {game | changingName = Nothing}
+            , case game.changingName of
+                Nothing   -> Cmd.none
+                Just name -> send <| Messages.ChangeName name
+            )
+        _ -> (model, Cmd.none)
 
 main : Program () Model Msg
 main = Browser.application
diff --git a/client/src/Messages.elm b/client/src/Messages.elm
index 2239a74..730a66d 100644
--- a/client/src/Messages.elm
+++ b/client/src/Messages.elm
@@ -9,16 +9,23 @@ import Set exposing (Set)
 
 
 type alias GameView  =
-   { players: (List String)
+   { opponents: (List String)
+   , playerName: String
    }
 
 jsonDecGameView : Json.Decode.Decoder ( GameView )
 jsonDecGameView =
-   Json.Decode.succeed (\pplayers -> {players = pplayers}) |> custom (Json.Decode.list (Json.Decode.string))
+   Json.Decode.succeed (\popponents pplayerName -> {opponents = popponents, playerName = pplayerName})
+   |> required "opponents" (Json.Decode.list (Json.Decode.string))
+   |> required "playerName" (Json.Decode.string)
 
 jsonEncGameView : GameView -> Value
 jsonEncGameView  val =
-   (Json.Encode.list Json.Encode.string) val.players
+   Json.Encode.object
+   [ ("opponents", (Json.Encode.list Json.Encode.string) val.opponents)
+   , ("playerName", Json.Encode.string val.playerName)
+   ]
+
 
 
 type ServerMessage  =
@@ -44,3 +51,17 @@ jsonEncServerMessage  val =
     in encodeSumObjectWithSingleField keyval val
 
 
+
+type ClientMessage  =
+    ChangeName String
+
+jsonDecClientMessage : Json.Decode.Decoder ( ClientMessage )
+jsonDecClientMessage =
+    Json.Decode.lazy (\_ -> Json.Decode.map ChangeName (Json.Decode.string))
+
+
+jsonEncClientMessage : ClientMessage -> Value
+jsonEncClientMessage (ChangeName v1) =
+    Json.Encode.string v1
+
+
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