diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/lib/Uplcg/Cards.hs | 39 | ||||
| -rw-r--r-- | server/lib/Uplcg/Main/Server.hs | 4 | ||||
| -rw-r--r-- | server/lib/Uplcg/Views.hs | 16 |
3 files changed, 40 insertions, 19 deletions
diff --git a/server/lib/Uplcg/Cards.hs b/server/lib/Uplcg/Cards.hs index d7d7659..b089574 100644 --- a/server/lib/Uplcg/Cards.hs +++ b/server/lib/Uplcg/Cards.hs @@ -1,13 +1,14 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Uplcg.Cards ( Deck - , CardSets + , CardSets (..) , loadCardSets ) where import qualified Data.Aeson.TH as Aeson import qualified Data.HashMap.Strict as HMS -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, listToMaybe) import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.Yaml as Yaml @@ -16,27 +17,39 @@ import Uplcg.Messages type Deck = T.Text -type CardSets = HMS.HashMap Deck Cards +data CardSets = CardSets + { csDefault :: Maybe Deck + , csCards :: HMS.HashMap Deck Cards + } deriving (Show) data RawCardSet = RawCardSet - { rcsEnabled :: Maybe Bool + { rcsDefault :: Maybe Bool + , rcsEnabled :: Maybe Bool , rcsInclude :: Maybe (V.Vector T.Text) , rcsBlack :: V.Vector T.Text , rcsWhite :: V.Vector T.Text - } + } deriving (Show) Aeson.deriveFromJSON (defaultOptionsDropLower 3) ''RawCardSet fromRawCardSets :: HMS.HashMap Deck RawCardSet -> CardSets fromRawCardSets raws = - HMS.map (\rcs -> - let includes = V.mapMaybe (`HMS.lookup` raws) $ - fromMaybe V.empty $ rcsInclude rcs in - Cards - { cardsBlack = rcsBlack rcs <> V.concatMap rcsBlack includes - , cardsWhite = rcsWhite rcs <> V.concatMap rcsWhite includes - }) $ - HMS.filter (fromMaybe True . rcsEnabled) raws + CardSets {..} + where + csDefault = listToMaybe + [ deck + | (deck, RawCardSet {..}) <- HMS.toList raws + , fromMaybe False rcsDefault + ] + csCards = + HMS.map (\rcs -> + let includes = V.mapMaybe (`HMS.lookup` raws) $ + fromMaybe V.empty $ rcsInclude rcs in + Cards + { cardsBlack = rcsBlack rcs <> V.concatMap rcsBlack includes + , cardsWhite = rcsWhite rcs <> V.concatMap rcsWhite includes + }) $ + HMS.filter (fromMaybe True . rcsEnabled) raws loadCardSets :: FilePath -> IO CardSets loadCardSets path = fromRawCardSets <$> Yaml.decodeFileThrow path diff --git a/server/lib/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs index c0849fd..6527251 100644 --- a/server/lib/Uplcg/Main/Server.hs +++ b/server/lib/Uplcg/Main/Server.hs @@ -142,7 +142,7 @@ scottyApp server = Scotty.scottyApp $ do Scotty.matchAny "/rooms" $ do views <- liftIO $ roomViews server - let decks = HMS.keys $ serverCards server + let decks = serverCards server method <- Wai.requestMethod <$> Scotty.request mbCreatedRoom <- if method == HttpMethod.methodPost @@ -205,7 +205,7 @@ parsePendingConnection pending = 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) + HMS.lookup deck (csCards $ serverCards server) MVar.modifyMVar (serverRooms server) $ \rooms -> do case HMS.lookup rid rooms of Just _ -> fail "Room already exists" diff --git a/server/lib/Uplcg/Views.hs b/server/lib/Uplcg/Views.hs index 0430586..835f8cb 100644 --- a/server/lib/Uplcg/Views.hs +++ b/server/lib/Uplcg/Views.hs @@ -8,7 +8,8 @@ module Uplcg.Views import Control.Monad (when) import qualified Data.ByteString.Lazy.Builder as BLB import Data.Foldable (for_) -import Data.List (sortBy) +import qualified Data.HashMap.Strict as HMS +import Data.List (sort, sortBy) import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text.Encoding as T @@ -36,7 +37,7 @@ template title body = H.docTypeHtml $ do " version " H.toHtml version -rooms :: [RoomView] -> [Deck] -> Maybe String -> H.Html +rooms :: [RoomView] -> CardSets -> Maybe String -> H.Html rooms rooms0 decks mbError = template "Untitled PL Card Game" $ H.div H.! A.class_ "rooms" $ do H.h1 "Rooms" @@ -63,8 +64,15 @@ rooms rooms0 decks mbError = template "Untitled PL Card Game" $ H.input H.! A.type_ "text" H.! A.name "password" H.br H.label H.! A.for "deck" $ "Card set to use: " - H.select H.! A.name "deck" $ for_ decks $ \deck -> - H.option H.! A.value (H.toValue deck) $ H.toHtml deck + + let sorted = sort . HMS.keys $ csCards decks + H.select H.! A.name "deck" $ for_ sorted $ \deck -> + if Just deck == csDefault decks then + H.option H.! A.value (H.toValue deck) + H.! A.selected "selected" $ H.toHtml deck + else + H.option H.! A.value (H.toValue deck) $ H.toHtml deck + H.br H.input H.! A.type_ "submit" H.! A.value "Create room" where |