diff options
Diffstat (limited to 'server/lib/Cafp')
| -rw-r--r-- | server/lib/Cafp/Game.hs | 14 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/GenerateElmTypes.hs | 1 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/Server.hs | 15 | ||||
| -rw-r--r-- | server/lib/Cafp/Messages.hs | 12 |
4 files changed, 28 insertions, 14 deletions
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs index ad33368..740eac5 100644 --- a/server/lib/Cafp/Game.hs +++ b/server/lib/Cafp/Game.hs @@ -5,6 +5,7 @@ module Cafp.Game ( PlayerId , Cards (..) , Game (..) + , gameCards, gamePlayers, gameNextPlayerId , newGame , joinGame @@ -16,7 +17,8 @@ module Cafp.Game ) where import Cafp.Messages -import Control.Lens (at, ix, over, (%~), (&), (.~), (^.), (^?)) +import Control.Lens (at, ix, over, to, (%~), (&), (.~), (^.), + (^?)) import Control.Lens.TH (makeLenses) import qualified Data.HashMap.Strict as HMS import Data.Maybe (fromMaybe) @@ -25,18 +27,12 @@ import qualified Data.Text as T type PlayerId = Int -data Cards = Cards - { _cardsBlack :: [BlackCard] - , _cardsWhite :: [WhiteCard] - } deriving (Show) - data Game = Game { _gameCards :: !Cards , _gamePlayers :: !(HMS.HashMap Int Text) , _gameNextPlayerId :: !Int } deriving (Show) -makeLenses ''Cards makeLenses ''Game newGame :: Cards -> Game @@ -65,6 +61,6 @@ gameViewForPlayer self game = GameView { gameViewOpponents = opponents , gameViewMyName = name - , gameViewBlackCard = game ^? gameCards . cardsBlack . ix 0 - , gameViewHand = take 10 $ game ^. gameCards . cardsWhite + , gameViewBlackCard = Just $ BlackCard 0 + , gameViewHand = [WhiteCard x | x <- [0 .. 9]] } diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs index 51376a5..7900b1c 100644 --- a/server/lib/Cafp/Main/GenerateElmTypes.hs +++ b/server/lib/Cafp/Main/GenerateElmTypes.hs @@ -12,6 +12,7 @@ main :: IO () main = putStrLn $ makeElmModule "Messages" [ DefineElm (Proxy :: Proxy BlackCard) , DefineElm (Proxy :: Proxy WhiteCard) + , DefineElm (Proxy :: Proxy Cards) , 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 3edf039..e6e353f 100644 --- a/server/lib/Cafp/Main/Server.hs +++ b/server/lib/Cafp/Main/Server.hs @@ -9,6 +9,7 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.STM (STM, TVar, atomically) import qualified Control.Concurrent.STM as STM import Control.Exception (bracket) +import Control.Lens ((^.)) import Control.Monad (forever, when) import qualified Data.Aeson as Aeson import qualified Data.ByteString as B @@ -20,6 +21,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL +import qualified Data.Vector as V import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WebSockets as WaiWs @@ -46,8 +48,11 @@ data Server = Server readCards :: IO Cards readCards = Cards - <$> fmap (map BlackCard . T.lines) (T.readFile "assets/black.txt") - <*> fmap (map WhiteCard . T.lines) (T.readFile "assets/white.txt") + <$> fmap parseCards (T.readFile "assets/black.txt") + <*> fmap parseCards (T.readFile "assets/white.txt") + where + parseCards = + filter (not . T.isPrefixOf "#") . filter (not . T.null) . T.lines newServer :: IO Server newServer = Server <$> readCards <*> atomically (STM.newTVar HMS.empty) @@ -117,13 +122,17 @@ wsApp server pc = case routePendingConnection pc of Just roomId -> do room <- atomically $ getOrCreateRoom server roomId conn <- WS.acceptRequest pc + let sink = WS.sendTextData conn WS.withPingThread conn 30 (pure ()) $ bracket - (atomically $ joinRoom room (WS.sendTextData conn)) + (atomically $ joinRoom room sink) (\playerId -> do atomically $ leaveRoom room playerId syncRoom room) (\playerId -> do syncRoom room + cards <- fmap (^. gameCards) . atomically . STM.readTVar $ + roomGame room + sink . Aeson.encode $ SyncCards cards loop conn roomId playerId) where loop conn roomId playerId = forever $ do diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs index 542189f..219efb4 100644 --- a/server/lib/Cafp/Messages.hs +++ b/server/lib/Cafp/Messages.hs @@ -2,6 +2,7 @@ module Cafp.Messages ( BlackCard (..) , WhiteCard (..) + , Cards (..) , GameView (..) , ServerMessage (..) , ClientMessage (..) @@ -10,9 +11,14 @@ module Cafp.Messages import Data.Text (Text) import Elm.Derive -data BlackCard = BlackCard Text deriving (Show) +data BlackCard = BlackCard Int deriving (Show) -data WhiteCard = WhiteCard Text deriving (Show) +data WhiteCard = WhiteCard Int deriving (Show) + +data Cards = Cards + { cardsBlack :: [Text] + , cardsWhite :: [Text] + } deriving (Show) data GameView = GameView { gameViewOpponents :: [Text] @@ -23,6 +29,7 @@ data GameView = GameView data ServerMessage = Welcome Int + | SyncCards Cards | SyncGameView GameView | Bye deriving (Show) @@ -33,6 +40,7 @@ data ClientMessage deriveBoth defaultOptions ''BlackCard deriveBoth defaultOptions ''WhiteCard +deriveBoth (defaultOptionsDropLower 5) ''Cards deriveBoth (defaultOptionsDropLower 8) ''GameView deriveBoth defaultOptions ''ServerMessage deriveBoth defaultOptions ''ClientMessage |