From b250aa81e332c612551803d0d156246b853b3fd3 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt
Date: Fri, 14 Aug 2020 10:49:36 +0200
Subject: Actually list rooms
---
server/lib/Uplcg/Main/Server.hs | 5 +++++
server/lib/Uplcg/Views.hs | 7 ++++++-
2 files changed, 11 insertions(+), 1 deletion(-)
diff --git a/server/lib/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs
index 72d9614..bd2b3ec 100644
--- a/server/lib/Uplcg/Main/Server.hs
+++ b/server/lib/Uplcg/Main/Server.hs
@@ -23,6 +23,7 @@ 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 qualified Data.Vector as V
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
@@ -82,6 +83,10 @@ parseRoomId txt
scottyApp :: Server -> IO Wai.Application
scottyApp server = Scotty.scottyApp $ do
+ Scotty.get "/" $
+ Scotty.redirect $ TL.fromStrict $
+ BaseUrl.render (serverBaseUrl server) <> "/rooms"
+
Scotty.get "/rooms" $ do
rooms <- liftIO . MVar.readMVar $ serverRooms server
Scotty.html . renderHtml . Views.rooms (serverBaseUrl server) $
diff --git a/server/lib/Uplcg/Views.hs b/server/lib/Uplcg/Views.hs
index 91b03ff..90716c1 100644
--- a/server/lib/Uplcg/Views.hs
+++ b/server/lib/Uplcg/Views.hs
@@ -3,6 +3,7 @@ module Uplcg.Views
( rooms
) where
+import Data.Foldable (for_)
import Data.Text (Text)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
@@ -10,10 +11,14 @@ import Uplcg.BaseUrl (BaseUrl)
import qualified Uplcg.BaseUrl as BaseUrl
rooms :: BaseUrl -> [Text] -> H.Html
-rooms base _ids = H.docTypeHtml $ do
+rooms base rids = H.docTypeHtml $ do
H.head $ do
H.meta H.! A.charset "UTF-8"
H.link H.! A.rel "stylesheet" H.! A.type_ "text/css"
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.a H.! A.href (H.toValue $ BaseUrl.render base <> "/rooms/" <> rid) $
+ H.toHtml rid
H.footer $ "Untitled PL Card Game"
--
cgit v1.2.3