aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJasper Van der Jeugt2020-09-11 13:14:19 +0200
committerJasper Van der Jeugt2020-09-11 13:14:19 +0200
commitffedfd5274a3545f2bc53bba7aa7ec3b4388edf1 (patch)
tree6fd9a75df6169d6abf2cc60e5658e0311d4ff20d
parentafbd7912487499fab2b7ebcc42496f015460f4b3 (diff)
Add default card set
Diffstat (limited to '')
-rw-r--r--cards.yaml1
-rw-r--r--server/lib/Uplcg/Cards.hs39
-rw-r--r--server/lib/Uplcg/Main/Server.hs4
-rw-r--r--server/lib/Uplcg/Views.hs16
4 files changed, 41 insertions, 19 deletions
diff --git a/cards.yaml b/cards.yaml
index e04a458..7d7fea8 100644
--- a/cards.yaml
+++ b/cards.yaml
@@ -265,6 +265,7 @@ icfp2020:
- a shepherd that won't budge
munihac2020:
+ default: true
include:
- generic
- covid19
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