aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--Makefile13
-rw-r--r--client/index.html21
-rw-r--r--client/src/Client.elm16
-rw-r--r--config.mk3
-rw-r--r--server/lib/Cafp/Main/Server.hs35
5 files changed, 56 insertions, 32 deletions
diff --git a/Makefile b/Makefile
index 0f7a475..bca08c4 100644
--- a/Makefile
+++ b/Makefile
@@ -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
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-02 23:19:57 +0000