diff options
Diffstat (limited to 'server/lib/Uplcg')
| -rw-r--r-- | server/lib/Uplcg/CookieSocket.hs | 86 | ||||
| -rw-r--r-- | server/lib/Uplcg/Game.hs | 332 | ||||
| -rw-r--r-- | server/lib/Uplcg/Main/GenerateElmTypes.hs | 22 | ||||
| -rw-r--r-- | server/lib/Uplcg/Main/Server.hs | 214 | ||||
| -rw-r--r-- | server/lib/Uplcg/Messages.hs | 87 |
5 files changed, 741 insertions, 0 deletions
diff --git a/server/lib/Uplcg/CookieSocket.hs b/server/lib/Uplcg/CookieSocket.hs new file mode 100644 index 0000000..7efb8b2 --- /dev/null +++ b/server/lib/Uplcg/CookieSocket.hs @@ -0,0 +1,86 @@ +-- | Allows websockets to reconnect and recover state by storing a cookie client +-- side. +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +module Uplcg.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/Uplcg/Game.hs b/server/lib/Uplcg/Game.hs new file mode 100644 index 0000000..02e40cb --- /dev/null +++ b/server/lib/Uplcg/Game.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +module Uplcg.Game + ( PlayerId + , Table (..) + , Player (..) + , Game (..) + , gameLog, gameCards, gamePlayers, gameNextPlayerId + + , newGame + , joinGame + , leaveGame + + , processClientMessage + + , gameViewForPlayer + ) where + +import Uplcg.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/Uplcg/Main/GenerateElmTypes.hs b/server/lib/Uplcg/Main/GenerateElmTypes.hs new file mode 100644 index 0000000..bc2481c --- /dev/null +++ b/server/lib/Uplcg/Main/GenerateElmTypes.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +module Uplcg.Main.GenerateElmTypes + ( main + ) where + +import Uplcg.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/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs new file mode 100644 index 0000000..a2914ab --- /dev/null +++ b/server/lib/Uplcg/Main/Server.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE OverloadedStrings #-} +module Uplcg.Main.Server + ( main + ) where + +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 Uplcg.CookieSocket as CookieSocket +import Uplcg.Game +import Uplcg.Messages +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 "UPLCG_HOSTNAME" + port <- read <$> getEnv "UPLCG_PORT" + base <- splitPath . T.pack <$> getEnv "UPLCG_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/Uplcg/Messages.hs b/server/lib/Uplcg/Messages.hs new file mode 100644 index 0000000..b1627e9 --- /dev/null +++ b/server/lib/Uplcg/Messages.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +module Uplcg.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 |