aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJasper Van der Jeugt2020-08-16 12:33:35 +0200
committerJasper Van der Jeugt2020-08-16 12:33:35 +0200
commit915aa0a168dce36013193be1c76a8448e3417556 (patch)
treeb2e669581db6ab32b8851f0436f1ed6636e8e870
parente0555c0fc44404befef4eeb51bb7745a79cac1a5 (diff)
parentd543ef8b1f68a23f9bc3706363fc3807ccbabf30 (diff)
Merge branch 'list-rooms' into main
Diffstat
-rw-r--r--Makefile6
-rw-r--r--README.md20
-rw-r--r--client/index.html51
-rw-r--r--client/style.css9
-rw-r--r--config.mk1
-rw-r--r--server/lib/Uplcg/BaseUrl.hs17
-rw-r--r--server/lib/Uplcg/Config.hs21
-rw-r--r--server/lib/Uplcg/Main/Server.hs82
-rw-r--r--server/lib/Uplcg/Version.hs17
-rw-r--r--server/lib/Uplcg/Views.hs83
-rw-r--r--server/uplcg.cabal10
11 files changed, 228 insertions, 89 deletions
diff --git a/Makefile b/Makefile
index e3e7947..921d0eb 100644
--- a/Makefile
+++ b/Makefile
@@ -7,7 +7,6 @@ STACK_BIN=$(shell cd server && stack path --local-install-root)/bin
.PHONY: build
build: server/assets/client.js \
- server/assets/client.html \
server/assets/style.css \
server/assets/black.txt \
server/assets/white.txt
@@ -36,11 +35,6 @@ server/assets/client.js: $(ELM_MESSAGES_SOURCE) $(ELM_SOURCES)
mkdir -p server/assets
cd client && elm make src/Client.elm --optimize --output=../$@
-.PHONY: server/assets/client.html # Depends on git hash.
-server/assets/client.html: client/index.html config.mk
- sed "s@\$$UPLCG_BASE@$(UPLCG_BASE)@" $< | \
- sed "s@\$$UPLCG_VERSION@$(UPLCG_VERSION)@" >$@
-
server/assets/style.css: client/style.css
cp $< $@
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/client/index.html b/client/index.html
deleted file mode 100644
index a03d777..0000000
--- a/client/index.html
+++ /dev/null
@@ -1,51 +0,0 @@
-<!DOCTYPE HTML>
-<html>
- <head>
- <meta charset="UTF-8">
- <title>Client</title>
- <link rel="stylesheet" type="text/css" href="$UPLCG_BASE/assets/style.css">
- <meta name="viewport" content="width=device-width">
- </head>
- <body>
- <div id="main"></div>
- <script type="text/JavaScript" src="$UPLCG_BASE/assets/client.js"></script>
- <script>
- var app = Elm.Client.init({node: document.querySelector("main")});
-
- function connect() {
- var protocol = "ws:";
- if(document.location.protocol == "https:") {
- protocol = "wss:"
- }
- var path = document.location.pathname;
- if(path.startsWith("$UPLCG_BASE")) {
- path = path.substr("$UPLCG_BASE".length);
- }
- var roomId = path.split("/")[2];
- var url = protocol + "//" + document.location.host +
- "$UPLCG_BASE/rooms/" + roomId + "/events";
-
- var socket = new WebSocket(url);
- var socketSend = function(message) {
- socket.send(message);
- };
- app.ports.webSocketOut.subscribe(socketSend);
- socket.onmessage = function(event) {
- app.ports.webSocketIn.send(event.data);
- };
- socket.onclose = function(event) {
- app.ports.webSocketOut.unsubscribe(socketSend);
- setTimeout(function() {
- connect();
- }, 1000);
- };
- socket.onerror = function(event) {
- socket.close();
- };
- }
-
- connect();
- </script>
- <footer>Untitled PL Card Game version $UPLCG_VERSION</footer>
- </body>
-</html>
diff --git a/client/style.css b/client/style.css
index 90e6a03..3da29f8 100644
--- a/client/style.css
+++ b/client/style.css
@@ -118,6 +118,15 @@ button, input {
margin-top: 6px;
}
+.rooms {
+ max-width: 800px;
+ margin: auto;
+}
+
+.rooms ul {
+ text-align: left;
+}
+
footer {
font-size: 12px;
margin: 60px auto 60px auto;
diff --git a/config.mk b/config.mk
index 5fd098d..ddec45c 100644
--- a/config.mk
+++ b/config.mk
@@ -1,4 +1,3 @@
UPLCG_HOSTNAME=0.0.0.0
UPLCG_PORT=8002
UPLCG_BASE=/uplcg
-UPLCG_VERSION=$(shell git rev-parse HEAD | head -c8)
diff --git a/server/lib/Uplcg/BaseUrl.hs b/server/lib/Uplcg/BaseUrl.hs
new file mode 100644
index 0000000..f49d0d0
--- /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] deriving (Show)
+
+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/Config.hs b/server/lib/Uplcg/Config.hs
new file mode 100644
index 0000000..9197d97
--- /dev/null
+++ b/server/lib/Uplcg/Config.hs
@@ -0,0 +1,21 @@
+module Uplcg.Config
+ ( Config (..)
+ , fromEnv
+ ) where
+
+import qualified Data.Text as T
+import System.Environment (getEnv)
+import Uplcg.BaseUrl (BaseUrl)
+import qualified Uplcg.BaseUrl as BaseUrl
+
+data Config = Config
+ { cHostname :: String
+ , cPort :: Int
+ , cBaseUrl :: BaseUrl
+ } deriving (Show)
+
+fromEnv :: IO Config
+fromEnv = Config
+ <$> getEnv "UPLCG_HOSTNAME"
+ <*> (read <$> getEnv "UPLCG_PORT")
+ <*> (BaseUrl.parse . T.pack <$> getEnv "UPLCG_BASE")
diff --git a/server/lib/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs
index a2914ab..acf2931 100644
--- a/server/lib/Uplcg/Main/Server.hs
+++ b/server/lib/Uplcg/Main/Server.hs
@@ -9,7 +9,8 @@ import Control.Concurrent.STM (STM, TVar, atomically)
import qualified Control.Concurrent.STM as STM
import Control.Exception (bracket)
import Control.Lens ((&), (.~), (^.))
-import Control.Monad (forever, when)
+import Control.Monad (forever)
+import Control.Monad.Trans (liftIO)
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
@@ -22,17 +23,24 @@ 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 Data.Traversable (for)
import qualified Data.Vector as V
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WebSockets as WaiWs
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 Uplcg.Config (Config)
+import qualified Uplcg.Config as Config
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 +54,8 @@ data Room = Room
}
data Server = Server
- { serverLogger :: FL.FastLogger
+ { serverConfig :: Config
+ , serverLogger :: FL.FastLogger
, serverCookieSocket :: CookieSocket.Handle Player
, serverCards :: Cards
, serverRooms :: MVar (HMS.HashMap RoomId Room)
@@ -60,9 +69,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 :: Config -> FL.FastLogger -> (Server -> IO a) -> IO a
+withServer conf fl f = CookieSocket.withHandle 5 $ \cs -> do
+ f =<< Server conf fl cs <$> readCards <*> MVar.newMVar HMS.empty
newRoom :: RoomId -> Cards -> StdGen -> STM Room
newRoom rid cards gen = Room rid
@@ -71,17 +80,32 @@ 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
+ Scotty.get "/" $
+ Scotty.redirect $ TL.fromStrict $
+ BaseUrl.render (Config.cBaseUrl $ serverConfig server) <> "/rooms"
+
+ Scotty.get "/rooms" $ do
+ views <- liftIO $ roomViews server
+ Scotty.html . renderHtml $ Views.rooms (serverConfig server) views
-scottyApp :: IO Wai.Application
-scottyApp = Scotty.scottyApp $ do
Scotty.get "/rooms/:id/" $ do
- rid <- Scotty.param "id"
- when (T.length rid < 6) $
- Scotty.raise "Room ID should be at least 6 characters"
- Scotty.setHeader "Content-Type" "text/html"
- Scotty.file "assets/client.html"
+ rid <- Scotty.param "id" >>=
+ either (Scotty.raise . TL.pack) pure . parseRoomId
+ Scotty.html . renderHtml $ Views.client (serverConfig server) rid
Scotty.get "/assets/client.js" $ do
Scotty.setHeader "Content-Type" "application/JavaScript"
@@ -94,9 +118,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 +208,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 +218,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"
- let settings = Warp.setPort port . Warp.setHost host $ Warp.defaultSettings
+ config <- Config.fromEnv
+ let settings = Warp.setPort (Config.cPort config) .
+ Warp.setHost (fromString $ Config.cHostname config) $
+ 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
- Warp.runSettings settings $ baseUrl base $
+ withServer config fl $ \server -> do
+ sapp <- scottyApp server
+ Warp.runSettings settings $ baseUrl (Config.cBaseUrl config) $
WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp
diff --git a/server/lib/Uplcg/Version.hs b/server/lib/Uplcg/Version.hs
new file mode 100644
index 0000000..b718a10
--- /dev/null
+++ b/server/lib/Uplcg/Version.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Uplcg.Version
+ ( version
+ ) where
+
+import Control.Monad.Trans (liftIO)
+import Data.Version (showVersion)
+import qualified Language.Haskell.TH as TH
+import qualified Paths_uplcg
+import System.Process (readProcess)
+
+version :: String
+version = showVersion Paths_uplcg.version ++ " (" ++
+ $(do
+ hash <- liftIO $ readProcess "git" ["rev-parse", "HEAD"] ""
+ pure . TH.LitE . TH.StringL $ take 8 hash) ++
+ ")"
diff --git a/server/lib/Uplcg/Views.hs b/server/lib/Uplcg/Views.hs
new file mode 100644
index 0000000..8241158
--- /dev/null
+++ b/server/lib/Uplcg/Views.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Uplcg.Views
+ ( RoomView (..)
+ , rooms
+ , client
+ ) where
+
+import qualified Data.ByteString.Lazy.Builder as BLB
+import Data.Foldable (for_)
+import Data.Text (Text)
+import qualified Data.Text.Encoding as T
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as A
+import qualified Uplcg.BaseUrl as BaseUrl
+import Uplcg.Config
+import Uplcg.Version (version)
+
+data RoomView = RoomView Text Int
+
+template :: Config -> Text -> H.Html -> H.Html
+template conf title body = 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 (cBaseUrl conf) <> "/assets/style.css")
+ H.title $ H.toHtml title
+ H.meta H.! A.name "viewport" H.! A.content "width=device-width"
+ H.body $ do
+ body
+ H.footer $ "Untitled PL Card Game version " <> H.toHtml version
+
+rooms :: Config -> [RoomView] -> H.Html
+rooms conf rids = template conf "Untitled PL Card Game" $
+ H.div H.! A.class_ "rooms" $ do
+ H.h1 "Rooms"
+ H.ul $ for_ rids $ \(RoomView rid num) -> H.li $ do
+ H.a H.! A.href (H.toValue $
+ BaseUrl.render (cBaseUrl conf) <> "/rooms/" <> rid) $
+ H.toHtml rid
+ " ("
+ H.toHtml num
+ ")"
+
+client :: Config -> Text -> H.Html
+client conf roomId = template conf "Untitled PL Card Game" $ do
+ H.div H.! A.id "main" $ ""
+ H.script H.! A.type_ "text/JavaScript"
+ H.! A.src (H.toValue $
+ BaseUrl.render (cBaseUrl conf) <> "/assets/client.js") $ ""
+ H.script H.! A.type_ "text/JavaScript" $ H.unsafeLazyByteString entryPoint
+ where
+ t2b = BLB.byteString . T.encodeUtf8
+ entryPoint = BLB.toLazyByteString $
+ "var app = Elm.Client.init({node: document.querySelector('main')});" <>
+
+ "function connect() {" <>
+ " var protocol = 'ws:';" <>
+ " if(document.location.protocol == 'https:') {" <>
+ " protocol = 'wss:'" <>
+ " }" <>
+ " var url = protocol + '//' + document.location.host +" <>
+ " '" <> t2b (BaseUrl.render $ cBaseUrl conf) <> "/rooms/" <>
+ t2b roomId <> "/events';" <>
+ " var socket = new WebSocket(url);" <>
+ " var socketSend = function(message) {" <>
+ " socket.send(message);" <>
+ " };" <>
+ " app.ports.webSocketOut.subscribe(socketSend);" <>
+ " socket.onmessage = function(event) {" <>
+ " app.ports.webSocketIn.send(event.data);" <>
+ " };" <>
+ " socket.onclose = function(event) {" <>
+ " app.ports.webSocketOut.unsubscribe(socketSend);" <>
+ " setTimeout(function() {" <>
+ " connect();" <>
+ " }, 1000);" <>
+ " };" <>
+ " socket.onerror = function(event) {" <>
+ " socket.close();" <>
+ " };" <>
+ "}" <>
+ "connect();"
diff --git a/server/uplcg.cabal b/server/uplcg.cabal
index 830c01a..c97d358 100644
--- a/server/uplcg.cabal
+++ b/server/uplcg.cabal
@@ -14,27 +14,35 @@ Library
Default-language: Haskell2010
Ghc-options: -Wall
Hs-source-dirs: lib
+ Other-modules: Paths_uplcg
Exposed-modules:
+ Uplcg.BaseUrl
Uplcg.CookieSocket
+ Uplcg.Config
Uplcg.Game
- Uplcg.Messages
Uplcg.Main.GenerateElmTypes
Uplcg.Main.Server
+ Uplcg.Messages
+ Uplcg.Version
+ 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,
hashable >= 1.3 && < 1.4,
lens >= 4.18 && < 4.19,
mtl >= 2.2 && < 2.3,
+ process >= 1.6 && < 1.7,
random >= 1.1 && < 1.2,
scotty >= 0.11 && < 0.12,
stm >= 2.5 && < 2.6,
+ template-haskell >= 2.15 && < 2.16,
text >= 1.2 && < 1.3,
time >= 1.9 && < 1.10,
unordered-containers >= 0.2 && < 0.3,
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-01 13:35:28 +0000