diff options
Diffstat (limited to '')
-rw-r--r-- | Makefile | 13 | ||||
-rw-r--r-- | client/index.html | 21 | ||||
-rw-r--r-- | client/src/Client.elm | 16 | ||||
-rw-r--r-- | config.mk | 3 | ||||
-rw-r--r-- | server/lib/Cafp/Main/Server.hs | 35 |
5 files changed, 56 insertions, 32 deletions
@@ -1,3 +1,5 @@ +include config.mk + HS_SOURCES=$(shell find server/lib/ server/src -name '*.hs') ELM_SOURCES=$(shell find client/src -name '*.elm') ELM_MESSAGES_SOURCE=client/src/Messages.elm @@ -9,8 +11,13 @@ build: server/assets/client.js \ server/assets/black.txt \ server/assets/white.txt +.PHONY: server server: build - cd server && stack exec cafp-server + (cd server && \ + CAFP_HOSTNAME=$(CAFP_HOSTNAME) \ + CAFP_PORT=$(CAFP_PORT) \ + CAFP_BASE=$(CAFP_BASE) \ + stack exec cafp-server) .PHONY: stack_build stack_build: $(HS_SOURCES) @@ -23,8 +30,8 @@ server/assets/client.js: $(ELM_MESSAGES_SOURCE) $(ELM_SOURCES) mkdir -p server/assets cd client && elm make src/Client.elm --output=../server/assets/client.js -server/assets/client.html: client/index.html - cp client/index.html $@ +server/assets/client.html: client/index.html config.mk + sed "s@\$$CAFP_BASE@$(CAFP_BASE)@" $< >$@ server/assets/style.css: client/style.css cp $< $@ diff --git a/client/index.html b/client/index.html index adc2ac8..8e1333d 100644 --- a/client/index.html +++ b/client/index.html @@ -1,19 +1,22 @@ <!DOCTYPE HTML> <html> -<head> - <meta charset="UTF-8"> - <title>Client</title> - <link rel="stylesheet" type="text/css" href="/assets/style.css"> -</head> + <head> + <meta charset="UTF-8"> + <title>Client</title> + <link rel="stylesheet" type="text/css" href="$CAFP_BASE/assets/style.css"> + </head> <body> <div id="main"></div> - <script type="text/JavaScript" src="/assets/client.js"></script> + <script type="text/JavaScript" src="$CAFP_BASE/assets/client.js"></script> <script> var app = Elm.Client.init({node: document.querySelector("main")}); - - var roomId = document.location.pathname.split("/")[2]; + var path = document.location.pathname; + if(path.startsWith("$CAFP_BASE")) { + path = path.substr("$CAFP_BASE".length); + } + var roomId = path.split("/")[2]; var url = "ws://" + document.location.host + - "/rooms/" + roomId + "/events"; + "$CAFP_BASE/rooms/" + roomId + "/events"; var socket = new WebSocket(url); app.ports.webSocketOut.subscribe(function(message) { socket.send(message); diff --git a/client/src/Client.elm b/client/src/Client.elm index 7cac663..6b65091 100644 --- a/client/src/Client.elm +++ b/client/src/Client.elm @@ -42,15 +42,8 @@ type alias GameState = type Model = Error String | Connecting - { roomId : String - } | Game GameState -parseRoomId : Url -> Result String String -parseRoomId url = case String.split "/" url.path of - _ :: "rooms" :: roomId :: _ -> Ok roomId - _ -> Err <| "Invalid path: " ++ url.path - viewPlayer : Messages.PlayerView -> Html msg viewPlayer player = Html.div [] <| [ Html.text player.name @@ -64,10 +57,7 @@ view model = case model of [ Html.h1 [] [Html.text "Error"] , Html.p [] [Html.text str] ] - Connecting state -> - [ Html.h1 [] - [Html.text <| "Connecting to room " ++ state.roomId ++ "..."] - ] + Connecting -> [Html.h1 [] [Html.text "Connecting to room..."]] Game game -> [ Html.h1 [] [Html.text "Players"] , Html.ul [] <| List.map @@ -305,9 +295,7 @@ update msg model = case msg of main : Program () Model Msg main = Browser.application - { init = \() url key -> case parseRoomId url of - Err str -> (Error <| "Could not parse room ID: " ++ str, Cmd.none) - Ok roomId -> (Connecting {roomId = roomId}, Cmd.none) + { init = \() url key -> (Connecting, Cmd.none) , update = update , subscriptions = subscriptions , view = \model -> {title = "Client", body = view model} diff --git a/config.mk b/config.mk new file mode 100644 index 0000000..add25a1 --- /dev/null +++ b/config.mk @@ -0,0 +1,3 @@ +CAFP_HOSTNAME=127.0.0.1 +CAFP_PORT=8002 +CAFP_BASE=/cafp diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs index 21cdb6f..9ded571 100644 --- a/server/lib/Cafp/Main/Server.hs +++ b/server/lib/Cafp/Main/Server.hs @@ -13,9 +13,13 @@ import Control.Exception (bracket) import Control.Lens ((^.)) import Control.Monad (forever, when) import qualified Data.Aeson as Aeson +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Foldable (for_) import qualified Data.HashMap.Strict as HMS +import qualified Data.List as L +import Data.Maybe (fromMaybe) +import Data.String (fromString) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T @@ -24,6 +28,7 @@ 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.IO as IO import System.Random (StdGen, newStdGen) import qualified Web.Scotty as Scotty @@ -61,6 +66,7 @@ newRoom server gen = Room <$> (STM.newTVar $ newGame (serverCards server) gen) <*> STM.newTVar HMS.empty + scottyApp :: IO Wai.Application scottyApp = Scotty.scottyApp $ do Scotty.get "/rooms/:id/" $ do @@ -81,9 +87,9 @@ scottyApp = Scotty.scottyApp $ do routePendingConnection :: WS.PendingConnection -> Maybe RoomId routePendingConnection pending = let path = T.decodeUtf8 . WS.requestPath $ WS.pendingRequest pending in - case T.split (== '/') path of - [_, "rooms", roomId, "events"] -> Just roomId - _ -> Nothing + case splitPath path of + ["rooms", roomId, "events"] -> Just roomId + _ -> Nothing getOrCreateRoom :: Server -> RoomId -> IO Room getOrCreateRoom server roomId = MVar.modifyMVar (serverRooms server) $ \rooms -> @@ -146,11 +152,28 @@ wsApp server pc = case routePendingConnection pc of Nothing -> do warning $ "Could not decode client message: " ++ show msg +splitPath :: T.Text -> [T.Text] +splitPath = filter (not . T.null) . T.split (== '/') + +baseUrl :: [T.Text] -> Wai.Middleware +baseUrl prefix application = \req -> + case L.stripPrefix prefix (Wai.pathInfo req) of + Nothing -> application req + Just path -> application req + { Wai.pathInfo = path + , Wai.rawPathInfo = fromMaybe (Wai.rawPathInfo req) . + B.stripPrefix bs $ Wai.rawPathInfo req + } + where + bs = T.encodeUtf8 $ "/" <> T.intercalate "/" prefix + main :: IO () main = do - let port = 3000 - settings = Warp.setPort port Warp.defaultSettings + host <- fromString <$> getEnv "CAFP_HOSTNAME" + port <- read <$> getEnv "CAFP_PORT" + base <- splitPath . T.pack <$> getEnv "CAFP_BASE" + let settings = Warp.setPort port . Warp.setHost host $ Warp.defaultSettings server <- newServer sapp <- scottyApp - Warp.runSettings settings $ + Warp.runSettings settings $ baseUrl base $ WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp |