aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--client/src/Client.elm62
-rw-r--r--client/src/Messages.elm27
-rw-r--r--server/cafp.cabal1
-rw-r--r--server/lib/Cafp/Game.hs39
-rw-r--r--server/lib/Cafp/Main/GenerateElmTypes.hs1
-rw-r--r--server/lib/Cafp/Main/Server.hs19
-rw-r--r--server/lib/Cafp/Messages.hs9
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 15:58:39 +0000