From 7f5e0db31447cc612cf469ef07854677f9d25b83 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 22 Aug 2020 14:47:58 +0200 Subject: Multiple card sets --- server/lib/Uplcg/Cards.hs | 17 +++++++++++++ server/lib/Uplcg/Game.hs | 2 +- server/lib/Uplcg/Main/Server.hs | 55 ++++++++++++++++++++--------------------- server/lib/Uplcg/Views.hs | 9 +++++-- 4 files changed, 52 insertions(+), 31 deletions(-) create mode 100644 server/lib/Uplcg/Cards.hs (limited to 'server/lib/Uplcg') diff --git a/server/lib/Uplcg/Cards.hs b/server/lib/Uplcg/Cards.hs new file mode 100644 index 0000000..27d5240 --- /dev/null +++ b/server/lib/Uplcg/Cards.hs @@ -0,0 +1,17 @@ +module Uplcg.Cards + ( Deck + , CardSets + , loadCardSets + ) where + +import qualified Data.HashMap.Strict as HMS +import qualified Data.Text as T +import qualified Data.Yaml as Yaml +import Uplcg.Messages + +type Deck = T.Text + +type CardSets = HMS.HashMap Deck Cards + +loadCardSets :: FilePath -> IO CardSets +loadCardSets path = Yaml.decodeFileThrow path diff --git a/server/lib/Uplcg/Game.hs b/server/lib/Uplcg/Game.hs index 02e40cb..140f2b6 100644 --- a/server/lib/Uplcg/Game.hs +++ b/server/lib/Uplcg/Game.hs @@ -157,7 +157,7 @@ leaveGame pid game = case game ^? gamePlayers . ix pid of blackCardBlanks :: Cards -> BlackCard -> Int blackCardBlanks cards (BlackCard c) = - maybe 0 (length . T.breakOnAll "\\BLANK") $ cardsBlack cards V.!? c + maybe 0 (length . T.breakOnAll "_") $ cardsBlack cards V.!? c maximaOn :: Ord o => (a -> o) -> [a] -> [a] maximaOn f = \case [] -> []; x : xs -> go [x] (f x) xs diff --git a/server/lib/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs index 295b736..4a3829b 100644 --- a/server/lib/Uplcg/Main/Server.hs +++ b/server/lib/Uplcg/Main/Server.hs @@ -25,10 +25,8 @@ import Data.Maybe (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.Text.Lazy as TL import Data.Traversable (for) -import qualified Data.Vector as V import qualified Network.HTTP.Types.Status as HttpStatus import qualified Network.HTTP.Types.URI as HttpUri import qualified Network.Wai as Wai @@ -40,6 +38,7 @@ import System.Environment (getEnv) import qualified System.Log.FastLogger as FL import System.Random (StdGen, newStdGen) import Text.Blaze.Html.Renderer.Text (renderHtml) +import Uplcg.Cards import qualified Uplcg.CookieSocket as CookieSocket import Uplcg.Game import Uplcg.Messages @@ -63,21 +62,15 @@ data Room = Room data Server = Server { serverLogger :: FL.FastLogger , serverCookieSocket :: CookieSocket.Handle Player - , serverCards :: Cards + , serverCards :: CardSets , 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 +withServer fl f = CookieSocket.withHandle 5 $ \cs -> + f =<< Server fl cs + <$> loadCardSets "assets/cards.yaml" + <*> MVar.newMVar HMS.empty newRoom :: RoomId -> RoomPassword -> Cards -> StdGen -> STM Room newRoom rid rpw cards gen = Room rid rpw @@ -148,12 +141,14 @@ scottyApp server = Scotty.scottyApp $ do Scotty.get "/rooms" $ do views <- liftIO $ roomViews server - Scotty.html . renderHtml $ Views.rooms views + let decks = HMS.keys $ serverCards server + Scotty.html . renderHtml $ Views.rooms views decks Scotty.post "/rooms" $ do - rid <- getParam "id" - rpw <- getParam "password" - _ <- liftIO $ createRoom server rid rpw + rid <- getParam "id" + rpw <- getParam "password" + cards <- getParam "deck" + _ <- liftIO $ createRoom server rid rpw cards Scotty.redirect $ TL.fromStrict $ "/rooms/" <> unRoomId rid <> case rpw of @@ -195,17 +190,21 @@ parsePendingConnection pending = Just (r, maybe NoRoomPassword RoomPassword pwd) _ -> Nothing -createRoom :: Server -> RoomId -> RoomPassword -> IO Room -createRoom server rid rpw = MVar.modifyMVar (serverRooms server) $ \rooms -> - case HMS.lookup rid rooms of - Just _ -> fail "Room already exists" - Nothing -> do - gen <- newStdGen - serverLogger server $ "[" <> FL.toLogStr rid <> "] Created " <> - (if rpw == NoRoomPassword then "" else "password-protected ") <> - "room" - room <- atomically $ newRoom rid rpw (serverCards server) gen - pure (HMS.insert rid room rooms, room) +createRoom :: Server -> RoomId -> RoomPassword -> Deck -> IO Room +createRoom server rid rpw deck = do + cards <- maybe (fail "Deck not found") pure $ + HMS.lookup deck (serverCards server) + MVar.modifyMVar (serverRooms server) $ \rooms -> do + case HMS.lookup rid rooms of + Just _ -> fail "Room already exists" + Nothing -> pure () + + gen <- newStdGen + serverLogger server $ "[" <> FL.toLogStr rid <> "] Created " <> + (if rpw == NoRoomPassword then "" else "password-protected ") <> + "room" + room <- atomically $ newRoom rid rpw cards gen + pure (HMS.insert rid room rooms, room) getRoom :: Server -> RoomId -> IO Room getRoom server rid = do diff --git a/server/lib/Uplcg/Views.hs b/server/lib/Uplcg/Views.hs index d25a9ce..9e453e8 100644 --- a/server/lib/Uplcg/Views.hs +++ b/server/lib/Uplcg/Views.hs @@ -13,6 +13,7 @@ import qualified Data.Text.Encoding as T import qualified Network.HTTP.Types.URI as HttpUri import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A +import Uplcg.Cards import Uplcg.Version (version) data RoomView = RoomView Text Bool Int @@ -29,8 +30,8 @@ template title body = H.docTypeHtml $ do body H.footer $ "Untitled PL Card Game version " <> H.toHtml version -rooms :: [RoomView] -> H.Html -rooms rids = template "Untitled PL Card Game" $ +rooms :: [RoomView] -> [Deck] -> H.Html +rooms rids decks = template "Untitled PL Card Game" $ H.div H.! A.class_ "rooms" $ do H.h1 "Rooms" if null rids @@ -52,6 +53,10 @@ rooms rids = template "Untitled PL Card Game" $ H.label H.! A.for "name" $ "Password (optional): " H.input H.! A.type_ "text" H.! A.name "password" H.br + H.label H.! A.for "deck" $ "Cards: " + H.select H.! A.name "deck" $ for_ decks $ \deck -> + H.option H.! A.value (H.toValue deck) $ H.toHtml deck + H.br H.input H.! A.type_ "submit" H.! A.value "Create room" client :: Text -> Maybe Text -> H.Html -- cgit v1.2.3