Merge Feature/limit vnc console sessions to master (xapi-project#6820)

Merge feature VNC console session limitation
This feature adds two new pool-level controls for VNC console
connections.

1. Connection Limiting
New field: pool.limit_console_sessions (boolean, default: false)
When enabled, only one user can connect to each VM/host console at a
time. Additional connection attempts are rejected with an error message
showing who is currently connected.

How it works:
- Tracks active connections per VM/host using unique connection IDs
- Rejects new connections when limit is enabled and one exists
- Automatically cleans up on disconnect
- WebSocket connections are blocked when limiting is enabled

2. Idle Timeout
New field: pool.vm_console_idle_timeout (seconds, default: 0 = no
timeout)
Automatically disconnects idle console sessions after the specified
time. Separate host.console_idle_timeout field exists for control domain
consoles.

How it works:
- Monitors keyboard and mouse activity via RFB protocol parsing
- Resets timer on user input (KeyEvent, PointerEvent)
- Disconnects when idle timeout exceeded
- Default value of 0 preserves existing behavior (no timeout)

Author: robhoes

ocaml/idl/datamodel_common.ml

@@ -10,7 +10,7 @@ open Datamodel_roles
               to leave a gap for potential hotfixes needing to increment the schema version.*)
 let schema_major_vsn = 5
 
-let schema_minor_vsn = 792
+let schema_minor_vsn = 793
 
 (* Historical schema versions just in case this is useful later *)
 let rio_schema_major_vsn = 5

ocaml/idl/datamodel_lifecycle.ml

@@ -147,6 +147,10 @@ let prototyped_of_field = function
       Some "23.18.0"
   | "VM", "actions__after_softreboot" ->
       Some "23.1.0"
+  | "pool", "vm_console_idle_timeout" ->
+      Some "26.0.0-next"
+  | "pool", "limit_console_sessions" ->
+      Some "26.0.0-next"
   | "pool", "ha_reboot_vm_on_internal_shutdown" ->
       Some "25.16.0"
   | "pool", "license_server" ->

ocaml/idl/datamodel_pool.ml

@@ -2249,6 +2249,19 @@ 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."
+        ; field ~writer_roles:_R_POOL_OP ~qualifier:RW ~lifecycle:[] ~ty:Int
+            ~default_value:(Some (VInt 0L)) "vm_console_idle_timeout"
+            "The maximum time (in seconds) that a VM's console can be idle \
+             before it is automatically disconnected. The default value 0 \
+             means never timeout. This setting applies only to VM consoles; \
+             for host consoles, use the separate parameter \
+             'host.console_idle_timeout'."
         ]
       )
     ()

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 = "d8cb04ccddfd91ca3f0f9074dcf7c219"
+let last_known_schema_hash = "a01358e3ff5f42d5aee162e995d2ec05"
 
 let current_schema_hash : string =
   let open Datamodel_types in

ocaml/libs/http-lib/http_svr.ml

@@ -149,6 +149,10 @@ let response_error_html ?(version = "1.1") s code message hdrs body =
   D.debug "Response %s" (Http.Response.to_string res) ;
   Unixext.really_write_string s (Http.Response.to_wire_string res)
 
+let response_custom_error ?req s error_code reason body =
+  let version = Option.map get_return_version req in
+  response_error_html ?version s error_code reason [] body
+
 let response_unauthorised ?req label s =
   let version = Option.map get_return_version req in
   let body =
@@ -331,7 +335,7 @@ module Server = struct
       x.handlers []
 end
 
-let escape uri =
+let escape str =
   (* from xapi-stdext-std xstringext *)
   let escaped ~rules string =
     let aux h t =
@@ -353,7 +357,7 @@ let escape uri =
       ; ('"', """)
       ; ('&', "&")
       ]
-    uri
+    str
 
 exception Generic_error of string
 

ocaml/libs/http-lib/http_svr.mli

@@ -50,6 +50,9 @@ end
 
 exception Generic_error of string
 
+val escape : string -> string
+(** [escape str] escapes HTML/XML special characters in [str] for safe inclusion in HTML/XML content. *)
+
 type socket
 
 val bind : ?listen_backlog:int -> Unix.sockaddr -> string -> socket
@@ -97,6 +100,9 @@ val response_unauthorised :
 
 val response_forbidden : ?req:Http.Request.t -> Unix.file_descr -> unit
 
+val response_custom_error :
+  ?req:Http.Request.t -> Unix.file_descr -> string -> string -> string -> unit
+
 val response_badrequest : ?req:Http.Request.t -> Unix.file_descr -> unit
 
 val response_internal_error :

ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml

@@ -338,7 +338,8 @@ module CBuf = struct
     in
     let read = Unix.read fd x.buffer next len in
     if read = 0 then x.r_closed <- true ;
-    x.len <- x.len + read
+    x.len <- x.len + read ;
+    (x.buffer, read, next)
 end
 
 exception Process_still_alive
@@ -381,11 +382,21 @@ let with_polly f =
   let finally () = Polly.close polly in
   Xapi_stdext_pervasives.Pervasiveext.finally (fun () -> f polly) finally
 
-let proxy (a : Unix.file_descr) (b : Unix.file_descr) =
+exception Close_proxy
+
+let proxy ?should_close ?(poll_timeout = -1) (a : Unix.file_descr)
+    (b : Unix.file_descr) =
   let size = 64 * 1024 in
   (* [a'] is read from [a] and will be written to [b] *)
   (* [b'] is read from [b] and will be written to [a] *)
   let a' = CBuf.empty size and b' = CBuf.empty size in
+
+  let close_proxy () =
+    Unix.shutdown a Unix.SHUTDOWN_ALL ;
+    Unix.shutdown b Unix.SHUTDOWN_ALL ;
+    raise Close_proxy
+  in
+
   Unix.set_nonblock a ;
   Unix.set_nonblock b ;
   with_polly @@ fun polly ->
@@ -413,13 +424,22 @@ let proxy (a : Unix.file_descr) (b : Unix.file_descr) =
         Polly.upd polly a a_events ;
       if Polly.Events.(b_events <> empty) then
         Polly.upd polly b b_events ;
-      Polly.wait_fold polly 4 (-1) () (fun _polly fd events () ->
+      Polly.wait_fold polly 4 poll_timeout (Bytes.empty, 0, 0)
+        (fun _polly fd events acc ->
           (* Do the writing before the reading *)
           if Polly.Events.(test out events) then
             if a = fd then CBuf.write b' a else CBuf.write a' b ;
           if Polly.Events.(test inp events) then
-            if a = fd then CBuf.read a' a else CBuf.read b' b
-      ) ;
+            if a = fd then (
+              ignore (CBuf.read a' a) ;
+              acc
+            ) else
+              CBuf.read b' b
+          else
+            acc
+      )
+      |> fun data ->
+      Option.iter (fun cb -> if cb data then close_proxy ()) should_close ;
       (* If there's nothing else to read or write then signal the other end *)
       List.iter
         (fun (buf, fd) ->

ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli

@@ -126,7 +126,12 @@ exception Process_still_alive
 
 val kill_and_wait : ?signal:int -> ?timeout:float -> int -> unit
 
-val proxy : Unix.file_descr -> Unix.file_descr -> unit
+val proxy :
+     ?should_close:(bytes * int * int -> bool)
+  -> ?poll_timeout:int
+  -> Unix.file_descr
+  -> Unix.file_descr
+  -> unit
 
 val really_read : Unix.file_descr -> bytes -> int -> int -> unit
 

ocaml/tests/common/test_common.ml

@@ -314,7 +314,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) ?(vm_console_idle_timeout = 0L) () =
   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
@@ -335,7 +336,8 @@ 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
+    ~vm_console_idle_timeout ;
   pool_ref
 
 let default_sm_features =

ocaml/tests/suite_alcotest.ml

@@ -70,5 +70,6 @@ let () =
     @ Test_session.tests
     @ Test_xapi_cmd_result.tests
     @ Test_extauth_plugin_ADwinbind.tests
+    @ Test_rfb_client_msgtype_parser.tests
     @ Test_tracked_user_agents.tests
     )