Multiple card sets

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