CP-53478: Implement SSH-related APIs for Dom0 SSH control (#6394)

Implemented XAPI APIs:
  - `set_ssh_enabled_timeout`
  - `set_console_idle_timeout`

These APIs allow XAPI to configure timeouts for the SSH service and idle
console sessions from both host and pool level.

Updated `records.ml` to support `host-param-set/get/list` and
`pool-param-set/get/list` for SSH-related fields.

Author: minglumlu

ocaml/idl/datamodel_errors.ml

@@ -2040,6 +2040,12 @@ let _ =
   error Api_errors.disable_ssh_partially_failed ["hosts"]
     ~doc:"Some of hosts failed to disable SSH access." () ;
 
+  error Api_errors.set_ssh_timeout_partially_failed ["hosts"]
+    ~doc:"Some hosts failed to set SSH timeout." () ;
+
+  error Api_errors.set_console_timeout_partially_failed ["hosts"]
+    ~doc:"Some hosts failed to set console timeout." () ;
+
   error Api_errors.host_driver_no_hardware ["driver variant"]
     ~doc:"No hardware present for this host driver variant" () ;
 

ocaml/xapi-cli-server/records.ml

@@ -20,6 +20,8 @@ let nullref = Ref.string_of Ref.null
 
 let nid = "<not in database>"
 
+let inconsistent = "<inconsistent>"
+
 let unknown_time = "<unknown time>"
 
 let string_of_float f = Printf.sprintf "%.3f" f
@@ -204,6 +206,37 @@ let get_pbds_host rpc session_id pbds =
 let get_sr_host rpc session_id record =
   get_pbds_host rpc session_id record.API.sR_PBDs
 
+(** Get consistent field from all hosts, or return a default value if the field
+    is not the same on all hosts. *)
+let get_consistent_field_or_default ~rpc ~session_id ~getter ~transform ~default
+    =
+  match Client.Host.get_all ~rpc ~session_id with
+  | [] ->
+      default
+  | hosts -> (
+      let result =
+        List.fold_left
+          (fun acc host ->
+            match acc with
+            | `Inconsistent ->
+                `Inconsistent
+            | `NotSet ->
+                `Value (getter ~rpc ~session_id ~self:host |> transform)
+            | `Value v ->
+                let current = getter ~rpc ~session_id ~self:host |> transform in
+                if v = current then `Value v else `Inconsistent
+          )
+          `NotSet hosts
+      in
+      match result with
+      | `Value v ->
+          v
+      | `Inconsistent ->
+          default
+      | `NotSet ->
+          default
+    )
+
 let bond_record rpc session_id bond =
   let _ref = ref bond in
   let empty_record =
@@ -1506,6 +1539,42 @@ let pool_record rpc session_id pool =
           )
           ~get_map:(fun () -> (x ()).API.pool_license_server)
           ()
+      ; make_field ~name:"ssh-enabled"
+          ~get:(fun () ->
+            get_consistent_field_or_default ~rpc ~session_id
+              ~getter:Client.Host.get_ssh_enabled ~transform:string_of_bool
+              ~default:inconsistent
+          )
+          ()
+      ; make_field ~name:"ssh-enabled-timeout"
+          ~get:(fun () ->
+            get_consistent_field_or_default ~rpc ~session_id
+              ~getter:Client.Host.get_ssh_enabled_timeout
+              ~transform:Int64.to_string ~default:inconsistent
+          )
+          ~set:(fun value ->
+            Client.Pool.set_ssh_enabled_timeout ~rpc ~session_id ~self:pool
+              ~value:(safe_i64_of_string "ssh-enabled-timeout" value)
+          )
+          ()
+      ; make_field ~name:"ssh-expiry"
+          ~get:(fun () ->
+            get_consistent_field_or_default ~rpc ~session_id
+              ~getter:Client.Host.get_ssh_expiry ~transform:Date.to_rfc3339
+              ~default:inconsistent
+          )
+          ()
+      ; make_field ~name:"console-idle-timeout"
+          ~get:(fun () ->
+            get_consistent_field_or_default ~rpc ~session_id
+              ~getter:Client.Host.get_console_idle_timeout
+              ~transform:Int64.to_string ~default:inconsistent
+          )
+          ~set:(fun value ->
+            Client.Pool.set_console_idle_timeout ~rpc ~session_id ~self:pool
+              ~value:(safe_i64_of_string "console-idle-timeout" value)
+          )
+          ()
       ]
   }
 
@@ -3265,6 +3334,26 @@ let host_record rpc session_id host =
       ; make_field ~name:"last-update-hash"
           ~get:(fun () -> (x ()).API.host_last_update_hash)
           ()
+      ; make_field ~name:"ssh-enabled"
+          ~get:(fun () -> string_of_bool (x ()).API.host_ssh_enabled)
+          ()
+      ; make_field ~name:"ssh-enabled-timeout"
+          ~get:(fun () -> Int64.to_string (x ()).API.host_ssh_enabled_timeout)
+          ~set:(fun value ->
+            Client.Host.set_ssh_enabled_timeout ~rpc ~session_id ~self:host
+              ~value:(safe_i64_of_string "ssh-enabled-timeout" value)
+          )
+          ()
+      ; make_field ~name:"ssh-expiry"
+          ~get:(fun () -> Date.to_rfc3339 (x ()).API.host_ssh_expiry)
+          ()
+      ; make_field ~name:"console-idle-timeout"
+          ~get:(fun () -> Int64.to_string (x ()).API.host_console_idle_timeout)
+          ~set:(fun value ->
+            Client.Host.set_console_idle_timeout ~rpc ~session_id ~self:host
+              ~value:(safe_i64_of_string "console-idle-timeout" value)
+          )
+          ()
       ]
   }
 

ocaml/xapi-consts/api_errors.ml

@@ -1420,6 +1420,12 @@ let enable_ssh_partially_failed = add_error "ENABLE_SSH_PARTIALLY_FAILED"
 
 let disable_ssh_partially_failed = add_error "DISABLE_SSH_PARTIALLY_FAILED"
 
+let set_ssh_timeout_partially_failed =
+  add_error "SET_SSH_TIMEOUT_PARTIALLY_FAILED"
+
+let set_console_timeout_partially_failed =
+  add_error "SET_CONSOLE_TIMEOUT_PARTIALLY_FAILED"
+
 let host_driver_no_hardware = add_error "HOST_DRIVER_NO_HARDWARE"
 
 let tls_verification_not_enabled_in_pool =

ocaml/xapi/xapi_globs.ml

@@ -1287,6 +1287,12 @@ let gpumon_stop_timeout = ref 10.0
 
 let reboot_required_hfxs = ref "/run/reboot-required.hfxs"
 
+let console_timeout_profile_path = ref "/etc/profile.d/console_timeout.sh"
+
+let job_for_disable_ssh = ref "Disable SSH"
+
+let ssh_service = ref "sshd"
+
 (* Fingerprint of default patch key *)
 let citrix_patch_key =
   "NERDNTUzMDMwRUMwNDFFNDI4N0M4OEVCRUFEMzlGOTJEOEE5REUyNg=="

ocaml/xapi/xapi_host.ml

@@ -3114,26 +3114,134 @@ let emergency_clear_mandatory_guidance ~__context =
      ) ;
   Db.Host.set_pending_guidances ~__context ~self ~value:[]
 
+let disable_ssh_internal ~__context ~self =
+  try
+    debug "Disabling SSH for host %s" (Helpers.get_localhost_uuid ()) ;
+    Xapi_systemctl.disable ~wait_until_success:false !Xapi_globs.ssh_service ;
+    Xapi_systemctl.stop ~wait_until_success:false !Xapi_globs.ssh_service ;
+    Db.Host.set_ssh_enabled ~__context ~self ~value:false
+  with e ->
+    error "Failed to disable SSH for host %s: %s" (Ref.string_of self)
+      (Printexc.to_string e) ;
+    Helpers.internal_error "Failed to disable SSH: %s" (Printexc.to_string e)
+
+let schedule_disable_ssh_job ~__context ~self ~timeout =
+  let host_uuid = Helpers.get_localhost_uuid () in
+  let expiry_time =
+    match
+      Ptime.add_span (Ptime_clock.now ())
+        (Ptime.Span.of_int_s (Int64.to_int timeout))
+    with
+    | None ->
+        error "Invalid SSH timeout: %Ld" timeout ;
+        raise
+          (Api_errors.Server_error
+             ( Api_errors.invalid_value
+             , ["ssh_enabled_timeout"; Int64.to_string timeout]
+             )
+          )
+    | Some t ->
+        Ptime.to_float_s t |> Date.of_unix_time
+  in
+
+  debug "Scheduling SSH disable job for host %s with timeout %Ld seconds"
+    host_uuid timeout ;
+
+  (* Remove any existing job first *)
+  Xapi_stdext_threads_scheduler.Scheduler.remove_from_queue
+    !Xapi_globs.job_for_disable_ssh ;
+
+  Xapi_stdext_threads_scheduler.Scheduler.add_to_queue
+    !Xapi_globs.job_for_disable_ssh
+    Xapi_stdext_threads_scheduler.Scheduler.OneShot (Int64.to_float timeout)
+    (fun () -> disable_ssh_internal ~__context ~self
+  ) ;
+
+  Db.Host.set_ssh_expiry ~__context ~self ~value:expiry_time
+
 let enable_ssh ~__context ~self =
   try
-    Xapi_systemctl.enable ~wait_until_success:false "sshd" ;
-    Xapi_systemctl.start ~wait_until_success:false "sshd"
-  with _ ->
-    raise
-      (Api_errors.Server_error
-         (Api_errors.enable_ssh_failed, [Ref.string_of self])
-      )
+    debug "Enabling SSH for host %s" (Helpers.get_localhost_uuid ()) ;
+
+    Xapi_systemctl.enable ~wait_until_success:false !Xapi_globs.ssh_service ;
+    Xapi_systemctl.start ~wait_until_success:false !Xapi_globs.ssh_service ;
+
+    let timeout = Db.Host.get_ssh_enabled_timeout ~__context ~self in
+    ( match timeout with
+    | 0L ->
+        Xapi_stdext_threads_scheduler.Scheduler.remove_from_queue
+          !Xapi_globs.job_for_disable_ssh
+    | t ->
+        schedule_disable_ssh_job ~__context ~self ~timeout:t
+    ) ;
+
+    Db.Host.set_ssh_enabled ~__context ~self ~value:true
+  with e ->
+    error "Failed to enable SSH on host %s: %s" (Ref.string_of self)
+      (Printexc.to_string e) ;
+    Helpers.internal_error "Failed to enable SSH: %s" (Printexc.to_string e)
 
 let disable_ssh ~__context ~self =
+  Xapi_stdext_threads_scheduler.Scheduler.remove_from_queue
+    !Xapi_globs.job_for_disable_ssh ;
+  disable_ssh_internal ~__context ~self ;
+  Db.Host.set_ssh_expiry ~__context ~self ~value:(Date.now ())
+
+let set_ssh_enabled_timeout ~__context ~self ~value =
+  let validate_timeout value =
+    (* the max timeout is two days: 172800L = 2*24*60*60 *)
+    if value < 0L || value > 172800L then
+      raise
+        (Api_errors.Server_error
+           ( Api_errors.invalid_value
+           , ["ssh_enabled_timeout"; Int64.to_string value]
+           )
+        )
+  in
+  validate_timeout value ;
+  debug "Setting SSH timeout for host %s to %Ld seconds"
+    (Db.Host.get_uuid ~__context ~self)
+    value ;
+  Db.Host.set_ssh_enabled_timeout ~__context ~self ~value ;
+  if Db.Host.get_ssh_enabled ~__context ~self then
+    match value with
+    | 0L ->
+        Xapi_stdext_threads_scheduler.Scheduler.remove_from_queue
+          !Xapi_globs.job_for_disable_ssh ;
+        Db.Host.set_ssh_expiry ~__context ~self ~value:Date.epoch
+    | t ->
+        schedule_disable_ssh_job ~__context ~self ~timeout:t
+
+let set_console_idle_timeout ~__context ~self ~value =
+  let assert_timeout_valid timeout =
+    if timeout < 0L then
+      raise
+        (Api_errors.Server_error
+           ( Api_errors.invalid_value
+           , ["console_timeout"; Int64.to_string timeout]
+           )
+        )
+  in
+
+  assert_timeout_valid value ;
   try
-    Xapi_systemctl.disable ~wait_until_success:false "sshd" ;
-    Xapi_systemctl.stop ~wait_until_success:false "sshd"
-  with _ ->
-    raise
-      (Api_errors.Server_error
-         (Api_errors.disable_ssh_failed, [Ref.string_of self])
-      )
+    let content =
+      match value with
+      | 0L ->
+          "# Console timeout is disabled\n"
+      | timeout ->
+          Printf.sprintf "# Console timeout configuration\nexport TMOUT=%Ld\n"
+            timeout
+    in
 
-let set_ssh_enabled_timeout ~__context ~self:_ ~value:_ = ()
+    Unixext.atomic_write_to_file !Xapi_globs.console_timeout_profile_path 0o0644
+      (fun fd ->
+        Unix.write fd (Bytes.of_string content) 0 (String.length content)
+        |> ignore
+    ) ;
 
-let set_console_idle_timeout ~__context ~self:_ ~value:_ = ()
+    Db.Host.set_console_idle_timeout ~__context ~self ~value
+  with e ->
+    error "Failed to configure console timeout: %s" (Printexc.to_string e) ;
+    Helpers.internal_error "Failed to set console timeout: %Ld: %s" value
+      (Printexc.to_string e)

ocaml/xapi/xapi_pool.ml

@@ -4056,12 +4056,26 @@ module Ssh = struct
   let disable ~__context ~self:_ =
     operate ~__context ~action:Client.Host.disable_ssh
       ~error:Api_errors.disable_ssh_partially_failed
+
+  let set_enabled_timeout ~__context ~self:_ ~value =
+    operate ~__context
+      ~action:(fun ~rpc ~session_id ~self ->
+        Client.Host.set_ssh_enabled_timeout ~rpc ~session_id ~self ~value
+      )
+      ~error:Api_errors.set_ssh_timeout_partially_failed
+
+  let set_console_timeout ~__context ~self:_ ~value =
+    operate ~__context
+      ~action:(fun ~rpc ~session_id ~self ->
+        Client.Host.set_console_idle_timeout ~rpc ~session_id ~self ~value
+      )
+      ~error:Api_errors.set_console_timeout_partially_failed
 end
 
 let enable_ssh = Ssh.enable
 
 let disable_ssh = Ssh.disable
 
-let set_ssh_enabled_timeout ~__context ~self:_ ~value:_ = ()
+let set_ssh_enabled_timeout = Ssh.set_enabled_timeout
 
-let set_console_idle_timeout ~__context ~self:_ ~value:_ = ()
+let set_console_idle_timeout = Ssh.set_console_timeout