From ce06b07d6dae781fe09e4b0512a9b6d41ba687a6 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 14 Aug 2020 01:43:30 +0200 Subject: WIP --- README.md | 20 ++++++++++++++++++ server/lib/Uplcg/BaseUrl.hs | 17 ++++++++++++++++ server/lib/Uplcg/Main/Server.hs | 45 ++++++++++++++++++++++++----------------- server/lib/Uplcg/Views.hs | 19 +++++++++++++++++ server/uplcg.cabal | 5 ++++- 5 files changed, 87 insertions(+), 19 deletions(-) create mode 100644 README.md create mode 100644 server/lib/Uplcg/BaseUrl.hs create mode 100644 server/lib/Uplcg/Views.hs 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, -- cgit v1.2.3