aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--client/src/Client.elm14
-rw-r--r--client/src/Messages.elm16
-rw-r--r--server/cafp.cabal1
-rw-r--r--server/lib/Cafp/Game.hs40
-rw-r--r--server/lib/Cafp/Main/GenerateElmTypes.hs3
-rw-r--r--server/lib/Cafp/Main/Server.hs66
-rw-r--r--server/lib/Cafp/Messages.hs10
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 16:14:03 +0000