diff --git a/frontend/dist/index.html b/frontend/dist/index.html
index f571a1e..45d3d84 100644
--- a/frontend/dist/index.html
+++ b/frontend/dist/index.html
@@ -297,6 +297,36 @@
font-size: 12px;
}
+ .rt-settings-panel {
+ display: flex;
+ justify-content: flex-end;
+ gap: 12px;
+ padding: 8px 18px;
+ border-bottom: 1px solid oklch(0.22 0.01 260);
+ background: oklch(0.155 0.009 260);
+ flex: none;
+ }
+
+ .rt-settings-field {
+ width: min(100%, 420px);
+ display: grid;
+ grid-template-columns: 132px minmax(0, 1fr);
+ align-items: center;
+ gap: 10px;
+ color: oklch(0.58 0.01 260);
+ font-size: 10px;
+ font-weight: 700;
+ letter-spacing: 0;
+ text-transform: uppercase;
+ }
+
+ .rt-settings-field input {
+ min-width: 0;
+ text-transform: none;
+ letter-spacing: 0;
+ font-size: 12px;
+ }
+
.rt-actions {
justify-content: flex-end;
gap: 12px;
diff --git a/frontend/src/Riptide/App.purs b/frontend/src/Riptide/App.purs
index 6307ff6..ff38505 100644
--- a/frontend/src/Riptide/App.purs
+++ b/frontend/src/Riptide/App.purs
@@ -44,6 +44,8 @@ data Action
| GoSong
| GoDefs
| ToggleEngine
+ | ToggleSettings
+ | SetBackendHost String
| Hush
| NewSong
| NewToolbox
@@ -96,7 +98,7 @@ data Action
| SetLoopEnd String
| MoveLoop Int
| PlayheadTick H.SubscriptionId Number
- | SocketEvent H.SubscriptionId WebSocket.WebSocketEvent
+ | SocketEvent Int H.SubscriptionId WebSocket.WebSocketEvent
component :: forall query input output m. MonadAff m => H.Component query input output m
component =
@@ -118,6 +120,8 @@ shellActions =
{ goSong: GoSong
, goDefs: GoDefs
, toggleEngine: ToggleEngine
+ , toggleSettings: ToggleSettings
+ , setBackendHost: SetBackendHost
, hush: Hush
, newSong: NewSong
, newToolbox: NewToolbox
@@ -187,9 +191,12 @@ definitionsActions =
handleAction :: forall output m. MonadAff m => Action -> H.HalogenM App Action () output m Unit
handleAction = case _ of
Initialize -> do
+ backendHost <- H.liftEffect WebSocket.loadBackendHost
+ H.modify_ (Reducer.setBackendHost backendHost)
app <- H.get
- H.modify_ (Reducer.setConnection Connecting)
- subscribeWebSocket
+ when app.engine do
+ H.modify_ (Reducer.setConnection Connecting)
+ subscribeWebSocket
when app.playing startPlayhead
CancelConfirm ->
H.modify_ Reducer.cancelConfirm
@@ -224,15 +231,36 @@ handleAction = case _ of
let silenced = Reducer.hush app
sendPlaybackTransitions app silenced
traverse_ (H.liftEffect <<< WebSocket.close) app.websocket
- H.put (silenced { websocket = Nothing, connection = Disconnected })
+ H.put (silenced { websocket = Nothing, websocketGeneration = silenced.websocketGeneration + 1, connection = Disconnected })
Disconnected -> do
- H.modify_ (Reducer.setConnection Connecting)
+ H.modify_ \state -> Reducer.setConnection Connecting (state { websocketGeneration = state.websocketGeneration + 1 })
subscribeWebSocket
ConnectionError _ -> do
- H.modify_ (Reducer.setConnection Connecting)
+ H.modify_ \state -> Reducer.setConnection Connecting (state { websocketGeneration = state.websocketGeneration + 1 })
subscribeWebSocket
Connecting ->
pure unit
+ ToggleSettings ->
+ H.modify_ \app -> Reducer.setSettingsOpen (not app.settingsOpen) app
+ SetBackendHost backendHost -> do
+ app <- H.get
+ when (backendHost /= app.backendHost) do
+ H.liftEffect (WebSocket.saveBackendHost backendHost)
+ traverse_ (H.liftEffect <<< WebSocket.close) app.websocket
+ let
+ reconnect =
+ case app.connection of
+ Disconnected -> false
+ _ -> app.engine
+ nextGeneration = app.websocketGeneration + 1
+ H.modify_ \state ->
+ state
+ { backendHost = backendHost
+ , websocket = Nothing
+ , websocketGeneration = nextGeneration
+ , connection = if reconnect then Connecting else state.connection
+ }
+ when reconnect subscribeWebSocket
Hush -> do
before <- H.get
let after = Reducer.hush before
@@ -455,8 +483,8 @@ handleAction = case _ of
sendPlaybackTransitions app after
else
H.unsubscribe subscriptionId
- SocketEvent subscriptionId event ->
- handleSocketEvent subscriptionId event
+ SocketEvent generation subscriptionId event ->
+ handleSocketEvent generation subscriptionId event
startPlayhead :: forall output m. MonadAff m => H.HalogenM App Action () output m Unit
startPlayhead =
@@ -464,9 +492,10 @@ startPlayhead =
Playhead.animationFrameEmitter (PlayheadTick subscriptionId)
subscribeWebSocket :: forall output m. MonadAff m => H.HalogenM App Action () output m Unit
-subscribeWebSocket =
+subscribeWebSocket = do
+ app <- H.get
H.subscribe' \subscriptionId ->
- WebSocket.connectEmitter (SocketEvent subscriptionId)
+ WebSocket.connectEmitter app.backendHost (SocketEvent app.websocketGeneration subscriptionId)
advancePlayhead :: Number -> App -> App
advancePlayhead dt app =
@@ -574,8 +603,20 @@ showToast message = do
H.modify_ \app -> app { toast = Just message }
H.subscribe' \subscriptionId -> Files.timeoutEmitter 2400 (ClearToast subscriptionId message)
-handleSocketEvent :: forall output m. MonadAff m => H.SubscriptionId -> WebSocket.WebSocketEvent -> H.HalogenM App Action () output m Unit
-handleSocketEvent subscriptionId = case _ of
+handleSocketEvent :: forall output m. MonadAff m => Int -> H.SubscriptionId -> WebSocket.WebSocketEvent -> H.HalogenM App Action () output m Unit
+handleSocketEvent generation subscriptionId event = do
+ app <- H.get
+ if generation == app.websocketGeneration then
+ handleCurrentSocketEvent subscriptionId event
+ else
+ case event of
+ WebSocket.WebSocketClosed ->
+ H.unsubscribe subscriptionId
+ _ ->
+ pure unit
+
+handleCurrentSocketEvent :: forall output m. MonadAff m => H.SubscriptionId -> WebSocket.WebSocketEvent -> H.HalogenM App Action () output m Unit
+handleCurrentSocketEvent subscriptionId = case _ of
WebSocket.WebSocketReady socket ->
H.modify_ (Reducer.setWebSocket (Just socket))
WebSocket.WebSocketOpened -> do
diff --git a/frontend/src/Riptide/Model.purs b/frontend/src/Riptide/Model.purs
index 688711b..5997629 100644
--- a/frontend/src/Riptide/Model.purs
+++ b/frontend/src/Riptide/Model.purs
@@ -84,6 +84,9 @@ type App =
, engine :: Boolean
, connection :: ConnectionState
, websocket :: Maybe WebSocketClient
+ , websocketGeneration :: Int
+ , backendHost :: String
+ , settingsOpen :: Boolean
, backendValidation :: Array AuthoritativeValidation
, songs :: Array Song
, currentSongId :: Maybe SongId
@@ -175,6 +178,9 @@ defaultApp =
, engine: true
, connection: Disconnected
, websocket: Nothing
+ , websocketGeneration: 0
+ , backendHost: ""
+ , settingsOpen: false
, backendValidation: []
, songs: []
, currentSongId: Nothing
diff --git a/frontend/src/Riptide/Reducer.purs b/frontend/src/Riptide/Reducer.purs
index 0966e42..a5d5087 100644
--- a/frontend/src/Riptide/Reducer.purs
+++ b/frontend/src/Riptide/Reducer.purs
@@ -38,6 +38,8 @@ module Riptide.Reducer
, recordBackendValidation
, selectCell
, setConnection
+ , setBackendHost
+ , setSettingsOpen
, setWebSocket
, setCtrl
, setLoopEnd
@@ -95,6 +97,14 @@ setConnection :: ConnectionState -> App -> App
setConnection connection app =
app { connection = connection }
+setBackendHost :: String -> App -> App
+setBackendHost backendHost app =
+ app { backendHost = backendHost }
+
+setSettingsOpen :: Boolean -> App -> App
+setSettingsOpen settingsOpen app =
+ app { settingsOpen = settingsOpen }
+
setWebSocket :: Maybe WebSocketClient -> App -> App
setWebSocket websocket app =
app { websocket = websocket }
diff --git a/frontend/src/Riptide/View/Icons.purs b/frontend/src/Riptide/View/Icons.purs
index 5ef931a..f1f3ea9 100644
--- a/frontend/src/Riptide/View/Icons.purs
+++ b/frontend/src/Riptide/View/Icons.purs
@@ -31,6 +31,7 @@ data Icon
| Loop
| Pause
| Play
+ | Settings
| Stop
| Upload
@@ -136,6 +137,10 @@ icon glyph =
]
Play ->
[ path "M8 5v14l11-7-11-7Z" ]
+ Settings ->
+ [ circle "12" "12" "3"
+ , path "M19.4 15a1.65 1.65 0 0 0 .33 1.82l.06.06a2 2 0 1 1-2.83 2.83l-.06-.06a1.65 1.65 0 0 0-1.82-.33 1.65 1.65 0 0 0-1 1.51V21a2 2 0 1 1-4 0v-.09a1.65 1.65 0 0 0-1-1.51 1.65 1.65 0 0 0-1.82.33l-.06.06a2 2 0 1 1-2.83-2.83l.06-.06A1.65 1.65 0 0 0 4.6 15a1.65 1.65 0 0 0-1.51-1H3a2 2 0 1 1 0-4h.09a1.65 1.65 0 0 0 1.51-1 1.65 1.65 0 0 0-.33-1.82l-.06-.06a2 2 0 1 1 2.83-2.83l.06.06A1.65 1.65 0 0 0 9 4.6a1.65 1.65 0 0 0 1-1.51V3a2 2 0 1 1 4 0v.09a1.65 1.65 0 0 0 1 1.51 1.65 1.65 0 0 0 1.82-.33l.06-.06a2 2 0 1 1 2.83 2.83l-.06.06A1.65 1.65 0 0 0 19.4 9c.14.47.5.85 1 1H21a2 2 0 1 1 0 4h-.09a1.65 1.65 0 0 0-1.51 1Z"
+ ]
Stop ->
[ rect "7" "7" "10" "10" ]
Upload ->
diff --git a/frontend/src/Riptide/View/Shell.purs b/frontend/src/Riptide/View/Shell.purs
index 21b37a5..a77a197 100644
--- a/frontend/src/Riptide/View/Shell.purs
+++ b/frontend/src/Riptide/View/Shell.purs
@@ -20,6 +20,8 @@ type ShellActions action =
{ goSong :: action
, goDefs :: action
, toggleEngine :: action
+ , toggleSettings :: action
+ , setBackendHost :: String -> action
, hush :: action
, newSong :: action
, newToolbox :: action
@@ -53,9 +55,11 @@ render actions app child =
, HH.div [ HP.classes [ HH.ClassName "rt-spacer" ] ] []
, chipButton (scopeClasses app) (scopeLabel app) actions.goDefs
, chipButton (engineClasses app) (connectionLabel app.connection) actions.toggleEngine
+ , Icons.iconButton "Settings" Settings actions.toggleSettings
, Icons.iconButtonWithClasses "Stop everything" Hush [ HH.ClassName "rt-hush" ] actions.hush
, HH.div [ HP.classes [ HH.ClassName "rt-active" ] ] [ HH.text (activeLabel app) ]
]
+ , if app.settingsOpen then settingsPanel actions app else HH.text ""
, HH.div [ HP.classes [ HH.ClassName "rt-actions" ] ]
[ actionCluster "Song"
[ Icons.iconButton "New song" Add actions.newSong
@@ -98,6 +102,26 @@ actionCluster label buttons =
, HH.div [ HP.classes [ HH.ClassName "rt-action-group" ] ] buttons
]
+settingsPanel :: forall action slots m. ShellActions action -> App -> HH.ComponentHTML action slots m
+settingsPanel actions app =
+ HH.div [ HP.classes [ HH.ClassName "rt-settings-panel" ] ]
+ [ HH.label
+ [ HP.classes [ HH.ClassName "rt-settings-field" ]
+ , HP.attr (HH.AttrName "for") "backend-host"
+ ]
+ [ HH.span_ [ HH.text "Backend host/URL" ]
+ , HH.input
+ [ HP.id "backend-host"
+ , HP.name "backendHost"
+ , HP.type_ HP.InputText
+ , HP.value app.backendHost
+ , HP.placeholder "same origin"
+ , HP.attr (HH.AttrName "autocomplete") "off"
+ , HE.onValueInput actions.setBackendHost
+ ]
+ ]
+ ]
+
scopeClasses :: App -> Array HH.ClassName
scopeClasses app =
[ HH.ClassName "rt-chip", HH.ClassName "rt-scope", if scopeInvalid app then HH.ClassName "is-invalid" else HH.ClassName "is-valid" ]
diff --git a/frontend/src/Riptide/WebSocket.js b/frontend/src/Riptide/WebSocket.js
index 57656a8..4d4591e 100644
--- a/frontend/src/Riptide/WebSocket.js
+++ b/frontend/src/Riptide/WebSocket.js
@@ -3,6 +3,9 @@ const noopSocket = {
close() {}
};
+let fallbackBackendHost = "";
+const backendHostKey = "riptide.backendHost";
+
const report = (handler, value) => {
try {
handler(value)();
@@ -15,19 +18,51 @@ const run = (effect) => {
} catch (_) {}
};
-const websocketUrl = () => {
+const normalizePath = (pathname) => {
+ if (!pathname || pathname === "/") {
+ return "/ws";
+ }
+ return pathname;
+};
+
+export const websocketUrlFromSetting = (page) => (rawSetting) => {
+ const setting = String(rawSetting || "").trim();
+ const pageProtocol = page && page.protocol === "https:" ? "wss:" : "ws:";
+ const pageHost = page && page.host ? page.host : "";
+
+ if (!setting) {
+ return pageHost ? `${pageProtocol}//${pageHost}/ws` : "/ws";
+ }
+
+ if (setting.startsWith("ws://") || setting.startsWith("wss://")) {
+ return setting;
+ }
+
+ if (setting.startsWith("http://") || setting.startsWith("https://")) {
+ try {
+ const url = new URL(setting);
+ const protocol = url.protocol === "https:" ? "wss:" : "ws:";
+ return `${protocol}//${url.host}${normalizePath(url.pathname)}${url.search}${url.hash}`;
+ } catch (_) {
+ return `${pageProtocol}//${setting}/ws`;
+ }
+ }
+
+ return `${pageProtocol}//${setting}/ws`;
+};
+
+export const currentWebSocketUrl = (backendHost) => {
const location = globalThis.location;
if (!location) {
- return "/ws";
+ return websocketUrlFromSetting({ protocol: "http:", host: "" })(backendHost);
}
- const protocol = location.protocol === "https:" ? "wss:" : "ws:";
- return `${protocol}//${location.host}/ws`;
+ return websocketUrlFromSetting({ protocol: location.protocol, host: location.host })(backendHost);
};
-export const connectImpl = (handlers) => () => {
+export const connectImpl = (url) => (handlers) => () => {
try {
- const socket = new WebSocket(websocketUrl());
+ const socket = new WebSocket(url);
socket.onopen = () => run(handlers.onOpen);
socket.onclose = () => run(handlers.onClose);
@@ -47,6 +82,34 @@ export const connectImpl = (handlers) => () => {
}
};
+export const loadBackendHost = () => {
+ try {
+ const storage = globalThis.localStorage;
+ if (!storage) {
+ return fallbackBackendHost;
+ }
+ return storage.getItem(backendHostKey) || "";
+ } catch (_) {
+ return fallbackBackendHost;
+ }
+};
+
+export const saveBackendHost = (value) => () => {
+ const next = String(value || "");
+ fallbackBackendHost = next;
+ try {
+ const storage = globalThis.localStorage;
+ if (!storage) {
+ return;
+ }
+ if (next) {
+ storage.setItem(backendHostKey, next);
+ } else {
+ storage.removeItem(backendHostKey);
+ }
+ } catch (_) {}
+};
+
export const sendImpl = (socket) => (message) => () => {
try {
if (socket && socket.readyState === WebSocket.OPEN) {
diff --git a/frontend/src/Riptide/WebSocket.purs b/frontend/src/Riptide/WebSocket.purs
index 1cfc259..4187f92 100644
--- a/frontend/src/Riptide/WebSocket.purs
+++ b/frontend/src/Riptide/WebSocket.purs
@@ -1,11 +1,15 @@
module Riptide.WebSocket
( WebSocketClient
+ , PageLocation
, WebSocketEvent(..)
, WebSocketHandlers
+ , loadBackendHost
, close
, connect
, connectEmitter
+ , saveBackendHost
, sendCommand
+ , websocketUrlFromSetting
) where
import Prelude
@@ -31,9 +35,15 @@ type WebSocketHandlers =
, onMessage :: ServerEvent -> Effect Unit
}
-connect :: WebSocketHandlers -> Effect WebSocketClient
-connect handlers =
+type PageLocation =
+ { protocol :: String
+ , host :: String
+ }
+
+connect :: String -> WebSocketHandlers -> Effect WebSocketClient
+connect backendHost handlers =
connectImpl
+ (currentWebSocketUrl backendHost)
{ onOpen: handlers.onOpen
, onClose: handlers.onClose
, onError: handlers.onError
@@ -48,11 +58,11 @@ sendCommand :: WebSocketClient -> ClientCommand -> Effect Unit
sendCommand socket =
sendImpl socket <<< encodeClientCommand
-connectEmitter :: forall action. (WebSocketEvent -> action) -> HS.Emitter action
-connectEmitter toAction =
+connectEmitter :: forall action. String -> (WebSocketEvent -> action) -> HS.Emitter action
+connectEmitter backendHost toAction =
map toAction $ HS.makeEmitter \emit -> do
socket <-
- connect
+ connect backendHost
{ onOpen: emit WebSocketOpened
, onClose: emit WebSocketClosed
, onError: emit <<< WebSocketErrored
@@ -62,6 +72,7 @@ connectEmitter toAction =
pure (close socket)
foreign import connectImpl ::
+ String ->
{ onOpen :: Effect Unit
, onClose :: Effect Unit
, onError :: String -> Effect Unit
@@ -72,3 +83,11 @@ foreign import connectImpl ::
foreign import sendImpl :: WebSocketClient -> String -> Effect Unit
foreign import close :: WebSocketClient -> Effect Unit
+
+foreign import websocketUrlFromSetting :: PageLocation -> String -> String
+
+foreign import currentWebSocketUrl :: String -> String
+
+foreign import loadBackendHost :: Effect String
+
+foreign import saveBackendHost :: String -> Effect Unit
diff --git a/frontend/test/Main.purs b/frontend/test/Main.purs
index 0a34d7f..3fe474e 100644
--- a/frontend/test/Main.purs
+++ b/frontend/test/Main.purs
@@ -9,6 +9,7 @@ import Data.Foldable (all)
import Data.Maybe (Maybe(..))
import Data.Number as Number
import Effect (Effect)
+import Effect.Class (liftEffect)
import Effect.Aff (launchAff_)
import Riptide.Action (ControlKey(..))
import Riptide.App as App
@@ -20,6 +21,7 @@ import Riptide.ImportExport as ImportExport
import Riptide.View.Playhead as Playhead
import Riptide.Reducer as Reducer
import Riptide.Validation (authoritativeValidation, valid)
+import Riptide.WebSocket as WebSocket
import Test.Spec (describe, it)
import Test.Spec.Assertions (shouldEqual, shouldSatisfy)
import Test.Spec.QuickCheck (quickCheck)
@@ -73,6 +75,29 @@ main =
Model.canUseBackend (Model.ConnectionError "websocket error") `shouldEqual` false
describe "websocket protocol" do
+ it "derives websocket URLs from the backend host setting" do
+ let
+ httpPage = { protocol: "http:", host: "ui.example:8200" }
+ httpsPage = { protocol: "https:", host: "ui.example:8200" }
+
+ WebSocket.websocketUrlFromSetting httpPage "" `shouldEqual` "ws://ui.example:8200/ws"
+ WebSocket.websocketUrlFromSetting httpsPage "" `shouldEqual` "wss://ui.example:8200/ws"
+ WebSocket.websocketUrlFromSetting httpPage "100.111.19.2:8201" `shouldEqual` "ws://100.111.19.2:8201/ws"
+ WebSocket.websocketUrlFromSetting httpsPage "100.111.19.2:8201" `shouldEqual` "wss://100.111.19.2:8201/ws"
+ WebSocket.websocketUrlFromSetting httpPage "ws://100.111.19.2:8201/ws" `shouldEqual` "ws://100.111.19.2:8201/ws"
+ WebSocket.websocketUrlFromSetting httpsPage "wss://100.111.19.2:8201/ws" `shouldEqual` "wss://100.111.19.2:8201/ws"
+ WebSocket.websocketUrlFromSetting httpPage "http://100.111.19.2:8201" `shouldEqual` "ws://100.111.19.2:8201/ws"
+ WebSocket.websocketUrlFromSetting httpsPage "https://100.111.19.2:8201/tidal" `shouldEqual` "wss://100.111.19.2:8201/tidal"
+
+ it "round-trips the backend host setting through storage" do
+ value <- liftEffect do
+ WebSocket.saveBackendHost "127.0.0.1:8201"
+ loaded <- WebSocket.loadBackendHost
+ WebSocket.saveBackendHost ""
+ pure loaded
+
+ value `shouldEqual` "127.0.0.1:8201"
+
it "encodes client commands with backend tags and field names" do
Protocol.encodeClientCommand (Protocol.ValidateText "d1 $ sound \"bd\"") `shouldEqual`
"{\"type\":\"validateText\",\"text\":\"d1 $ sound \\\"bd\\\"\"}"
diff --git a/gate.sh b/gate.sh
index 8117be2..e4969da 100755
--- a/gate.sh
+++ b/gate.sh
@@ -43,6 +43,7 @@ const server = http.createServer((req, res) => {
});
});
const sockets = new Set();
+let websocketConnections = 0;
server.on("upgrade", (req, socket) => {
if (req.url !== "/ws") {
socket.destroy();
@@ -65,6 +66,7 @@ server.on("upgrade", (req, socket) => {
"",
"",
].join("\r\n"));
+ websocketConnections += 1;
sockets.add(socket);
socket.on("close", () => sockets.delete(socket));
socket.on("error", () => sockets.delete(socket));
@@ -132,6 +134,7 @@ try {
throw new Error("frontend rendered a blank document body");
}
await assertFrontendInteractions(cdp);
+ await assertBackendSettings(cdp, port, () => websocketConnections);
await cdp.close();
} finally {
chromeProcess.kill("SIGTERM");
@@ -462,6 +465,48 @@ async function assertFrontendInteractions(cdp) {
})()`, 2000, "second confirm delete click did not remove the cell");
}
+async function assertBackendSettings(cdp, port, getConnectionCount) {
+ await evaluateOrThrow(cdp, `(() => {
+ const button = document.querySelector("button[title='Settings'], button[aria-label='Settings']");
+ if (!button) throw new Error("missing settings control");
+ button.click();
+ const labels = [...document.querySelectorAll("label")];
+ const label = labels.find((node) => /backend host\\/url/i.test(node.textContent || ""));
+ if (!label) throw new Error("missing backend host/url label");
+ const targetId = label.getAttribute("for");
+ const input = targetId ? document.getElementById(targetId) : label.querySelector("input");
+ if (!(input instanceof HTMLInputElement)) throw new Error("missing backend host/url input");
+ const box = input.getBoundingClientRect();
+ const style = getComputedStyle(input);
+ if (box.width === 0 || box.height === 0 || style.display === "none" || style.visibility === "hidden") {
+ throw new Error("backend host/url input is not visible");
+ }
+ })()`);
+
+ const before = getConnectionCount();
+ await evaluateOrThrow(cdp, `(() => {
+ const input = document.querySelector("#backend-host, input[name='backendHost']");
+ if (!(input instanceof HTMLInputElement)) throw new Error("missing backend host/url input for reconnect");
+ input.focus();
+ input.value = "127.0.0.1:${port}";
+ input.dispatchEvent(new Event("input", { bubbles: true }));
+ input.dispatchEvent(new Event("change", { bubbles: true }));
+ })()`);
+
+ await waitUntil(
+ () => getConnectionCount() > before,
+ 5000,
+ "backend host/url change did not reconnect websocket"
+ );
+
+ await waitForCondition(
+ cdp,
+ `/engine connected/i.test(document.querySelector(".rt-engine")?.textContent || "")`,
+ 5000,
+ "engine did not reconnect after backend host/url change"
+ );
+}
+
async function evaluateOrThrow(cdp, expression) {
const response = await cdp.send("Runtime.evaluate", {
expression,
diff --git a/riptide.cabal b/riptide.cabal
index c50d312..e2c9f1b 100644
--- a/riptide.cabal
+++ b/riptide.cabal
@@ -54,6 +54,7 @@ library
, directory
, filepath
, hint
+ , http-types
, process
, text
, tidal
@@ -89,10 +90,16 @@ test-suite unit-tests
build-depends:
, aeson
, base <5
+ , bytestring
, directory
, filepath
, hspec
+ , http-types
, QuickCheck
, riptide
, text
, tidal
+ , wai
+ , wai-extra
+ , warp
+ , websockets
diff --git a/specs/039-host-setting-cors/plan.md b/specs/039-host-setting-cors/plan.md
new file mode 100644
index 0000000..1704e27
--- /dev/null
+++ b/specs/039-host-setting-cors/plan.md
@@ -0,0 +1,51 @@
+# Implementation Plan
+
+## Tech stack
+
+- Haskell backend using WAI, Warp, wai-websockets, and websockets.
+- PureScript Halogen frontend with a JavaScript FFI websocket/localStorage boundary.
+- Existing `./gate.sh` for build, unit, formatting, hlint, frontend nix build, and Chromium render smoke.
+
+## Slice 1: backend CORS
+
+Owned implementation surface:
+
+- `src/Riptide/Server.hs`
+- `test/Riptide/ServerSpec.hs`
+- `riptide.cabal` if direct dependencies are needed for tests or HTTP status/header helpers.
+
+Expected changes:
+
+- Extend `ServerConfig` with configured CORS origins, defaulting to `["*"]`.
+- Read `RIPTIDE_CORS_ORIGINS`, accepting a comma-separated list and preserving `*`.
+- Wrap the WAI application with CORS headers and an `OPTIONS` preflight response.
+- Preserve websocket upgrade handling through `websocketsOr` and do not add Origin rejection.
+- Add focused backend tests for default/config parsing, CORS headers on HTTP responses, preflight, and cross-origin websocket upgrade acceptance.
+
+## Slice 2: frontend backend setting
+
+Owned implementation surface:
+
+- `frontend/src/Riptide/**`
+- `frontend/test/**`
+- `frontend/spago.yaml` only if a direct dependency is genuinely needed.
+- `gate.sh` only for render-smoke assertions of the new setting affordance and reconnect behavior.
+- `frontend/dist/index.html` for CSS.
+
+Expected changes:
+
+- Add backend URL/host state to `App` and seed/default state.
+- Add localStorage FFI for loading/saving the backend setting.
+- Refactor websocket URL building so it is testable and uses the configured setting.
+- On app initialization, load the stored backend setting before connecting.
+- Add shell/top-bar settings UI with a visible settings control and backend host/URL field.
+- On setting change, persist, close the existing socket, set connection to Connecting when the engine is enabled, and subscribe a new websocket using the new URL.
+- Add PureScript tests for URL derivation and storage round-trip.
+- Update render smoke to assert the settings control exists and that changing the input attempts a websocket connection to the configured host while preserving existing interaction checks.
+
+## Verification
+
+- Slice 1 focused command: `nix develop --command just unit Riptide.Server`.
+- Slice 2 focused command: `nix develop .#frontend --command just --justfile frontend/justfile test`.
+- Final command for every accepted implementation commit: `./gate.sh`.
+- Manual/live smoke before final completion: run `riptide serve`, open the served UI in a browser, set the backend host field to the local server host, confirm connection status changes to connected, and confirm CORS preflight headers with `curl -i -X OPTIONS`.
diff --git a/specs/039-host-setting-cors/spec.md b/specs/039-host-setting-cors/spec.md
new file mode 100644
index 0000000..7535b1b
--- /dev/null
+++ b/specs/039-host-setting-cors/spec.md
@@ -0,0 +1,34 @@
+# Issue 39: backend host setting and CORS
+
+## P1 user story
+
+As an operator serving the riptide UI from one origin and the backend from a tailnet host, I need the UI to remember which backend to connect to and the backend to accept cross-origin HTTP and websocket traffic.
+
+## Scope
+
+- Add configurable backend CORS behavior to the Haskell server.
+- Add a top-bar settings affordance to the frontend for a backend host or websocket URL.
+- Persist the frontend setting in `localStorage`.
+- Reconnect the websocket when the setting changes.
+- Preserve existing same-origin behavior when the setting is empty.
+
+## Functional requirements
+
+- FR-039-001: `RIPTIDE_CORS_ORIGINS` is read into server configuration and defaults to permissive `*`.
+- FR-039-002: HTTP responses include CORS headers, including origin, methods, and headers.
+- FR-039-003: `OPTIONS` preflight requests return a successful empty response with CORS headers.
+- FR-039-004: Cross-origin websocket upgrades to `/ws` are accepted; server code must not reject based on the `Origin` header.
+- FR-039-005: The frontend exposes a small shell/top-bar settings control containing a backend host or URL input.
+- FR-039-006: Empty backend setting builds the current same-origin `/ws` URL.
+- FR-039-007: A host:port setting such as `100.111.19.2:8201` builds `ws://100.111.19.2:8201/ws` or `wss://.../ws` when the page is HTTPS.
+- FR-039-008: A full `ws://.../ws` or `wss://.../ws` setting is used as provided.
+- FR-039-009: The setting round-trips through `localStorage`.
+- FR-039-010: Changing the setting closes the current socket, stores the value, shows connecting/offline status through the existing connection state, and reconnects.
+
+## Success criteria
+
+- Backend unit tests cover CORS config/defaults, preflight headers, foreign-origin headers, and cross-origin websocket acceptance.
+- Frontend tests cover URL derivation and storage round-trip.
+- Render smoke covers the settings affordance and remains green for existing interactions.
+- `./gate.sh` passes locally.
+- PR CI is 4/4 green.
diff --git a/specs/039-host-setting-cors/tasks.md b/specs/039-host-setting-cors/tasks.md
new file mode 100644
index 0000000..0f04c12
--- /dev/null
+++ b/specs/039-host-setting-cors/tasks.md
@@ -0,0 +1,19 @@
+# Tasks
+
+## Slice 1 - backend CORS
+
+- [X] T039-S1 Add CORS origins to server config with permissive default and env parsing.
+- [X] T039-S1 Add CORS headers to HTTP responses and implement successful `OPTIONS` preflight.
+- [X] T039-S1 Preserve websocket upgrades without rejecting cross-origin `Origin`.
+- [X] T039-S1 Add backend tests for config, preflight, foreign-origin headers, and cross-origin websocket acceptance.
+- [X] T039-S1 Run focused backend tests and `./gate.sh`, then commit with the required trailer.
+
+## Slice 2 - frontend backend setting
+
+- [X] T039-S2 Add persisted backend host/URL state and localStorage FFI.
+- [X] T039-S2 Build websocket URLs from the setting, preserving same-origin behavior when empty.
+- [X] T039-S2 Add shell/top-bar settings UI for the backend host/URL field.
+- [X] T039-S2 Reconnect on setting changes while preserving connection status behavior.
+- [X] T039-S2 Add frontend tests for URL derivation and storage round-trip.
+- [X] T039-S2 Update render smoke for the settings affordance and configured websocket connection.
+- [X] T039-S2 Run focused frontend tests and `./gate.sh`, then commit with the required trailer.
diff --git a/src/Riptide/Server.hs b/src/Riptide/Server.hs
index f486056..8d30e86 100644
--- a/src/Riptide/Server.hs
+++ b/src/Riptide/Server.hs
@@ -32,6 +32,8 @@ import Data.Aeson
( eitherDecode
, encode
)
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as ByteString.Char8
import Data.ByteString.Lazy qualified as LazyByteString
import Data.Foldable (traverse_)
import Data.IORef (newIORef)
@@ -43,7 +45,17 @@ import Data.Maybe (fromMaybe)
import Data.String (fromString)
import Data.Text (Text)
import Data.Text qualified as Text
-import Network.Wai (Application)
+import Network.HTTP.Types
+ ( ResponseHeaders
+ , methodOptions
+ , status204
+ )
+import Network.Wai
+ ( Application
+ , Request (..)
+ , mapResponseHeaders
+ , responseLBS
+ )
import Network.Wai.Application.Static
( defaultFileServerSettings
, staticApp
@@ -93,6 +105,7 @@ data ServerConfig = ServerConfig
, serverFrontendDir :: FilePath
, serverStateDirectory :: FilePath
, serverSlotCapacity :: Int
+ , serverCorsOrigins :: [String]
}
deriving stock (Show, Eq)
@@ -134,6 +147,7 @@ readServerConfigFrom lookupVar = do
configuredFrontendDir <- lookupVar "RIPTIDE_FRONTEND_DIR"
configuredStateDir <- lookupVar "RIPTIDE_STATE_DIR"
configuredSlotCapacity <- lookupVar "RIPTIDE_SLOT_CAPACITY"
+ configuredCorsOrigins <- lookupVar "RIPTIDE_CORS_ORIGINS"
pure $ do
serverPort <- parseServerPort configuredPort
serverSlotCapacity <- parseSlotCapacity configuredSlotCapacity
@@ -144,6 +158,7 @@ readServerConfigFrom lookupVar = do
fromMaybe "frontend/dist" configuredFrontendDir
, serverStateDirectory =
fromMaybe ".riptide-state" configuredStateDir
+ , serverCorsOrigins = parseCorsOrigins configuredCorsOrigins
, ..
}
@@ -168,14 +183,20 @@ runServerFromEnvironment = do
session
Warp.runSettings
(warpSettings config)
- (serverApplication server $ serverFrontendDir config)
+ ( serverApplication (serverCorsOrigins config) server $
+ serverFrontendDir config
+ )
-serverApplication :: ServerState -> FilePath -> Application
-serverApplication server frontendDir =
+serverApplication
+ :: [String] -> ServerState -> FilePath -> Application
+serverApplication corsOrigins server frontendDir =
websocketsOr
WebSockets.defaultConnectionOptions
(websocketApplication server)
- (staticApp $ defaultFileServerSettings frontendDir)
+ ( corsMiddleware corsOrigins $
+ staticApp $
+ defaultFileServerSettings frontendDir
+ )
handleClientCommand
:: ServerState -> ClientCommand -> IO [ServerEvent]
@@ -403,6 +424,55 @@ parseSlotCapacity (Just rawCapacity) =
| capacity >= 0 -> Right capacity
_ -> Left $ InvalidSlotCapacity rawCapacity
+parseCorsOrigins :: Maybe String -> [String]
+parseCorsOrigins Nothing =
+ ["*"]
+parseCorsOrigins (Just rawOrigins) =
+ Text.unpack . Text.strip
+ <$> Text.splitOn "," (Text.pack rawOrigins)
+
+corsMiddleware :: [String] -> Application -> Application
+corsMiddleware configuredOrigins app request respond
+ | requestMethod request == methodOptions =
+ respond $ responseLBS status204 headers ""
+ | otherwise =
+ app request $ respond . mapResponseHeaders (headers <>)
+ where
+ headers = corsHeaders configuredOrigins request
+
+corsHeaders :: [String] -> Request -> ResponseHeaders
+corsHeaders configuredOrigins request =
+ originHeaders <> metadataHeaders
+ where
+ originHeaders =
+ case allowedOrigin configuredOrigins request of
+ Just origin ->
+ [("Access-Control-Allow-Origin", origin)]
+ <> varyOriginHeader configuredOrigins
+ Nothing ->
+ varyOriginHeader configuredOrigins
+
+metadataHeaders :: ResponseHeaders
+metadataHeaders =
+ [ ("Access-Control-Allow-Methods", "GET, POST, OPTIONS")
+ , ("Access-Control-Allow-Headers", "Content-Type")
+ ]
+
+allowedOrigin :: [String] -> Request -> Maybe ByteString
+allowedOrigin configuredOrigins request
+ | "*" `elem` configuredOrigins = Just "*"
+ | otherwise = do
+ origin <- lookup "Origin" $ requestHeaders request
+ let allowedOrigins = ByteString.Char8.pack <$> configuredOrigins
+ if origin `elem` allowedOrigins
+ then Just origin
+ else Nothing
+
+varyOriginHeader :: [String] -> ResponseHeaders
+varyOriginHeader configuredOrigins
+ | "*" `elem` configuredOrigins = []
+ | otherwise = [("Vary", "Origin")]
+
forever :: (Applicative f) => f a -> f b
forever action =
action *> forever action
diff --git a/test/Riptide/ServerSpec.hs b/test/Riptide/ServerSpec.hs
index 5608e8b..9e7ad1c 100644
--- a/test/Riptide/ServerSpec.hs
+++ b/test/Riptide/ServerSpec.hs
@@ -3,10 +3,31 @@ module Riptide.ServerSpec
) where
import Control.Exception (bracket)
+import Data.Aeson (decode)
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy qualified as LazyByteString
import Data.IORef (IORef, newIORef, readIORef)
import Data.List (find)
import Data.Text (Text)
import Data.Text qualified as Text
+import Network.HTTP.Types
+ ( HeaderName
+ , methodGet
+ , methodOptions
+ , statusCode
+ )
+import Network.Wai
+ ( Request (..)
+ , defaultRequest
+ )
+import Network.Wai.Handler.Warp qualified as Warp
+import Network.Wai.Test
+ ( SRequest (..)
+ , SResponse (..)
+ , runSession
+ , srequest
+ )
+import Network.WebSockets qualified as WebSockets
import Riptide.Playback
( PlaybackEvent (..)
, dryPlaybackBackend
@@ -25,6 +46,7 @@ import Riptide.Server
, handleClientCommand
, newServerState
, readServerConfigFrom
+ , serverApplication
)
import Riptide.Session
( DefinitionBlock (..)
@@ -72,10 +94,11 @@ spec = do
, serverFrontendDir = "frontend/dist"
, serverStateDirectory = ".riptide-state"
, serverSlotCapacity = 16
+ , serverCorsOrigins = ["*"]
}
it
- "reads configured host, port, frontend dir, state dir, and slot capacity"
+ "reads configured host, port, frontend dir, state dir, slot capacity, and CORS origins"
$ do
config <-
readServerConfigFrom $
@@ -85,6 +108,10 @@ spec = do
, ("RIPTIDE_FRONTEND_DIR", "dist")
, ("RIPTIDE_STATE_DIR", "state")
, ("RIPTIDE_SLOT_CAPACITY", "32")
+ ,
+ ( "RIPTIDE_CORS_ORIGINS"
+ , "https://ui.example, http://tailnet.test"
+ )
]
config
@@ -95,6 +122,10 @@ spec = do
, serverFrontendDir = "dist"
, serverStateDirectory = "state"
, serverSlotCapacity = 32
+ , serverCorsOrigins =
+ [ "https://ui.example"
+ , "http://tailnet.test"
+ ]
}
it "reports an invalid port as a recoverable config error" $ do
@@ -218,6 +249,67 @@ spec = do
events `shouldSatisfy` commandFailed (ActivateTrackText trackA textA)
readIORef eventsRef >>= (`shouldBe` 0) . length
+ describe "Riptide.Server CORS" $ do
+ it "answers OPTIONS preflight with CORS headers" $
+ withServer corsSession $ \server _ frontendDir -> do
+ response <-
+ runCorsRequest
+ ["*"]
+ server
+ frontendDir
+ defaultRequest
+ { requestMethod = methodOptions
+ , requestHeaders =
+ [ ("Origin", "https://foreign.example")
+ ,
+ ( "Access-Control-Request-Method"
+ , methodGet
+ )
+ ]
+ }
+
+ statusCode (simpleStatus response) `shouldBe` 204
+ responseHeader "Access-Control-Allow-Origin" response
+ `shouldBe` Just "*"
+ responseHeader "Access-Control-Allow-Methods" response
+ `shouldBe` Just "GET, POST, OPTIONS"
+ responseHeader "Access-Control-Allow-Headers" response
+ `shouldBe` Just "Content-Type"
+ simpleBody response `shouldBe` ""
+
+ it "allows a normal foreign-origin HTTP request by default" $
+ withServer corsSession $ \server _ frontendDir -> do
+ response <-
+ runCorsRequest
+ ["*"]
+ server
+ frontendDir
+ defaultRequest
+ { requestMethod = methodGet
+ , requestHeaders =
+ [("Origin", "https://foreign.example")]
+ }
+
+ responseHeader "Access-Control-Allow-Origin" response
+ `shouldBe` Just "*"
+
+ it "accepts websocket clients with a foreign Origin" $
+ withServer corsSession $ \server _ frontendDir ->
+ Warp.testWithApplication
+ (pure $ serverApplication ["*"] server frontendDir)
+ $ \port -> do
+ rawMessage <-
+ WebSockets.runClientWith
+ "127.0.0.1"
+ port
+ "/ws"
+ WebSockets.defaultConnectionOptions
+ [("Origin", "https://foreign.example")]
+ WebSockets.receiveData
+
+ decode rawMessage
+ `shouldBe` Just (StateSnapshot corsSession)
+
withServer
:: Session
-> (ServerState -> IORef [PlaybackEvent] -> FilePath -> IO a)
@@ -309,6 +401,10 @@ clientSession =
]
}
+corsSession :: Session
+corsSession =
+ emptySession 4
+
findTrack :: TrackId -> Session -> Maybe Track
findTrack ident session =
find ((== ident) . trackId) (sessionTracks session)
@@ -358,3 +454,14 @@ withTempDir =
envLookup :: [(String, String)] -> String -> IO (Maybe String)
envLookup vars name =
pure $ lookup name vars
+
+runCorsRequest
+ :: [String] -> ServerState -> FilePath -> Request -> IO SResponse
+runCorsRequest origins server frontendDir request =
+ runSession
+ (srequest $ SRequest request LazyByteString.empty)
+ (serverApplication origins server frontendDir)
+
+responseHeader :: HeaderName -> SResponse -> Maybe ByteString
+responseHeader name response =
+ lookup name $ simpleHeaders response