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 --- server/lib/Uplcg/BaseUrl.hs | 17 ++++++++++++++++ server/lib/Uplcg/Main/Server.hs | 45 ++++++++++++++++++++++++----------------- server/lib/Uplcg/Views.hs | 19 +++++++++++++++++ 3 files changed, 63 insertions(+), 18 deletions(-) create mode 100644 server/lib/Uplcg/BaseUrl.hs create mode 100644 server/lib/Uplcg/Views.hs (limited to 'server/lib') 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" -- cgit v1.2.3 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(-) (limited to 'server/lib') 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 From 41622353bc3309921109f44bc0163e0987c20052 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 14 Aug 2020 17:32:00 +0200 Subject: List room num members --- server/lib/Uplcg/Main/Server.hs | 17 +++++++++++++---- server/lib/Uplcg/Views.hs | 12 +++++++++--- 2 files changed, 22 insertions(+), 7 deletions(-) (limited to 'server/lib') diff --git a/server/lib/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs index bd2b3ec..bd89540 100644 --- a/server/lib/Uplcg/Main/Server.hs +++ b/server/lib/Uplcg/Main/Server.hs @@ -24,6 +24,7 @@ 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 @@ -78,8 +79,17 @@ 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 @@ -88,9 +98,8 @@ scottyApp server = Scotty.scottyApp $ do BaseUrl.render (serverBaseUrl server) <> "/rooms" Scotty.get "/rooms" $ do - rooms <- liftIO . MVar.readMVar $ serverRooms server - Scotty.html . renderHtml . Views.rooms (serverBaseUrl server) $ - HMS.keys rooms + views <- liftIO $ roomViews server + Scotty.html . renderHtml $ Views.rooms (serverBaseUrl server) views Scotty.get "/rooms/:id/" $ do rid <- Scotty.param "id" diff --git a/server/lib/Uplcg/Views.hs b/server/lib/Uplcg/Views.hs index 90716c1..ef4bc09 100644 --- a/server/lib/Uplcg/Views.hs +++ b/server/lib/Uplcg/Views.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Uplcg.Views - ( rooms + ( RoomView (..) + , rooms ) where import Data.Foldable (for_) @@ -10,7 +11,9 @@ import qualified Text.Blaze.Html5.Attributes as A import Uplcg.BaseUrl (BaseUrl) import qualified Uplcg.BaseUrl as BaseUrl -rooms :: BaseUrl -> [Text] -> H.Html +data RoomView = RoomView Text Int + +rooms :: BaseUrl -> [RoomView] -> H.Html rooms base rids = H.docTypeHtml $ do H.head $ do H.meta H.! A.charset "UTF-8" @@ -18,7 +21,10 @@ rooms base rids = H.docTypeHtml $ do 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.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" -- cgit v1.2.3 From 9f2d12f0b098a365d7b0d4cc00b03fd2e5284740 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 16 Aug 2020 10:21:14 +0200 Subject: WIP --- server/lib/Uplcg/BaseUrl.hs | 2 +- server/lib/Uplcg/Config.hs | 24 +++++++++++++ server/lib/Uplcg/Main/Server.hs | 26 +++++++------- server/lib/Uplcg/Views.hs | 80 ++++++++++++++++++++++++++++++++++------- 4 files changed, 107 insertions(+), 25 deletions(-) create mode 100644 server/lib/Uplcg/Config.hs (limited to 'server/lib') 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(); + + + + -- cgit v1.2.3 From 5a3fc14c1a92b28423d1b64b64e12d0502a90219 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 16 Aug 2020 12:29:31 +0200 Subject: Move client to server --- server/lib/Uplcg/Config.hs | 3 -- server/lib/Uplcg/Main/Server.hs | 11 ++---- server/lib/Uplcg/Version.hs | 17 ++++++++ server/lib/Uplcg/Views.hs | 88 ++++++++++++++++++++--------------------- 4 files changed, 63 insertions(+), 56 deletions(-) create mode 100644 server/lib/Uplcg/Version.hs (limited to 'server/lib') diff --git a/server/lib/Uplcg/Config.hs b/server/lib/Uplcg/Config.hs index 627a829..9197d97 100644 --- a/server/lib/Uplcg/Config.hs +++ b/server/lib/Uplcg/Config.hs @@ -3,7 +3,6 @@ module Uplcg.Config , fromEnv ) where -import Data.String (fromString) import qualified Data.Text as T import System.Environment (getEnv) import Uplcg.BaseUrl (BaseUrl) @@ -13,7 +12,6 @@ data Config = Config { cHostname :: String , cPort :: Int , cBaseUrl :: BaseUrl - , cVersion :: String } deriving (Show) fromEnv :: IO Config @@ -21,4 +19,3 @@ 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 72b9377..acf2931 100644 --- a/server/lib/Uplcg/Main/Server.hs +++ b/server/lib/Uplcg/Main/Server.hs @@ -9,7 +9,7 @@ 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 @@ -30,7 +30,6 @@ 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) @@ -104,11 +103,9 @@ scottyApp server = Scotty.scottyApp $ do Scotty.html . renderHtml $ Views.rooms (serverConfig server) views 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" 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 index 3cb9ebe..772c83b 100644 --- a/server/lib/Uplcg/Views.hs +++ b/server/lib/Uplcg/Views.hs @@ -2,15 +2,18 @@ module Uplcg.Views ( RoomView (..) , rooms + , client ) where -import Data.Foldable (for_) -import Data.Text (Text) -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as A import qualified Data.ByteString.Lazy.Builder as BLB -import qualified Uplcg.BaseUrl as BaseUrl +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 @@ -25,7 +28,7 @@ template conf title body = H.docTypeHtml $ do 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 (cVersion conf) + H.footer $ "Untitled PL Card Game version " <> H.toHtml version rooms :: Config -> [RoomView] -> H.Html rooms conf rids = template conf "Untitled PL Card Game" $ do @@ -43,44 +46,37 @@ 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")}); + 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 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(); - - - - + "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();" -- cgit v1.2.3 From d543ef8b1f68a23f9bc3706363fc3807ccbabf30 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 16 Aug 2020 12:33:21 +0200 Subject: Room list styling --- server/lib/Uplcg/Views.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) (limited to 'server/lib') diff --git a/server/lib/Uplcg/Views.hs b/server/lib/Uplcg/Views.hs index 772c83b..8241158 100644 --- a/server/lib/Uplcg/Views.hs +++ b/server/lib/Uplcg/Views.hs @@ -31,15 +31,16 @@ template conf title body = H.docTypeHtml $ do H.footer $ "Untitled PL Card Game version " <> H.toHtml version 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 - ")" +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 -- cgit v1.2.3