From 8d5c0405565ad4afd976efd1262b3224efd6ee2f Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 13 Aug 2020 19:19:22 +0200 Subject: cafp -> uplcg --- server/lib/Cafp/CookieSocket.hs | 86 -------- server/lib/Cafp/Game.hs | 332 ------------------------------- server/lib/Cafp/Main/GenerateElmTypes.hs | 22 -- server/lib/Cafp/Main/Server.hs | 214 -------------------- server/lib/Cafp/Messages.hs | 87 -------- 5 files changed, 741 deletions(-) delete mode 100644 server/lib/Cafp/CookieSocket.hs delete mode 100644 server/lib/Cafp/Game.hs delete mode 100644 server/lib/Cafp/Main/GenerateElmTypes.hs delete mode 100644 server/lib/Cafp/Main/Server.hs delete mode 100644 server/lib/Cafp/Messages.hs (limited to 'server/lib/Cafp') diff --git a/server/lib/Cafp/CookieSocket.hs b/server/lib/Cafp/CookieSocket.hs deleted file mode 100644 index 5770a3b..0000000 --- a/server/lib/Cafp/CookieSocket.hs +++ /dev/null @@ -1,86 +0,0 @@ --- | Allows websockets to reconnect and recover state by storing a cookie client --- side. -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -module Cafp.CookieSocket - ( Handle - , withHandle - , CookieName - , acceptRequest - , persist - ) where - -import Control.Concurrent (threadDelay) -import qualified Control.Concurrent.Async as Async -import Control.Concurrent.MVar (MVar) -import qualified Control.Concurrent.MVar as MVar -import Control.Monad (forever, guard) -import Data.Hashable (Hashable) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HMS -import Data.Maybe (listToMaybe) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Time as Time -import Data.UUID (UUID) -import qualified Data.UUID as UUID -import qualified Data.UUID.V4 as UUID.V4 -import qualified Network.WebSockets as WS - -type CookieName = T.Text - -newtype Secret = Secret UUID deriving (Eq, Hashable) - -data Handle v = Handle - { hMinutes :: Int -- Minutes after which expiry happens - , hStore :: MVar (HashMap Secret (Time.UTCTime, v)) - } - -withHandle :: Int -> (Handle v -> IO a) -> IO a -withHandle minutes f = do - store <- MVar.newMVar HMS.empty - Async.withAsync (reaper store) $ \_ -> f $ Handle minutes store - where - -- This is really shitty and we should probably do something with - -- monotonic time. - reaper store = forever $ do - threadDelay $ minutes * 60 * 1000 * 1000 - now <- Time.getCurrentTime - MVar.modifyMVar_ store $ pure . HMS.filter ((> now) . fst) - -parseCookie :: CookieName -> WS.PendingConnection -> Maybe T.Text -parseCookie name pc = listToMaybe $ do - (header, values) <- WS.requestHeaders $ WS.pendingRequest pc - guard $ header == "Cookie" - part <- T.split (== ';') $ T.decodeUtf8 values - let (key, val) = T.break (== '=') part - guard $ T.strip key == name - guard $ "=" `T.isPrefixOf` val - pure . T.strip $ T.drop 1 val - -makeCookie :: CookieName -> T.Text -> WS.Headers -makeCookie name val = [("Set-Cookie", T.encodeUtf8 $ name <> "=" <> val)] - -acceptRequest - :: Handle a -> CookieName -> WS.PendingConnection - -> IO (WS.Connection, Secret, Maybe a) -acceptRequest h name pc = case parseCookie name pc >>= UUID.fromText of - Just uuid -> do - conn <- WS.acceptRequest pc - store <- MVar.readMVar (hStore h) - pure (conn, Secret uuid, snd <$> HMS.lookup (Secret uuid) store) - Nothing -> do - uuid <- UUID.V4.nextRandom - conn <- WS.acceptRequestWith pc WS.defaultAcceptRequest - { WS.acceptHeaders = - makeCookie name (UUID.toText uuid) <> - WS.acceptHeaders WS.defaultAcceptRequest - } - pure (conn, Secret uuid, Nothing) - -persist :: Handle a -> Secret -> a -> IO () -persist h key x = MVar.modifyMVar_ (hStore h) $ \store -> do - expiry <- Time.addUTCTime diffTime <$> Time.getCurrentTime - pure $ HMS.insert key (expiry, x) store - where - diffTime = fromIntegral (60 * hMinutes h) diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs deleted file mode 100644 index 9ed3cc1..0000000 --- a/server/lib/Cafp/Game.hs +++ /dev/null @@ -1,332 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -module Cafp.Game - ( PlayerId - , Table (..) - , Player (..) - , Game (..) - , gameLog, gameCards, gamePlayers, gameNextPlayerId - - , newGame - , joinGame - , leaveGame - - , processClientMessage - - , gameViewForPlayer - ) where - -import Cafp.Messages -import Control.Lens (Lens', at, iall, ifor_, imap, ix, - orOf, to, (%%=), (%=), (%~), (&), - (+=), (.=), (.~), (^.), (^..), - (^?), _1, _2, _3) -import Control.Lens.TH (makeLenses, makePrisms) -import Control.Monad (guard) -import Control.Monad.State (State, execState, modify, - runState, state) -import Data.Bifunctor (first) -import Data.Foldable (for_) -import qualified Data.HashMap.Strict as HMS -import Data.List (sort) -import Data.Maybe (fromMaybe) -import Data.Ord (Down (..), comparing) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified Data.Vector.Algorithms.Merge as V -import Data.Vector.Instances () -import System.Random (StdGen) -import VectorShuffling.Immutable (shuffle) - -type PlayerId = Int - -type Proposal = V.Vector WhiteCard - -data Table - = TableProposing - !BlackCard - !(HMS.HashMap PlayerId Proposal) - | TableVoting - !BlackCard - !(V.Vector (Proposal, [PlayerId])) - !(HMS.HashMap PlayerId Int) - | TableTally - !BlackCard - !(V.Vector VotedView) - deriving (Show) - -data Player = Player - { _playerId :: !PlayerId - , _playerName :: !Text - , _playerHand :: !(V.Vector WhiteCard) - , _playerAdmin :: !Bool - , _playerPoints :: !Int - } deriving (Show) - -data Game = Game - { _gameCards :: !Cards - , _gameSeed :: !StdGen - , _gameLog :: ![Text] - , _gameBlack :: ![BlackCard] - , _gameWhite :: ![WhiteCard] - , _gamePlayers :: !(HMS.HashMap PlayerId Player) - , _gameTable :: !Table - , _gameNextPlayerId :: !Int - } deriving (Show) - -makePrisms ''Table -makeLenses ''Player -makeLenses ''Game - -popCard - :: (Cards -> V.Vector t) -> (Int -> c) -> Lens' Game [c] - -> State Game c -popCard getDeck mk queue = state $ \game -> case game ^. queue of - (x : xs) -> (x, game & queue .~ xs) - [] -> - let deck = game ^. gameCards . to getDeck - idxs = V.imap (\i _ -> mk i) deck - (cs, seed) = first V.toList $ shuffle idxs (game ^. gameSeed) in - case cs of - [] -> error "popCard: Cards are empty" - x : xs -> (x, game & queue .~ xs & gameSeed .~ seed) - -popBlackCard :: State Game BlackCard -popBlackCard = popCard cardsBlack BlackCard gameBlack - -popWhiteCard :: State Game WhiteCard -popWhiteCard = popCard cardsWhite WhiteCard gameWhite - -newGame :: Cards -> StdGen -> Game -newGame cards gen = flip execState state0 $ do - black <- popBlackCard - gameTable .= TableProposing black HMS.empty - where - state0 = Game - { _gameCards = cards - , _gameSeed = gen - , _gameLog = [] - , _gameBlack = [] - , _gameWhite = [] - , _gamePlayers = HMS.empty - , _gameTable = TableProposing (BlackCard 0) HMS.empty - , _gameNextPlayerId = 1 - } - -defaultHandSize :: Int -defaultHandSize = 8 - -drawNewWhiteCards :: Game -> Game -drawNewWhiteCards game = flip execState game $ do - ifor_ (game ^. gamePlayers) $ \pid player -> do - let num = defaultHandSize - V.length (player ^. playerHand) - new <- V.replicateM num popWhiteCard - gamePlayers . ix pid . playerHand %= (<> new) - -assignAdmin :: Game -> Game -assignAdmin game - -- Admin already assigned. - | orOf (gamePlayers . traverse . playerAdmin) game = game - -- Assign to first player - | (p1 : _) <- sort (game ^. gamePlayers . to HMS.keys) = - game & gamePlayers . ix p1 . playerAdmin .~ True - -- No players - | otherwise = game - -joinGame :: Maybe Player -> Game -> (PlayerId, Game) -joinGame mbPlayer = runState $ do - player <- case mbPlayer of - Nothing -> do - pid <- gameNextPlayerId %%= (\x -> (x, x + 1)) - let name = "Player " <> T.pack (show pid) - hand <- V.replicateM defaultHandSize popWhiteCard - pure $ Player pid name hand False 0 - Just p -> pure $ p & playerAdmin .~ False - gamePlayers %= HMS.insert (player ^. playerId) player - modify assignAdmin - pure $ player ^. playerId - -leaveGame :: PlayerId -> Game -> (Maybe Player, Game) -leaveGame pid game = case game ^? gamePlayers . ix pid of - Nothing -> (Nothing, game) - Just p -> (Just p, assignAdmin $ game & gamePlayers %~ HMS.delete pid) - -blackCardBlanks :: Cards -> BlackCard -> Int -blackCardBlanks cards (BlackCard c) = - maybe 0 (length . T.breakOnAll "\\BLANK") $ cardsBlack cards V.!? c - -maximaOn :: Ord o => (a -> o) -> [a] -> [a] -maximaOn f = \case [] -> []; x : xs -> go [x] (f x) xs - where - go best _ [] = reverse best - go best bestScore (x : xs) = - let score = f x in - case compare score bestScore of - LT -> go best bestScore xs - EQ -> go (x : best) bestScore xs - GT -> go [x] score xs - -tallyVotes - :: Game - -> (V.Vector (Proposal, [PlayerId])) - -> (HMS.HashMap PlayerId Int) - -> (V.Vector VotedView, [PlayerId]) -tallyVotes game shuffled votes = - let counts :: HMS.HashMap Int Int -- Index, votes received. - counts = HMS.fromListWith (+) [(idx, 1) | (_, idx) <- HMS.toList votes] - best = map fst . maximaOn snd $ HMS.toList counts in - ( byScore $ V.imap (\i (proposal, players) -> VotedView - { votedProposal = proposal - , votedScore = fromMaybe 0 $ HMS.lookup i counts - , votedWinners = V.fromList $ do - guard $ i `elem` best - p <- players - game ^.. gamePlayers . ix p . playerName - }) - shuffled - , [player | idx <- best, player <- snd $ shuffled V.! idx] - ) - where - byScore = V.modify $ V.sortBy . comparing $ Down . votedScore - --- | Create nice messages about the winners in the logs. -votedMessages :: Cards -> BlackCard -> V.Vector VotedView -> [T.Text] -votedMessages cards (BlackCard black) voteds = do - voted <- V.toList voteds - guard $ V.length (votedWinners voted) > 0 - pure $ - T.intercalate ", " (V.toList $ votedWinners voted) <> " won with " <> - cardsBlack cards V.! black <> " | " <> - T.intercalate " / " - [ cardsWhite cards V.! i - | WhiteCard i <- V.toList $ votedProposal voted - ] - -stepGame :: Bool -> Game -> Game -stepGame skip game = case game ^. gameTable of - TableProposing black proposals - -- Everyone has proposed. - | skip || iall (const . (`HMS.member` proposals)) (game ^. gamePlayers) -> - let proposalsMap = HMS.fromListWith (++) $ do - (pid, proposal) <- HMS.toList proposals - pure (proposal, [pid]) - (shuffled, seed) = shuffle - (V.fromList $ HMS.toList proposalsMap) (game ^. gameSeed) in - -- There's a recursive call because in some one-player cases we - -- skip the voting process entirely. - stepGame False $ game - & gameSeed .~ seed - & gameTable .~ TableVoting black shuffled HMS.empty - & gamePlayers %~ imap (\pid player -> - let used = fromMaybe V.empty $ HMS.lookup pid proposals in - player & playerHand %~ V.filter (not . (`V.elem` used))) - | otherwise -> game - - TableVoting black shuffled votes - -- Everyone has voted. - | skip || iall hasVoted (game ^. gamePlayers) -> - let (voted, wins) = tallyVotes game shuffled votes in - flip execState game $ do - for_ wins $ \win -> gamePlayers . ix win . playerPoints += 1 - gameTable .= TableTally black voted - gameLog %= (votedMessages (game ^. gameCards) black voted ++) - | otherwise -> game - where - hasVoted pid _ = HMS.member pid votes || - -- The person cannot vote for anything since all the proposals - -- are theirs. This can happen when the game starts out with a - -- single person. - V.all (\(_, pids) -> pid `elem` pids) shuffled - - TableTally _ _ -> game - -processClientMessage :: PlayerId -> ClientMessage -> Game -> Game -processClientMessage pid msg game = case msg of - ChangeMyName name - | T.length name > 32 -> game - | otherwise -> game & gamePlayers . ix pid . playerName .~ name - - ProposeWhiteCards cs - -- Bad card(s) proposed, i.e. not in hand of player. - | any (not . (`elem` hand)) cs -> game - -- Proposal already made. - | Just _ <- game ^? gameTable . _TableProposing . _2 . ix pid -> game - -- Not enough cards submitted. - | Just b <- game ^? gameTable . _TableProposing . _1 - , blackCardBlanks (game ^. gameCards) b /= length cs -> game - -- All good. - | otherwise -> stepGame False $ - game & gameTable . _TableProposing . _2 . at pid .~ Just cs - - SubmitVote i -> case game ^. gameTable of - TableProposing _ _ -> game - TableTally _ _ -> game - TableVoting _ shuffled votes - -- Vote out of bounds. - | i < 0 || i >= V.length shuffled -> game - -- Already voted. - | pid `HMS.member` votes -> game - -- Can't vote for self. - | pid `elem` snd (shuffled V.! i) -> game - -- Ok vote. - | otherwise -> stepGame False $ game - & gameTable . _TableVoting . _3 . at pid .~ Just i - - AdminConfirmTally - | TableTally _ _ <- game ^. gameTable, admin -> - flip execState game $ do - black <- popBlackCard - gameTable .= TableProposing black HMS.empty - modify drawNewWhiteCards - | otherwise -> game - - AdminSkipProposals - | TableProposing _ _ <- game ^. gameTable, admin -> stepGame True $ - game & gameLog %~ ("Admin skipped proposals" :) - | otherwise -> game - - AdminSkipVotes - | TableVoting _ _ _ <- game ^. gameTable, admin -> stepGame True $ - game & gameLog %~ ("Admin skipped votes" :) - | otherwise -> game - where - hand = game ^.. gamePlayers . ix pid . playerHand . traverse - admin = fromMaybe False $ game ^? gamePlayers . ix pid . playerAdmin - -gameViewForPlayer :: PlayerId -> Game -> GameView -gameViewForPlayer self game = - let playerView pid player = PlayerView - { playerViewName = player ^. playerName - , playerViewAdmin = player ^. playerAdmin - , playerViewReady = case game ^. gameTable of - TableProposing _ proposals -> HMS.member pid proposals - TableVoting _ _ votes -> HMS.member pid votes - TableTally _ _ -> False - , playerViewPoints = player ^. playerPoints - } - - table = case game ^. gameTable of - TableProposing black proposals -> - Proposing black . fromMaybe V.empty $ HMS.lookup self proposals - TableVoting black shuffled votes -> Voting - black - (fst <$> shuffled) - (V.findIndex ((self `elem`) . snd) shuffled) - (HMS.lookup self votes) - TableTally black voted -> Tally black voted in - GameView - { gameViewPlayers = V.fromList . map snd . HMS.toList - . HMS.delete self . imap playerView $ game ^. gamePlayers - , gameViewMe = maybe dummy (playerView self) $ - game ^? gamePlayers . ix self - , gameViewTable = table - , gameViewHand = fromMaybe V.empty $ - game ^? gamePlayers . ix self . playerHand - } - - where - dummy = PlayerView "" False False 0 diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs deleted file mode 100644 index ccf19e8..0000000 --- a/server/lib/Cafp/Main/GenerateElmTypes.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TemplateHaskell #-} -module Cafp.Main.GenerateElmTypes - ( main - ) where - -import Cafp.Messages -import Data.Proxy -import Elm.Module - -main :: IO () -main = putStrLn $ makeElmModule "Messages" - [ DefineElm (Proxy :: Proxy BlackCard) - , DefineElm (Proxy :: Proxy WhiteCard) - , DefineElm (Proxy :: Proxy Cards) - , DefineElm (Proxy :: Proxy PlayerView) - , DefineElm (Proxy :: Proxy VotedView) - , DefineElm (Proxy :: Proxy TableView) - , 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 deleted file mode 100644 index ba2425d..0000000 --- a/server/lib/Cafp/Main/Server.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Cafp.Main.Server - ( main - ) where - -import qualified Cafp.CookieSocket as CookieSocket -import Cafp.Game -import Cafp.Messages -import Control.Concurrent.MVar (MVar) -import qualified Control.Concurrent.MVar as MVar -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 -import qualified Data.ByteString.Lazy as BL -import Data.Char (isAlphaNum) -import Data.Foldable (for_) -import qualified Data.HashMap.Strict as HMS -import qualified Data.List as L -import Data.Maybe (fromMaybe, isNothing) -import Data.String (fromString) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -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 -import qualified Network.WebSockets as WS -import System.Environment (getEnv) -import qualified System.Log.FastLogger as FL -import System.Random (StdGen, newStdGen) -import qualified Web.Scotty as Scotty - -type RoomId = T.Text - -type Sink = BL.ByteString -> IO () - -data Room = Room - { roomId :: RoomId - , roomGame :: TVar Game - , roomSinks :: TVar (HMS.HashMap PlayerId Sink) - } - -data Server = Server - { serverLogger :: FL.FastLogger - , serverCookieSocket :: CookieSocket.Handle Player - , serverCards :: Cards - , serverRooms :: MVar (HMS.HashMap RoomId Room) - } - -readCards :: IO Cards -readCards = Cards - <$> fmap parseCards (T.readFile "assets/black.txt") - <*> fmap parseCards (T.readFile "assets/white.txt") - where - parseCards = V.fromList . filter (not . T.null) . map dropComment . T.lines - dropComment = T.strip . fst . T.break (== '#') - -withServer :: FL.FastLogger -> (Server -> IO a) -> IO a -withServer fl f = CookieSocket.withHandle 5 $ \cs -> do - f =<< Server fl cs <$> readCards <*> MVar.newMVar HMS.empty - -newRoom :: RoomId -> Cards -> StdGen -> STM Room -newRoom rid cards gen = Room rid - <$> STM.newTVar (newGame cards gen) - <*> STM.newTVar HMS.empty - -parseRoomId :: T.Text -> Either String T.Text -parseRoomId txt - | T.all isAlphaNum txt && T.length txt >= 6 = Right txt - | otherwise = Left "Bad room name" - -scottyApp :: IO Wai.Application -scottyApp = Scotty.scottyApp $ do - Scotty.get "/rooms/:id/" $ do - rid <- Scotty.param "id" - when (T.length rid < 6) $ - Scotty.raise "Room ID should be at least 6 characters" - Scotty.setHeader "Content-Type" "text/html" - Scotty.file "assets/client.html" - - Scotty.get "/assets/client.js" $ do - Scotty.setHeader "Content-Type" "application/JavaScript" - Scotty.file "assets/client.js" - - Scotty.get "/assets/style.css" $ do - Scotty.setHeader "Content-Type" "text/css" - Scotty.file "assets/style.css" - -routePendingConnection :: WS.PendingConnection -> Maybe RoomId -routePendingConnection pending = - let path = T.decodeUtf8 . WS.requestPath $ WS.pendingRequest pending in - case splitPath path of - ["rooms", txt, "events"] | Right r <- parseRoomId txt -> Just r - _ -> Nothing - -getOrCreateRoom :: Server -> RoomId -> IO Room -getOrCreateRoom server rid = MVar.modifyMVar (serverRooms server) $ \rooms -> - case HMS.lookup rid rooms of - Just room -> pure (rooms, room) - Nothing -> do - gen <- newStdGen - serverLogger server $ "[" <> FL.toLogStr rid <> "] Created room" - room <- atomically $ newRoom rid (serverCards server) gen - pure (HMS.insert rid room rooms, room) - -deleteRoom :: Server -> RoomId -> IO () -deleteRoom server rid = do - serverLogger server $ "[" <> FL.toLogStr rid <> "] Deleting room" - MVar.modifyMVar_ (serverRooms server) $ pure . HMS.delete rid - -joinRoom :: Room -> Sink -> Maybe Player -> STM PlayerId -joinRoom room sink mbRecovered = do - pid <- STM.stateTVar (roomGame room) $ joinGame mbRecovered - STM.modifyTVar' (roomSinks room) $ HMS.insert pid sink - pure pid - -leaveRoom :: Room -> PlayerId -> STM (Bool, Maybe Player) -leaveRoom room pid = do - player <- STM.stateTVar (roomGame room) $ leaveGame pid - STM.stateTVar (roomSinks room) $ \sinks -> - let sinks' = HMS.delete pid sinks in - ((HMS.null sinks', player), sinks') - -syncRoom :: Server -> Room -> IO () -syncRoom server room = do - (game, sinks) <- atomically $ (,) - <$> STM.stateTVar (roomGame room) (\g -> (g, g & gameLog .~ [])) - <*> STM.readTVar (roomSinks room) - for_ (reverse $ game ^. gameLog) $ \msg -> - serverLogger server $ "[" <> FL.toLogStr (roomId room) <> "] " <> - FL.toLogStr msg - for_ (HMS.toList sinks) $ \(pid, sink) -> do - let view = gameViewForPlayer pid game - sink . Aeson.encode $ SyncGameView view - -wsApp :: Server -> WS.ServerApp -wsApp server pc = case routePendingConnection pc of - Nothing -> WS.rejectRequest pc "Invalid URL" - Just rid -> do - room <- getOrCreateRoom server rid - (conn, secret, mbRecovered) <- - CookieSocket.acceptRequest (serverCookieSocket server) rid pc - let sink = WS.sendTextData conn - WS.withPingThread conn 30 (pure ()) $ bracket - (do - pid <- atomically $ joinRoom room sink mbRecovered - serverLogger server $ "[" <> FL.toLogStr rid <> - "] Player " <> FL.toLogStr pid <> - if isNothing mbRecovered then " joined" else " rejoined" - pure pid) - (\pid -> do - (roomEmpty, mbPlayer) <- atomically $ leaveRoom room pid - serverLogger server $ "[" <> FL.toLogStr rid <> - "] Player " <> FL.toLogStr pid <> " left" - if roomEmpty - then deleteRoom server rid - else do - for_ mbPlayer $ CookieSocket.persist - (serverCookieSocket server) secret - syncRoom server room) - (\playerId -> do - sink . Aeson.encode $ Welcome rid - syncRoom server room - cards <- fmap (^. gameCards) . atomically . STM.readTVar $ - roomGame room - sink . Aeson.encode $ SyncCards cards - loop conn rid playerId) - where - loop conn rid playerId = forever $ do - msg <- WS.receiveData conn - case Aeson.decode msg of - Just cm -> do - room <- getOrCreateRoom server rid -- TODO: only get? - atomically . STM.modifyTVar' (roomGame room) $ - processClientMessage playerId cm - syncRoom server room - Nothing -> do - serverLogger server $ "Could not decode client message: " <> - FL.toLogStr (show msg) - -splitPath :: T.Text -> [T.Text] -splitPath = filter (not . T.null) . T.split (== '/') - -baseUrl :: [T.Text] -> Wai.Middleware -baseUrl prefix application = \req -> - case L.stripPrefix prefix (Wai.pathInfo req) of - Nothing -> application req - Just path -> application req - { Wai.pathInfo = path - , Wai.rawPathInfo = fromMaybe (Wai.rawPathInfo req) . - B.stripPrefix bs $ Wai.rawPathInfo req - } - where - bs = T.encodeUtf8 $ "/" <> T.intercalate "/" prefix - -main :: IO () -main = do - host <- fromString <$> getEnv "CAFP_HOSTNAME" - port <- read <$> getEnv "CAFP_PORT" - base <- splitPath . T.pack <$> getEnv "CAFP_BASE" - let settings = Warp.setPort port . Warp.setHost host $ Warp.defaultSettings - timeCache <- FL.newTimeCache FL.simpleTimeFormat - FL.withTimedFastLogger timeCache - (FL.LogStderr FL.defaultBufSize) $ \tfl -> - let fl s = tfl (\time -> FL.toLogStr time <> " " <> s <> "\n") in - withServer fl $ \server -> do - sapp <- scottyApp - Warp.runSettings settings $ baseUrl base $ - WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs deleted file mode 100644 index 5066447..0000000 --- a/server/lib/Cafp/Messages.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} -module Cafp.Messages - ( BlackCard (..) - , WhiteCard (..) - , Cards (..) - , PlayerView (..) - , VotedView (..) - , TableView (..) - , GameView (..) - , ServerMessage (..) - , ClientMessage (..) - ) where - -import Data.Hashable (Hashable) -import Data.Text (Text) -import Data.Vector (Vector) -import Elm.Derive -import GHC.Generics (Generic) - -data BlackCard = BlackCard Int deriving (Eq, Generic, Show) - -instance Hashable BlackCard - -data WhiteCard = WhiteCard Int deriving (Eq, Generic, Show) - -instance Hashable WhiteCard - -data Cards = Cards - { cardsBlack :: !(Vector Text) - , cardsWhite :: !(Vector Text) - } deriving (Show) - -data PlayerView = PlayerView - { playerViewName :: !Text - , playerViewAdmin :: !Bool - , playerViewReady :: !Bool - , playerViewPoints :: !Int - } deriving (Show) - -data VotedView = VotedView - { votedProposal :: !(Vector WhiteCard) - , votedScore :: !Int - , votedWinners :: !(Vector Text) - } deriving (Show) - -data TableView - = Proposing !BlackCard !(Vector WhiteCard) - | Voting - !BlackCard - !(Vector (Vector WhiteCard)) -- ^ Proposals to vote for - !(Maybe Int) -- ^ My proposal - !(Maybe Int) -- ^ My vote - | Tally !BlackCard !(Vector VotedView) - deriving (Show) - -data GameView = GameView - { gameViewPlayers :: !(Vector PlayerView) - , gameViewMe :: !PlayerView - , gameViewTable :: !TableView - , gameViewHand :: !(Vector WhiteCard) - } deriving (Show) - -data ServerMessage - = Welcome !Text - | SyncCards !Cards - | SyncGameView !GameView - deriving (Show) - -data ClientMessage - = ChangeMyName !Text - | ProposeWhiteCards !(Vector WhiteCard) - | SubmitVote !Int - | AdminSkipProposals - | AdminSkipVotes - | AdminConfirmTally - deriving (Show) - -deriveBoth defaultOptions ''BlackCard -deriveBoth defaultOptions ''WhiteCard -deriveBoth (defaultOptionsDropLower 5) ''Cards -deriveBoth (defaultOptionsDropLower 10) ''PlayerView -deriveBoth (defaultOptionsDropLower 5) ''VotedView -deriveBoth defaultOptions ''TableView -deriveBoth (defaultOptionsDropLower 8) ''GameView -deriveBoth defaultOptions ''ServerMessage -deriveBoth defaultOptions ''ClientMessage -- cgit v1.2.3