Move client to server

5 files changed, 67 insertions, 56 deletions

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();
-    </script>
-    <footer>Untitled PL Card Game version $UPLCG_VERSION</footer>
-  </body>
-</html>
+      "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,