aboutsummaryrefslogtreecommitdiff
path: root/server/lib
diff options
context:
space:
mode:
authorJasper Van der Jeugt2020-07-30 16:16:52 +0200
committerJasper Van der Jeugt2020-07-30 16:16:52 +0200
commitf5a7875d605010540ec7c9c8f2a3ff4ed0702597 (patch)
tree2ea9642ff2c50ee86d861126d8a766fbd922e3d8 /server/lib
parent4e1068c41b84f0813b82fe61816271b92ca76f48 (diff)
Allow people to change their name
Diffstat (limited to 'server/lib')
-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
4 files changed, 56 insertions, 12 deletions
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