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 ++++++++++++++++++++--------------------- server/uplcg.cabal | 4 ++ 5 files changed, 67 insertions(+), 56 deletions(-) create mode 100644 server/lib/Uplcg/Version.hs (limited to 'server') 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();" diff --git a/server/uplcg.cabal b/server/uplcg.cabal index 72b2f82..c97d358 100644 --- a/server/uplcg.cabal +++ b/server/uplcg.cabal @@ -14,6 +14,7 @@ Library Default-language: Haskell2010 Ghc-options: -Wall Hs-source-dirs: lib + Other-modules: Paths_uplcg Exposed-modules: Uplcg.BaseUrl @@ -23,6 +24,7 @@ Library Uplcg.Main.GenerateElmTypes Uplcg.Main.Server Uplcg.Messages + Uplcg.Version Uplcg.Views Build-depends: @@ -36,9 +38,11 @@ Library 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, -- cgit v1.2.3