aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--server/lib/Uplcg/BaseUrl.hs2
-rw-r--r--server/lib/Uplcg/Config.hs24
-rw-r--r--server/lib/Uplcg/Main/Server.hs26
-rw-r--r--server/lib/Uplcg/Views.hs80
-rw-r--r--server/uplcg.cabal1
5 files changed, 108 insertions, 25 deletions
diff --git a/server/lib/Uplcg/BaseUrl.hs b/server/lib/Uplcg/BaseUrl.hs
index 4374322..f49d0d0 100644
--- a/server/lib/Uplcg/BaseUrl.hs
+++ b/server/lib/Uplcg/BaseUrl.hs
@@ -7,7 +7,7 @@ module Uplcg.BaseUrl
import qualified Data.Text as T
-newtype BaseUrl = BaseUrl [T.Text]
+newtype BaseUrl = BaseUrl [T.Text] deriving (Show)
render :: BaseUrl -> T.Text
render (BaseUrl []) = ""
diff --git a/server/lib/Uplcg/Config.hs b/server/lib/Uplcg/Config.hs
new file mode 100644
index 0000000..627a829
--- /dev/null
+++ b/server/lib/Uplcg/Config.hs
@@ -0,0 +1,24 @@
+module Uplcg.Config
+ ( Config (..)
+ , fromEnv
+ ) where
+
+import Data.String (fromString)
+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
+ , cVersion :: String
+ } deriving (Show)
+
+fromEnv :: IO Config
+fromEnv = Config
+ <$> getEnv "UPLCG_HOSTNAME"
+ <*> (read <$> getEnv "UPLCG_PORT")
+ <*> (BaseUrl.parse . T.pack <$> getEnv "UPLCG_BASE")
+ <*> getEnv "UPLCG_VERSION"
diff --git a/server/lib/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs
index bd89540..72b9377 100644
--- a/server/lib/Uplcg/Main/Server.hs
+++ b/server/lib/Uplcg/Main/Server.hs
@@ -36,6 +36,8 @@ 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
@@ -53,7 +55,7 @@ data Room = Room
}
data Server = Server
- { serverBaseUrl :: BaseUrl
+ { serverConfig :: Config
, serverLogger :: FL.FastLogger
, serverCookieSocket :: CookieSocket.Handle Player
, serverCards :: Cards
@@ -68,9 +70,9 @@ readCards = Cards
parseCards = V.fromList . filter (not . T.null) . map dropComment . T.lines
dropComment = T.strip . fst . T.break (== '#')
-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
+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
@@ -95,11 +97,11 @@ scottyApp :: Server -> IO Wai.Application
scottyApp server = Scotty.scottyApp $ do
Scotty.get "/" $
Scotty.redirect $ TL.fromStrict $
- BaseUrl.render (serverBaseUrl server) <> "/rooms"
+ BaseUrl.render (Config.cBaseUrl $ serverConfig server) <> "/rooms"
Scotty.get "/rooms" $ do
views <- liftIO $ roomViews server
- Scotty.html . renderHtml $ Views.rooms (serverBaseUrl server) views
+ Scotty.html . renderHtml $ Views.rooms (serverConfig server) views
Scotty.get "/rooms/:id/" $ do
rid <- Scotty.param "id"
@@ -223,15 +225,15 @@ baseUrl base@(BaseUrl.BaseUrl prefix) application = \req ->
main :: IO ()
main = do
- host <- fromString <$> getEnv "UPLCG_HOSTNAME"
- port <- read <$> getEnv "UPLCG_PORT"
- base <- BaseUrl.parse . 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 base fl $ \server -> do
+ withServer config fl $ \server -> do
sapp <- scottyApp server
- Warp.runSettings settings $ baseUrl base $
+ Warp.runSettings settings $ baseUrl (Config.cBaseUrl config) $
WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp
diff --git a/server/lib/Uplcg/Views.hs b/server/lib/Uplcg/Views.hs
index ef4bc09..3cb9ebe 100644
--- a/server/lib/Uplcg/Views.hs
+++ b/server/lib/Uplcg/Views.hs
@@ -8,23 +8,79 @@ import Data.Foldable (for_)
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 Data.ByteString.Lazy.Builder as BLB
import qualified Uplcg.BaseUrl as BaseUrl
+import Uplcg.Config
data RoomView = RoomView Text Int
-rooms :: BaseUrl -> [RoomView] -> H.Html
-rooms base rids = H.docTypeHtml $ do
+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 base <> "/assets/style.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
- H.h1 "Rooms"
- 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"
+ body
+ H.footer $ "Untitled PL Card Game version " <> H.toHtml (cVersion conf)
+
+rooms :: Config -> [RoomView] -> H.Html
+rooms conf rids = template conf "Untitled PL Card Game" $ 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.unsafeLazyByteString $ clientScript $ BLB.toLazyByteString $
+ 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/server/uplcg.cabal b/server/uplcg.cabal
index 403facd..72b2f82 100644
--- a/server/uplcg.cabal
+++ b/server/uplcg.cabal
@@ -18,6 +18,7 @@ Library
Exposed-modules:
Uplcg.BaseUrl
Uplcg.CookieSocket
+ Uplcg.Config
Uplcg.Game
Uplcg.Main.GenerateElmTypes
Uplcg.Main.Server
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 16:44:38 +0000