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 --- Dockerfile | 10 +- Makefile | 18 +- black.txt | 2 +- client/index.html | 12 +- client/src/Client.elm | 8 +- config.mk | 8 +- server/cafp.cabal | 63 ------ 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 -------- server/lib/Uplcg/CookieSocket.hs | 86 ++++++++ server/lib/Uplcg/Game.hs | 332 ++++++++++++++++++++++++++++++ server/lib/Uplcg/Main/GenerateElmTypes.hs | 22 ++ server/lib/Uplcg/Main/Server.hs | 214 +++++++++++++++++++ server/lib/Uplcg/Messages.hs | 87 ++++++++ server/src/GenerateElmTypes.hs | 4 +- server/src/Server.hs | 4 +- server/uplcg.cabal | 63 ++++++ 20 files changed, 837 insertions(+), 837 deletions(-) delete mode 100644 server/cafp.cabal 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 create mode 100644 server/lib/Uplcg/CookieSocket.hs create mode 100644 server/lib/Uplcg/Game.hs create mode 100644 server/lib/Uplcg/Main/GenerateElmTypes.hs create mode 100644 server/lib/Uplcg/Main/Server.hs create mode 100644 server/lib/Uplcg/Messages.hs create mode 100644 server/uplcg.cabal diff --git a/Dockerfile b/Dockerfile index 17b087b..593505e 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,9 +1,9 @@ FROM haskell:8.8 -WORKDIR /opt/cafp -COPY server/cafp.cabal server/stack.yaml* /opt/cafp/ +WORKDIR /opt/uplcg +COPY server/uplcg.cabal server/stack.yaml* /opt/uplcg/ RUN stack build --only-dependencies -COPY server /opt/cafp +COPY server /opt/uplcg RUN stack build -ENV CAFP_HOSTNAME=0.0.0.0 CAFP_PORT=8002 CAFP_BASE=/cafp +ENV UPLCG_HOSTNAME=0.0.0.0 UPLCG_PORT=8002 UPLCG_BASE=/uplcg EXPOSE 8002 -CMD stack exec cafp-server +CMD stack exec uplcg-server diff --git a/Makefile b/Makefile index 38caaef..e3e7947 100644 --- a/Makefile +++ b/Makefile @@ -14,23 +14,23 @@ build: server/assets/client.js \ .PHONY: docker docker: - docker build -t jaspervdj/cafp . - docker push jaspervdj/cafp + docker build -t jaspervdj/uplcg . + docker push jaspervdj/uplcg .PHONY: server server: build (cd server && \ - CAFP_HOSTNAME=$(CAFP_HOSTNAME) \ - CAFP_PORT=$(CAFP_PORT) \ - CAFP_BASE=$(CAFP_BASE) \ - stack exec cafp-server) + UPLCG_HOSTNAME=$(UPLCG_HOSTNAME) \ + UPLCG_PORT=$(UPLCG_PORT) \ + UPLCG_BASE=$(UPLCG_BASE) \ + stack exec uplcg-server) .PHONY: stack_build stack_build: $(HS_SOURCES) (cd server && stack build) $(ELM_MESSAGES_SOURCE): stack_build - (cd server && stack exec cafp-generate-elm-types) >$(ELM_MESSAGES_SOURCE) + (cd server && stack exec uplcg-generate-elm-types) >$(ELM_MESSAGES_SOURCE) server/assets/client.js: $(ELM_MESSAGES_SOURCE) $(ELM_SOURCES) mkdir -p server/assets @@ -38,8 +38,8 @@ server/assets/client.js: $(ELM_MESSAGES_SOURCE) $(ELM_SOURCES) .PHONY: server/assets/client.html # Depends on git hash. server/assets/client.html: client/index.html config.mk - sed "s@\$$CAFP_BASE@$(CAFP_BASE)@" $< | \ - sed "s@\$$CAFP_VERSION@$(CAFP_VERSION)@" >$@ + sed "s@\$$UPLCG_BASE@$(UPLCG_BASE)@" $< | \ + sed "s@\$$UPLCG_VERSION@$(UPLCG_VERSION)@" >$@ server/assets/style.css: client/style.css cp $< $@ diff --git a/black.txt b/black.txt index 7c91439..0797970 100644 --- a/black.txt +++ b/black.txt @@ -4,7 +4,7 @@ # Some cards taken from: # https://github.com/CardsAgainstCryptography/CAC/blob/master/src/white.txt # Slightly modified to take out most sexist / racist / ... stuff and comply -# with the cafp format. Added more \BLANKs to a few because we can. +# with the uplcg format. Added more \BLANKs to a few because we can. A PL conference is never complete without \BLANK. Both Microsoft and Apple have concerns with \BLANK. Did you hear that \BLANK is the new hot topic? diff --git a/client/index.html b/client/index.html index 274f533..a03d777 100644 --- a/client/index.html +++ b/client/index.html @@ -3,12 +3,12 @@ Client - +
- + - + diff --git a/client/src/Client.elm b/client/src/Client.elm index 840e9b6..6e987e7 100644 --- a/client/src/Client.elm +++ b/client/src/Client.elm @@ -74,14 +74,14 @@ viewPlayers players = Html.table [] <| view : Model -> Browser.Document Msg view model = case model of Error str -> - { title = "CaFP: Error" + { title = "Untitled PL Card Game: Error" , body = [ Html.h1 [] [Html.text "Error"] , Html.p [] [Html.text str] ] } Connecting roomId -> - { title = "CaFP: Connecting" + { title = "Untitled PL Card Game: Connecting" , body = [ Html.h1 [] [ Html.text <| @@ -91,8 +91,8 @@ view model = case model of } Game game -> { title = case game.room of - Nothing -> "CaFP" - Just room -> "CaFP | " ++ room + Nothing -> "Untitled PL Card Game" + Just room -> room ++ " | Untitled PL Card Game" , body = [ Html.div [Html.Attributes.class "main"] <| [ Html.div [Html.Attributes.class "table"] diff --git a/config.mk b/config.mk index c31f939..5fd098d 100644 --- a/config.mk +++ b/config.mk @@ -1,4 +1,4 @@ -CAFP_HOSTNAME=0.0.0.0 -CAFP_PORT=8002 -CAFP_BASE=/cafp -CAFP_VERSION=$(shell git rev-parse HEAD | head -c8) +UPLCG_HOSTNAME=0.0.0.0 +UPLCG_PORT=8002 +UPLCG_BASE=/uplcg +UPLCG_VERSION=$(shell git rev-parse HEAD | head -c8) diff --git a/server/cafp.cabal b/server/cafp.cabal deleted file mode 100644 index a0eded7..0000000 --- a/server/cafp.cabal +++ /dev/null @@ -1,63 +0,0 @@ -Name: cafp -Version: 0.1.0 -Synopsis: Cards Against Functional Programming -License: BSD3 -License-file: LICENSE -Author: Jasper Van der Jeugt -Maintainer: Jasper Van der Jeugt -Copyright: 2020 Jasper Van der Jeugt -Category: Language -Build-type: Simple -Cabal-version: 1.18 - -Library - Default-language: Haskell2010 - Ghc-options: -Wall - Hs-source-dirs: lib - - Exposed-modules: - Cafp.CookieSocket - Cafp.Game - Cafp.Messages - Cafp.Main.GenerateElmTypes - Cafp.Main.Server - - Build-depends: - aeson >= 1.4 && < 1.5, - async >= 2.2 && < 2.3, - base >= 4.9 && < 5, - bytestring >= 0.10 && < 0.11, - elm-bridge >= 0.5 && < 0.6, - fast-logger >= 3.0 && < 3.1, - hashable >= 1.3 && < 1.4, - lens >= 4.18 && < 4.19, - mtl >= 2.2 && < 2.3, - random >= 1.1 && < 1.2, - scotty >= 0.11 && < 0.12, - stm >= 2.5 && < 2.6, - text >= 1.2 && < 1.3, - time >= 1.9 && < 1.10, - unordered-containers >= 0.2 && < 0.3, - uuid >= 1.3 && < 1.4, - vector >= 0.12 && < 0.13, - vector-algorithms >= 0.8 && < 0.9, - vector-instances >= 3.4 && < 3.5, - vector-shuffling >= 1.1 && < 1.2, - wai >= 3.2 && < 3.3, - wai-websockets >= 3.0 && < 3.1, - warp >= 3.3 && < 3.4, - websockets >= 0.12 && < 0.13 - -Executable cafp-generate-elm-types - Hs-source-dirs: src - Main-is: GenerateElmTypes.hs - Default-language: Haskell2010 - Ghc-options: -Wall - Build-depends: base, cafp - -Executable cafp-server - Hs-source-dirs: src - Main-is: Server.hs - Default-language: Haskell2010 - Ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N" - Build-depends: base, 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 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 diff --git a/server/src/GenerateElmTypes.hs b/server/src/GenerateElmTypes.hs index c85aaf3..7fbca10 100644 --- a/server/src/GenerateElmTypes.hs +++ b/server/src/GenerateElmTypes.hs @@ -1,4 +1,4 @@ -import qualified Cafp.Main.GenerateElmTypes +import qualified Uplcg.Main.GenerateElmTypes main :: IO () -main = Cafp.Main.GenerateElmTypes.main +main = Uplcg.Main.GenerateElmTypes.main diff --git a/server/src/Server.hs b/server/src/Server.hs index fba65ef..95ef75c 100644 --- a/server/src/Server.hs +++ b/server/src/Server.hs @@ -1,4 +1,4 @@ -import qualified Cafp.Main.Server +import qualified Uplcg.Main.Server main :: IO () -main = Cafp.Main.Server.main +main = Uplcg.Main.Server.main diff --git a/server/uplcg.cabal b/server/uplcg.cabal new file mode 100644 index 0000000..830c01a --- /dev/null +++ b/server/uplcg.cabal @@ -0,0 +1,63 @@ +Name: uplcg +Version: 0.1.0 +Synopsis: Untitled PL Card Game +License: BSD3 +License-file: LICENSE +Author: Jasper Van der Jeugt +Maintainer: Jasper Van der Jeugt +Copyright: 2020 Jasper Van der Jeugt +Category: Language +Build-type: Simple +Cabal-version: 1.18 + +Library + Default-language: Haskell2010 + Ghc-options: -Wall + Hs-source-dirs: lib + + Exposed-modules: + Uplcg.CookieSocket + Uplcg.Game + Uplcg.Messages + Uplcg.Main.GenerateElmTypes + Uplcg.Main.Server + + Build-depends: + aeson >= 1.4 && < 1.5, + async >= 2.2 && < 2.3, + base >= 4.9 && < 5, + bytestring >= 0.10 && < 0.11, + elm-bridge >= 0.5 && < 0.6, + fast-logger >= 3.0 && < 3.1, + hashable >= 1.3 && < 1.4, + lens >= 4.18 && < 4.19, + mtl >= 2.2 && < 2.3, + random >= 1.1 && < 1.2, + scotty >= 0.11 && < 0.12, + stm >= 2.5 && < 2.6, + text >= 1.2 && < 1.3, + time >= 1.9 && < 1.10, + unordered-containers >= 0.2 && < 0.3, + uuid >= 1.3 && < 1.4, + vector >= 0.12 && < 0.13, + vector-algorithms >= 0.8 && < 0.9, + vector-instances >= 3.4 && < 3.5, + vector-shuffling >= 1.1 && < 1.2, + wai >= 3.2 && < 3.3, + wai-websockets >= 3.0 && < 3.1, + warp >= 3.3 && < 3.4, + websockets >= 0.12 && < 0.13 + +Executable uplcg-generate-elm-types + Hs-source-dirs: src + Main-is: GenerateElmTypes.hs + Default-language: Haskell2010 + Ghc-options: -Wall + Build-depends: base, uplcg + +Executable uplcg-server + Hs-source-dirs: src + Main-is: Server.hs + Default-language: Haskell2010 + Ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N" + Build-depends: base, uplcg -- cgit v1.2.3