WIP

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