diff options
Diffstat (limited to 'server')
-rw-r--r-- | server/lib/Uplcg/Cards.hs | 17 | ||||
-rw-r--r-- | server/lib/Uplcg/Game.hs | 2 | ||||
-rw-r--r-- | server/lib/Uplcg/Main/Server.hs | 55 | ||||
-rw-r--r-- | server/lib/Uplcg/Views.hs | 9 | ||||
-rw-r--r-- | server/uplcg.cabal | 4 |
5 files changed, 55 insertions, 32 deletions
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 diff --git a/server/uplcg.cabal b/server/uplcg.cabal index 5ed6d2f..2c8db7d 100644 --- a/server/uplcg.cabal +++ b/server/uplcg.cabal @@ -17,6 +17,7 @@ Library Other-modules: Paths_uplcg Exposed-modules: + Uplcg.Cards Uplcg.CookieSocket Uplcg.Game Uplcg.Main.GenerateElmTypes @@ -54,7 +55,8 @@ Library wai-extra >= 3.0 && < 3.1, wai-websockets >= 3.0 && < 3.1, warp >= 3.3 && < 3.4, - websockets >= 0.12 && < 0.13 + websockets >= 0.12 && < 0.13, + yaml >= 0.11 && < 0.12 Executable uplcg-generate-elm-types Hs-source-dirs: src |