From ffedfd5274a3545f2bc53bba7aa7ec3b4388edf1 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt
Date: Fri, 11 Sep 2020 13:14:19 +0200
Subject: Add default card set

---
 server/lib/Uplcg/Cards.hs       | 39 ++++++++++++++++++++++++++-------------
 server/lib/Uplcg/Main/Server.hs |  4 ++--
 server/lib/Uplcg/Views.hs       | 16 ++++++++++++----
 3 files changed, 40 insertions(+), 19 deletions(-)

(limited to 'server')

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
-- 
cgit v1.2.3