aboutsummaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
Diffstat (limited to 'server')
-rw-r--r--server/lib/Uplcg/Main/Server.hs17
-rw-r--r--server/lib/Uplcg/Views.hs12
2 files changed, 22 insertions, 7 deletions
diff --git a/server/lib/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs
index bd2b3ec..bd89540 100644
--- a/server/lib/Uplcg/Main/Server.hs
+++ b/server/lib/Uplcg/Main/Server.hs
@@ -24,6 +24,7 @@ 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.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
@@ -78,8 +79,17 @@ newRoom rid cards gen = Room rid
parseRoomId :: T.Text -> Either String T.Text
parseRoomId txt
- | T.all isAlphaNum txt && T.length txt >= 6 = Right txt
+ | T.all isAlphaNum txt && l >= 6 && l <= 32 = Right txt
| otherwise = Left "Bad room name"
+ where
+ l = T.length txt
+
+roomViews :: Server -> IO [Views.RoomView]
+roomViews server = do
+ rooms <- liftIO . MVar.readMVar $ serverRooms server
+ liftIO . for (HMS.toList rooms) $ \(rid, room) ->
+ fmap (Views.RoomView rid . HMS.size) . atomically . STM.readTVar $
+ roomSinks room
scottyApp :: Server -> IO Wai.Application
scottyApp server = Scotty.scottyApp $ do
@@ -88,9 +98,8 @@ scottyApp server = Scotty.scottyApp $ do
BaseUrl.render (serverBaseUrl server) <> "/rooms"
Scotty.get "/rooms" $ do
- rooms <- liftIO . MVar.readMVar $ serverRooms server
- Scotty.html . renderHtml . Views.rooms (serverBaseUrl server) $
- HMS.keys rooms
+ views <- liftIO $ roomViews server
+ Scotty.html . renderHtml $ Views.rooms (serverBaseUrl server) views
Scotty.get "/rooms/:id/" $ do
rid <- Scotty.param "id"
diff --git a/server/lib/Uplcg/Views.hs b/server/lib/Uplcg/Views.hs
index 90716c1..ef4bc09 100644
--- a/server/lib/Uplcg/Views.hs
+++ b/server/lib/Uplcg/Views.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Uplcg.Views
- ( rooms
+ ( RoomView (..)
+ , rooms
) where
import Data.Foldable (for_)
@@ -10,7 +11,9 @@ import qualified Text.Blaze.Html5.Attributes as A
import Uplcg.BaseUrl (BaseUrl)
import qualified Uplcg.BaseUrl as BaseUrl
-rooms :: BaseUrl -> [Text] -> H.Html
+data RoomView = RoomView Text Int
+
+rooms :: BaseUrl -> [RoomView] -> H.Html
rooms base rids = H.docTypeHtml $ do
H.head $ do
H.meta H.! A.charset "UTF-8"
@@ -18,7 +21,10 @@ rooms base rids = H.docTypeHtml $ do
H.! A.href (H.toValue $ BaseUrl.render base <> "/assets/style.css")
H.body $ do
H.h1 "Rooms"
- H.ul $ for_ rids $ \rid -> H.li $
+ H.ul $ for_ rids $ \(RoomView rid num) -> H.li $ do
H.a H.! A.href (H.toValue $ BaseUrl.render base <> "/rooms/" <> rid) $
H.toHtml rid
+ " ("
+ H.toHtml num
+ ")"
H.footer $ "Untitled PL Card Game"