diff options
author | Jasper Van der Jeugt | 2020-08-16 10:21:14 +0200 |
---|---|---|
committer | Jasper Van der Jeugt | 2020-08-16 10:21:14 +0200 |
commit | 9f2d12f0b098a365d7b0d4cc00b03fd2e5284740 (patch) | |
tree | bab2b7de1ccdb4618640cc951490d51ed8c66938 /server | |
parent | 41622353bc3309921109f44bc0163e0987c20052 (diff) |
WIP
Diffstat (limited to 'server')
-rw-r--r-- | server/lib/Uplcg/BaseUrl.hs | 2 | ||||
-rw-r--r-- | server/lib/Uplcg/Config.hs | 24 | ||||
-rw-r--r-- | server/lib/Uplcg/Main/Server.hs | 26 | ||||
-rw-r--r-- | server/lib/Uplcg/Views.hs | 80 | ||||
-rw-r--r-- | server/uplcg.cabal | 1 |
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 |