Add pool-level field to limit VNC console access to one session per VM/host

ocaml/idl/datamodel_lifecycle.ml

@@ -137,6 +137,8 @@ let prototyped_of_field = function
       Some "23.18.0"
   | "VM", "actions__after_softreboot" ->
       Some "23.1.0"
+  | "pool", "limit_console_sessions" ->
+      Some "25.30.0-next"
   | "pool", "ha_reboot_vm_on_internal_shutdown" ->
       Some "25.16.0"
   | "pool", "license_server" ->

ocaml/idl/datamodel_pool.ml

@@ -2250,6 +2250,12 @@ let t =
             "Indicates whether an HA-protected VM that is shut down from \
              inside (not through the API) should be automatically rebooted \
              when HA is enabled"
+        ; field ~writer_roles:_R_POOL_OP ~qualifier:RW ~lifecycle:[] ~ty:Bool
+            ~default_value:(Some (VBool false)) "limit_console_sessions"
+            "When true, only one console connection per VM/host in the pool is \
+             accepted. Otherwise every connection for a VM/host's console is \
+             accepted. Note: when true, connection attempts via websocket will \
+             be rejected."
         ]
       )
     ()

ocaml/idl/schematest.ml

@@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex
 (* BEWARE: if this changes, check that schema has been bumped accordingly in
    ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *)
 
-let last_known_schema_hash = "7586cb039918e573594fc358e90b0f04"
+let last_known_schema_hash = "cf1c1e26b4288dd53cf6da5a4d6ad13c"
 
 let current_schema_hash : string =
   let open Datamodel_types in

ocaml/tests/common/test_common.ml

@@ -305,7 +305,8 @@ let make_pool ~__context ~master ?(name_label = "") ?(name_description = "")
     ?(last_update_sync = API.Date.epoch) ?(update_sync_frequency = `daily)
     ?(update_sync_day = 0L) ?(update_sync_enabled = false)
     ?(recommendations = []) ?(license_server = [])
-    ?(ha_reboot_vm_on_internal_shutdown = true) () =
+    ?(ha_reboot_vm_on_internal_shutdown = true)
+    ?(limit_console_sessions = false) () =
   let pool_ref = Ref.make () in
   Db.Pool.create ~__context ~ref:pool_ref ~uuid:(make_uuid ()) ~name_label
     ~name_description ~master ~default_SR ~suspend_image_SR ~crash_dump_SR
@@ -326,7 +327,7 @@ let make_pool ~__context ~master ?(name_label = "") ?(name_description = "")
     ~ext_auth_cache_enabled:false ~ext_auth_cache_size:50L
     ~ext_auth_cache_expiry:300L ~update_sync_frequency ~update_sync_day
     ~update_sync_enabled ~recommendations ~license_server
-    ~ha_reboot_vm_on_internal_shutdown ;
+    ~ha_reboot_vm_on_internal_shutdown ~limit_console_sessions ;
   pool_ref
 
 let default_sm_features =

ocaml/xapi-cli-server/records.ml

@@ -1595,6 +1595,13 @@ let pool_record rpc session_id pool =
               ~value:(safe_bool_of_string "ssh-auto-mode" value)
           )
           ()
+      ; make_field ~name:"limit-console-sessions"
+          ~get:(fun () -> string_of_bool (x ()).API.pool_limit_console_sessions)
+          ~set:(fun x ->
+            Client.Pool.set_limit_console_sessions ~rpc ~session_id ~self:pool
+              ~value:(safe_bool_of_string "limit-console-sessions" x)
+          )
+          ()
       ]
   }
 

ocaml/xapi/console.ml

@@ -34,6 +34,51 @@ type address =
 
 (* console is listening on a Unix domain socket *)
 
+(* This module limits VNC console sessions to at most one per VM/host.
+   Depending on configuration, either unlimited connections are allowed,
+   or only a single active connection per VM/host is allowed. *)
+module Connection_limit = struct
+  module VMSet = Set.Make (String)
+
+  let active_connections : VMSet.t ref = ref VMSet.empty
+
+  let mutex = Mutex.create ()
+
+  let add vm_id =
+    Mutex.lock mutex ;
+    active_connections := VMSet.add vm_id !active_connections ;
+    Mutex.unlock mutex
+
+  let remove vm_id =
+    Mutex.lock mutex ;
+    active_connections := VMSet.remove vm_id !active_connections ;
+    Mutex.unlock mutex
+
+  let exists vm_id =
+    Mutex.lock mutex ;
+    let present = VMSet.mem vm_id !active_connections in
+    Mutex.unlock mutex ; present
+
+  let can_add vm_id limit_console_sessions =
+    if not limit_console_sessions then
+      true
+    else
+      not (exists vm_id)
+end
+
+let connection_limit_reached __context vm_id =
+  let pool = Helpers.get_pool ~__context in
+  let limit_console_sessions =
+    Db.Pool.get_limit_console_sessions ~__context ~self:pool
+  in
+  if not (Connection_limit.can_add vm_id limit_console_sessions) then (
+    debug
+      "Console session limit reached: only one active session allowed for VM %s"
+      vm_id ;
+    true
+  ) else
+    false
+
 let string_of_address = function
   | Port x ->
       "localhost:" ^ string_of_int x
@@ -84,72 +129,88 @@ let address_of_console __context console : address option =
     ) ;
   address_option
 
-let real_proxy __context _ _ vnc_port s =
+let real_proxy __context console _ _ vnc_port s =
   try
-    Http_svr.headers s (Http.http_200_ok ()) ;
-    let vnc_sock =
-      match vnc_port with
-      | Port x ->
-          Unixext.open_connection_fd "127.0.0.1" x
-      | Path x ->
-          Unixext.open_connection_unix_fd x
-    in
-    (* Unixext.proxy closes fds itself so we must dup here *)
-    let s' = Unix.dup s in
-    debug "Connected; running proxy (between fds: %d and %d)"
-      (Unixext.int_of_file_descr vnc_sock)
-      (Unixext.int_of_file_descr s') ;
-    Unixext.proxy vnc_sock s' ;
-    debug "Proxy exited"
+    let vm = Db.Console.get_VM ~__context ~self:console in
+    let vm_id = Ref.string_of vm in
+    if connection_limit_reached __context vm_id then
+      Http_svr.headers s (Http.http_503_service_unavailable ())
+    else (
+      Http_svr.headers s (Http.http_200_ok ()) ;
+      let vnc_sock =
+        match vnc_port with
+        | Port x ->
+            Unixext.open_connection_fd "127.0.0.1" x
+        | Path x ->
+            Unixext.open_connection_unix_fd x
+      in
+      (* Unixext.proxy closes fds itself so we must dup here *)
+      let s' = Unix.dup s in
+      debug "Connected; running proxy (between fds: %d and %d)"
+        (Unixext.int_of_file_descr vnc_sock)
+        (Unixext.int_of_file_descr s') ;
+      Connection_limit.add vm_id ;
+      Unixext.proxy vnc_sock s' ;
+      Connection_limit.remove vm_id ;
+      debug "Proxy exited"
+    )
   with exn -> debug "error: %s" (ExnHelper.string_of_exn exn)
 
-let ws_proxy __context req protocol address s =
-  let addr = match address with Port p -> string_of_int p | Path p -> p in
-  let protocol =
-    match protocol with `rfb -> "rfb" | `vt100 -> "vt100" | `rdp -> "rdp"
-  in
-  let real_path = Filename.concat "/var/lib/xcp" "websockproxy" in
-  let sock =
-    try Some (Fecomms.open_unix_domain_sock_client real_path)
-    with e ->
-      debug "Error connecting to wsproxy (%s)" (Printexc.to_string e) ;
-      Http_svr.headers s (Http.http_501_method_not_implemented ()) ;
-      None
+let ws_proxy __context _ req protocol address s =
+  let pool = Helpers.get_pool ~__context in
+  let limit_console_sessions =
+    Db.Pool.get_limit_console_sessions ~__context ~self:pool
   in
-  (* Ensure we always close the socket *)
-  finally
-    (fun () ->
-      let upgrade_successful =
-        Option.map
-          (fun sock ->
-            try
-              let result = (sock, Some (Ws_helpers.upgrade req s)) in
-              result
-            with _ -> (sock, None)
-          )
-          sock
-      in
-      Option.iter
-        (function
-          | sock, Some ty ->
-              let wsprotocol =
-                match ty with
-                | Ws_helpers.Hixie76 ->
-                    "hixie76"
-                | Ws_helpers.Hybi10 ->
-                    "hybi10"
-              in
-              let message =
-                Printf.sprintf "%s:%s:%s" wsprotocol protocol addr
-              in
-              let len = String.length message in
-              ignore (Unixext.send_fd_substring sock message 0 len [] s)
-          | _, None ->
-              Http_svr.headers s (Http.http_501_method_not_implemented ())
-          )
-        upgrade_successful
-    )
-    (fun () -> Option.iter (fun sock -> Unix.close sock) sock)
+  (* Disable connection via websocket if the limit is set *)
+  if limit_console_sessions = true then
+    Http_svr.headers s (Http.http_503_service_unavailable ())
+  else
+    let addr = match address with Port p -> string_of_int p | Path p -> p in
+    let protocol =
+      match protocol with `rfb -> "rfb" | `vt100 -> "vt100" | `rdp -> "rdp"
+    in
+    let real_path = Filename.concat "/var/lib/xcp" "websockproxy" in
+    let sock =
+      try Some (Fecomms.open_unix_domain_sock_client real_path)
+      with e ->
+        debug "Error connecting to wsproxy (%s)" (Printexc.to_string e) ;
+        Http_svr.headers s (Http.http_501_method_not_implemented ()) ;
+        None
+    in
+    (* Ensure we always close the socket *)
+    finally
+      (fun () ->
+        let upgrade_successful =
+          Option.map
+            (fun sock ->
+              try
+                let result = (sock, Some (Ws_helpers.upgrade req s)) in
+                result
+              with _ -> (sock, None)
+            )
+            sock
+        in
+        Option.iter
+          (function
+            | sock, Some ty ->
+                let wsprotocol =
+                  match ty with
+                  | Ws_helpers.Hixie76 ->
+                      "hixie76"
+                  | Ws_helpers.Hybi10 ->
+                      "hybi10"
+                in
+                let message =
+                  Printf.sprintf "%s:%s:%s" wsprotocol protocol addr
+                in
+                let len = String.length message in
+                ignore (Unixext.send_fd_substring sock message 0 len [] s)
+            | _, None ->
+                Http_svr.headers s (Http.http_501_method_not_implemented ())
+            )
+          upgrade_successful
+      )
+      (fun () -> Option.iter (fun sock -> Unix.close sock) sock)
 
 let default_console_of_vm ~__context ~self =
   try
@@ -247,7 +308,7 @@ let handler proxy_fn (req : Request.t) s _ =
       check_vm_is_running_here __context console ;
       match address_of_console __context console with
       | Some vnc_port ->
-          proxy_fn __context req protocol vnc_port s
+          proxy_fn __context console req protocol vnc_port s
       | None ->
           Http_svr.headers s (Http.http_404_missing ())
   )

ocaml/xapi/dbsync_master.ml

@@ -55,6 +55,7 @@ let create_pool_record ~__context =
       ~ext_auth_max_threads:1L ~ext_auth_cache_enabled:false
       ~ext_auth_cache_size:50L ~ext_auth_cache_expiry:300L ~recommendations:[]
       ~license_server:[] ~ha_reboot_vm_on_internal_shutdown:true
+      ~limit_console_sessions:false
 
 let set_master_ip ~__context =
   let ip =