aboutsummaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--server/lib/Uplcg/Cards.hs17
-rw-r--r--server/lib/Uplcg/Game.hs2
-rw-r--r--server/lib/Uplcg/Main/Server.hs55
-rw-r--r--server/lib/Uplcg/Views.hs9
-rw-r--r--server/uplcg.cabal4
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 06:29:37 +0000