diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/lib/Uplcg/Main/Server.hs | 17 | ||||
| -rw-r--r-- | server/lib/Uplcg/Views.hs | 12 |
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" |