WIP

5 files changed, 87 insertions, 19 deletions

diff --git a/README.md b/README.md
new file mode 100644
index 0000000..da95309
--- /dev/null
+++ b/README.md
@@ -0,0 +1,20 @@
+# Untitled PL Card Game
+
+## Event Info
+
+Untitled PL Card Game is a game heavily inspired by [Cards Against Humanity],
+[Cards Against Cryptography], and [Apples to Apples].
+
+We've created custom cards that relate to ICFP2020 and free of the racism,
+sexism and homophobia appearing in the original version.
+
+Another change we've made to the game is that there is a democratic voting round
+at the end of each play phase, rather than the starting player picking the
+winner.
+
+The game can be fully played in the browser, but we'll have a video call along
+the side to make it more social.
+
+[Cards Against Humanity]: https://cardsagainsthumanity.com/
+[Cards Against Cryptography]: https://github.com/CardsAgainstCryptography/CAC
+[Apples to Apples]: https://en.wikipedia.org/wiki/Apples_to_Apples
diff --git a/server/lib/Uplcg/BaseUrl.hs b/server/lib/Uplcg/BaseUrl.hs
new file mode 100644
index 0000000..4374322
--- /dev/null
+++ b/server/lib/Uplcg/BaseUrl.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Uplcg.BaseUrl
+    ( BaseUrl (..)
+    , parse
+    , render
+    ) where
+
+import qualified Data.Text as T
+
+newtype BaseUrl = BaseUrl [T.Text]
+
+render :: BaseUrl -> T.Text
+render (BaseUrl []) = ""
+render (BaseUrl xs) = "/" <> T.intercalate "/" xs
+
+parse :: T.Text -> BaseUrl
+parse = BaseUrl . filter (not . T.null) . T.split (== '/')
diff --git a/server/lib/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs
index a2914ab..72d9614 100644
--- a/server/lib/Uplcg/Main/Server.hs
+++ b/server/lib/Uplcg/Main/Server.hs
@@ -10,6 +10,7 @@ import qualified Control.Concurrent.STM         as STM
 import           Control.Exception              (bracket)
 import           Control.Lens                   ((&), (.~), (^.))
 import           Control.Monad                  (forever, when)
+import           Control.Monad.Trans            (liftIO)
 import qualified Data.Aeson                     as Aeson
 import qualified Data.ByteString                as B
 import qualified Data.ByteString.Lazy           as BL
@@ -30,9 +31,13 @@ import qualified Network.WebSockets             as WS
 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.BaseUrl                  (BaseUrl)
+import qualified Uplcg.BaseUrl                  as BaseUrl
 import qualified Uplcg.CookieSocket             as CookieSocket
 import           Uplcg.Game
 import           Uplcg.Messages
+import qualified Uplcg.Views                    as Views
 import qualified Web.Scotty                     as Scotty
 
 type RoomId = T.Text
@@ -46,7 +51,8 @@ data Room = Room
     }
 
 data Server = Server
-    { serverLogger       :: FL.FastLogger
+    { serverBaseUrl      :: BaseUrl
+    , serverLogger       :: FL.FastLogger
     , serverCookieSocket :: CookieSocket.Handle Player
     , serverCards        :: Cards
     , serverRooms        :: MVar (HMS.HashMap RoomId Room)
@@ -60,9 +66,9 @@ readCards = Cards
     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 :: BaseUrl -> FL.FastLogger -> (Server -> IO a) -> IO a
+withServer base fl f = CookieSocket.withHandle 5 $ \cs -> do
+    f =<< Server base fl cs <$> readCards <*> MVar.newMVar HMS.empty
 
 newRoom :: RoomId -> Cards -> StdGen -> STM Room
 newRoom rid cards gen = Room rid
@@ -74,8 +80,13 @@ parseRoomId txt
     | T.all isAlphaNum txt && T.length txt >= 6 = Right txt
     | otherwise                                 = Left "Bad room name"
 
-scottyApp :: IO Wai.Application
-scottyApp = Scotty.scottyApp $ do
+scottyApp :: Server -> IO Wai.Application
+scottyApp server = Scotty.scottyApp $ do
+    Scotty.get "/rooms" $ do
+        rooms <- liftIO . MVar.readMVar $ serverRooms server
+        Scotty.html . renderHtml . Views.rooms (serverBaseUrl server) $
+            HMS.keys rooms
+
     Scotty.get "/rooms/:id/" $ do
         rid <- Scotty.param "id"
         when (T.length rid < 6) $
@@ -94,9 +105,10 @@ scottyApp = Scotty.scottyApp $ do
 routePendingConnection :: WS.PendingConnection -> Maybe RoomId
 routePendingConnection pending =
     let path = T.decodeUtf8 . WS.requestPath $ WS.pendingRequest pending in
-    case splitPath path of
-        ["rooms", txt, "events"] | Right r <- parseRoomId txt -> Just r
-        _                                                     -> Nothing
+    case BaseUrl.parse path of
+        BaseUrl.BaseUrl ["rooms", txt, "events"] | Right r <- parseRoomId txt ->
+            Just r
+        _ -> Nothing
 
 getOrCreateRoom :: Server -> RoomId -> IO Room
 getOrCreateRoom server rid = MVar.modifyMVar (serverRooms server) $ \rooms ->
@@ -183,11 +195,8 @@ wsApp server pc = case routePendingConnection pc of
                 serverLogger server $ "Could not decode client message: " <>
                     FL.toLogStr (show msg)
 
-splitPath :: T.Text -> [T.Text]
-splitPath = filter (not . T.null) . T.split (== '/')
-
-baseUrl :: [T.Text] -> Wai.Middleware
-baseUrl prefix application = \req ->
+baseUrl :: BaseUrl -> Wai.Middleware
+baseUrl base@(BaseUrl.BaseUrl prefix) application = \req ->
     case L.stripPrefix prefix (Wai.pathInfo req) of
         Nothing   -> application req
         Just path -> application req
@@ -196,19 +205,19 @@ baseUrl prefix application = \req ->
                 B.stripPrefix bs $ Wai.rawPathInfo req
             }
   where
-    bs = T.encodeUtf8 $ "/" <> T.intercalate "/" prefix
+    bs = T.encodeUtf8 $ BaseUrl.render base
 
 main :: IO ()
 main = do
     host <- fromString <$> getEnv "UPLCG_HOSTNAME"
     port <- read <$> getEnv "UPLCG_PORT"
-    base <- splitPath . T.pack <$> getEnv "UPLCG_BASE"
+    base <- BaseUrl.parse . T.pack <$> getEnv "UPLCG_BASE"
     let settings = Warp.setPort port . Warp.setHost host $ Warp.defaultSettings
     timeCache <- FL.newTimeCache FL.simpleTimeFormat
     FL.withTimedFastLogger timeCache
             (FL.LogStderr FL.defaultBufSize) $ \tfl ->
         let fl s = tfl (\time -> FL.toLogStr time <> " " <> s <> "\n") in
-        withServer fl $ \server -> do
-        sapp <- scottyApp
+        withServer base fl $ \server -> do
+        sapp <- scottyApp server
         Warp.runSettings settings $ baseUrl base $
             WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp
diff --git a/server/lib/Uplcg/Views.hs b/server/lib/Uplcg/Views.hs
new file mode 100644
index 0000000..91b03ff
--- /dev/null
+++ b/server/lib/Uplcg/Views.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Uplcg.Views
+    ( rooms
+    ) where
+
+import           Data.Text                   (Text)
+import qualified Text.Blaze.Html5            as H
+import qualified Text.Blaze.Html5.Attributes as A
+import           Uplcg.BaseUrl               (BaseUrl)
+import qualified Uplcg.BaseUrl               as BaseUrl
+
+rooms :: BaseUrl -> [Text] -> H.Html
+rooms base _ids = 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.footer $ "Untitled PL Card Game"
diff --git a/server/uplcg.cabal b/server/uplcg.cabal
index 830c01a..403facd 100644
--- a/server/uplcg.cabal
+++ b/server/uplcg.cabal
@@ -16,16 +16,19 @@ Library
   Hs-source-dirs:   lib
 
   Exposed-modules:
+    Uplcg.BaseUrl
     Uplcg.CookieSocket
     Uplcg.Game
-    Uplcg.Messages
     Uplcg.Main.GenerateElmTypes
     Uplcg.Main.Server
+    Uplcg.Messages
+    Uplcg.Views
 
   Build-depends:
     aeson                >= 1.4  && < 1.5,
     async                >= 2.2  && < 2.3,
     base                 >= 4.9  && < 5,
+    blaze-html           >= 0.9  && < 0.10,
     bytestring           >= 0.10 && < 0.11,
     elm-bridge           >= 0.5  && < 0.6,
     fast-logger          >= 3.0  && < 3.1,