aboutsummaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
Diffstat (limited to 'server')
-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
5 files changed, 91 insertions, 29 deletions
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-23 10:51:10 +0000