feat: add backend host setting and CORS

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;

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,18 +483,19 @@ 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 =
   H.subscribe' \subscriptionId ->
     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

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

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 }

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 ->

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" ]

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) {