List room num members

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"