diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/cafp.cabal | 1 | ||||
| -rw-r--r-- | server/lib/Cafp/Game.hs | 39 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/GenerateElmTypes.hs | 1 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/Server.hs | 19 | ||||
| -rw-r--r-- | server/lib/Cafp/Messages.hs | 9 |
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 |