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,52 @@ 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 VMMap = Map.Make (String)
+
+  let active_connections : int VMMap.t ref = ref VMMap.empty
+
+  let mutex = Mutex.create ()
+
+  let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute
+
+  let drop vm_id =
+    with_lock mutex (fun () ->
+        match VMMap.find_opt vm_id !active_connections with
+        | Some n when n > 1 ->
+            active_connections := VMMap.add vm_id (n - 1) !active_connections
+        | Some _ | None ->
+            active_connections := VMMap.remove vm_id !active_connections
+    )
+
+  (* When the limit is disabled (false), we must still track the connection count for each vm_id.
+     This ensures that if the limit is later enabled (set to true), any existing connections are accounted for,
+     and the limit can be correctly enforced for subsequent connection attempts. *)
+  let try_add vm_id is_limit_enabled =
+    with_lock mutex (fun () ->
+        let count =
+          match VMMap.find_opt vm_id !active_connections with
+          | Some n ->
+              n
+          | None ->
+              0
+        in
+        if is_limit_enabled && count > 0 then (
+          debug
+            "limit_console_sessions is true. Console connection is rejected \
+             for VM %s, active connections: %d"
+            vm_id count ;
+          false
+        ) else (
+          active_connections := VMMap.add vm_id (count + 1) !active_connections ;
+          true
+        )
+    )
+end
+
 let string_of_address = function
   | Port x ->
       "localhost:" ^ string_of_int x
@@ -84,7 +130,7 @@ let address_of_console __context console : address option =
     ) ;
   address_option
 
-let real_proxy __context _ _ vnc_port s =
+let real_proxy' vnc_port s =
   try
     Http_svr.headers s (Http.http_200_ok ()) ;
     let vnc_sock =
@@ -103,7 +149,28 @@ let real_proxy __context _ _ vnc_port s =
     debug "Proxy exited"
   with exn -> debug "error: %s" (ExnHelper.string_of_exn exn)
 
-let ws_proxy __context req protocol address s =
+let real_proxy __context vm _ _ vnc_port s =
+  let vm_id = Ref.string_of vm in
+  let pool = Helpers.get_pool ~__context in
+  let is_limit_enabled =
+    Db.Pool.get_limit_console_sessions ~__context ~self:pool
+  in
+  if not (Connection_limit.try_add vm_id is_limit_enabled) then
+    Http_svr.headers s (Http.http_503_service_unavailable ())
+  else
+    finally (* Ensure we drop the vm connection count if exceptions occur *)
+      (fun () -> real_proxy' vnc_port s)
+      (fun () -> Connection_limit.drop vm_id)
+
+let go_if_no_limit __context s f =
+  let pool = Helpers.get_pool ~__context in
+  if Db.Pool.get_limit_console_sessions ~__context ~self:pool then
+    Http_svr.headers s (Http.http_503_service_unavailable ())
+  else
+    f ()
+
+let ws_proxy __context _ req protocol address s =
+  go_if_no_limit __context s @@ fun () ->
   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"
@@ -240,14 +307,15 @@ let handler proxy_fn (req : Request.t) s _ =
       (* only sessions with 'http/connect_console/host_console' permission *)
       let protocol = Db.Console.get_protocol ~__context ~self:console in
       (* can access dom0 host consoles *)
+      let vm = Db.Console.get_VM ~__context ~self:console in
       rbac_check_for_control_domain __context req console
         Rbac_static.permission_http_connect_console_host_console
           .Db_actions.role_name_label ;
       (* Check VM is actually running locally *)
       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 vm 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 =