Add host.get_ntp_synchronized and host.set_servertime (#6743)

**host.get_ntp_synchronized**:
Simply return true or false by parsing "System clock synchronized" or
"NTP synchronized" from the output of "timedatectl status" like the
following, no matter the NTP being enabled or not.
```
# timedatectl status
               Local time: Wed 2025-11-05 06:10:42 UTC
           Universal time: Wed 2025-11-05 06:10:42 UTC
                 RTC time: Wed 2025-11-05 05:00:11
                Time zone: UTC (UTC, +0000)
System clock synchronized: yes
              NTP service: active
          RTC in local TZ: no
```

**host.set_servertime**:
Use "timedatectl set-time" to set local time on the host in its local
timezone only when NTP is disabled.

Author: minglumlu

ocaml/idl/datamodel_errors.ml

@@ -2065,6 +2065,9 @@ let _ =
   error Api_errors.invalid_ntp_config ["reason"]
     ~doc:"The NTP configuration is invalid." () ;
 
+  error Api_errors.not_allowed_when_ntp_is_enabled ["host"]
+    ~doc:"The operation is not allowed on the host when the NTP is enabled." () ;
+
   message
     (fst Api_messages.ha_pool_overcommitted)
     ~doc:

ocaml/idl/datamodel_host.ml

@@ -2646,6 +2646,33 @@ let list_timezones =
     ~result:(Set String, "The set of available timezones on the host")
     ~allowed_roles:_R_READ_ONLY ()
 
+let get_ntp_synchronized =
+  call ~name:"get_ntp_synchronized" ~lifecycle:[]
+    ~doc:
+      "Returns true if the system clock on the host is synchronized with the \
+       NTP servers."
+    ~params:[(Ref _host, "self", "The host")]
+    ~result:
+      ( Bool
+      , "true if the system clock on the host is synchronized with the NTP \
+         servers."
+      )
+    ~allowed_roles:_R_READ_ONLY ()
+
+let set_servertime =
+  call ~name:"set_servertime" ~lifecycle:[]
+    ~doc:"Set the host's system clock when NTP is disabled."
+    ~params:
+      [
+        (Ref _host, "self", "The host")
+      ; ( DateTime
+        , "value"
+        , "A date/time to be set. When a timezone offset is missing, UTC is \
+           assumed."
+        )
+      ]
+    ~allowed_roles:_R_POOL_OP ()
+
 (** Hosts *)
 let t =
   create_obj ~in_db:true
@@ -2800,6 +2827,8 @@ let t =
       ; get_ntp_servers_status
       ; set_timezone
       ; list_timezones
+      ; get_ntp_synchronized
+      ; set_servertime
       ]
     ~contents:
       ([

ocaml/libs/clock/date.ml

@@ -150,6 +150,8 @@ let strip_tz tz t =
   in
   {t; tz= None}
 
+let to_utc {t; tz} = Option.bind tz (fun _ -> Some {t; tz= utc})
+
 let _localtime_string tz t = strip_tz tz t |> to_rfc3339
 
 let localtime () =

ocaml/libs/clock/date.mli

@@ -86,3 +86,7 @@ val is_later : than:t -> t -> bool
 val diff : t -> t -> Ptime.Span.t
 (** [diff a b] returns the span of time corresponding to [a - b]. When [than]
     or [b] lack a timezone, UTC is assumed. *)
+
+val to_utc : t -> t option
+(** [to_utc a] returns [Some b] where [b] is equivalent to [a] but in UTC, if
+    [a] has a timezone offset [Some tz]. Otherwise, the return is [None]. *)

ocaml/xapi-consts/api_errors.ml

@@ -1440,3 +1440,6 @@ let tls_verification_not_enabled_in_pool =
 let sysprep = add_error "SYSPREP"
 
 let invalid_ntp_config = add_error "INVALID_NTP_CONFIG"
+
+let not_allowed_when_ntp_is_enabled =
+  add_error "NOT_ALLOWED_WHEN_NTP_IS_ENABLED"

ocaml/xapi/message_forwarding.ml

@@ -4184,6 +4184,26 @@ functor
         let local_fn = Local.Host.list_timezones ~self in
         let remote_fn = Client.Host.list_timezones ~self in
         do_op_on ~local_fn ~__context ~host:self ~remote_fn
+
+      let get_ntp_synchronized ~__context ~self =
+        info "Host.get_ntp_synchronized: host = '%s'" (host_uuid ~__context self) ;
+        let local_fn = Local.Host.get_ntp_synchronized ~self in
+        let remote_fn = Client.Host.get_ntp_synchronized ~self in
+        do_op_on ~local_fn ~__context ~host:self ~remote_fn
+
+      let set_servertime ~__context ~self ~value =
+        info "Host.set_servertime : host = '%s'; value = '%s'"
+          (host_uuid ~__context self)
+          (Clock.Date.to_rfc3339 value) ;
+        if Db.Host.get_ntp_enabled ~__context ~self then
+          raise
+            (Api_errors.Server_error
+               (Api_errors.not_allowed_when_ntp_is_enabled, [Ref.string_of self])
+            )
+        else
+          let local_fn = Local.Host.set_servertime ~self ~value in
+          let remote_fn = Client.Host.set_servertime ~self ~value in
+          do_op_on ~local_fn ~__context ~host:self ~remote_fn
     end
 
     module Host_crashdump = struct

ocaml/xapi/xapi_host.ml

@@ -3562,8 +3562,12 @@ let get_ntp_servers_status ~__context ~self:_ =
   else
     []
 
+(* Prevent concurrent time/timezeone operations from interleaving. *)
+let time_m = Mutex.create ()
+
 let set_timezone ~__context ~self ~value =
   try
+    with_lock time_m @@ fun () ->
     let _ =
       Helpers.call_script !Xapi_globs.timedatectl ["set-timezone"; value]
     in
@@ -3581,3 +3585,34 @@ let list_timezones ~__context ~self:_ =
     Helpers.call_script !Xapi_globs.timedatectl ["list-timezones"]
     |> Astring.String.cuts ~empty:false ~sep:"\n"
   with e -> Helpers.internal_error "%s" (ExnHelper.string_of_exn e)
+
+let get_ntp_synchronized ~__context ~self:_ =
+  match Xapi_host_ntp.is_synchronized () with
+  | Ok r ->
+      r
+  | Error msg ->
+      Helpers.internal_error "%s" msg
+
+let set_servertime ~__context ~self ~value =
+  let f = Helpers.call_script !Xapi_globs.timedatectl in
+  with_lock time_m @@ fun () ->
+  let tz = Db.Host.get_timezone ~__context ~self in
+  let not_utc = tz <> "UTC" in
+  try
+    (* The [value] stores only a naive date/time and a fixed timezone offset.
+       Convert it to UTC to avoid ambiguities caused by additional timezone
+       details, such as Daylight Saving Time (DST) rules or historical changes. *)
+    match Date.to_utc value |> Option.map Date.to_ptime with
+    | Some t ->
+        let (y, mon, d), ((h, min, s), _) = Ptime.to_date_time t in
+        let naive_in_utc =
+          Printf.sprintf "%04i-%02i-%02i %02i:%02i:%02i" y mon d h min s
+        in
+        if not_utc then (f ["set-timezone"; "UTC"] : string) |> ignore ;
+        (f ["set-time"; naive_in_utc] : string) |> ignore ;
+        if not_utc then (f ["set-timezone"; tz] : string) |> ignore ;
+        debug "%s: %s" __FUNCTION__ (f ["status"])
+    | None ->
+        raise (Invalid_argument "Missing timezone offset in value")
+  with e ->
+    Helpers.internal_error "%s: %s" __FUNCTION__ (ExnHelper.string_of_exn e)

ocaml/xapi/xapi_host.mli

@@ -632,3 +632,8 @@ val set_timezone :
   __context:Context.t -> self:API.ref_host -> value:string -> unit
 
 val list_timezones : __context:Context.t -> self:API.ref_host -> string list
+
+val get_ntp_synchronized : __context:Context.t -> self:API.ref_host -> bool
+
+val set_servertime :
+  __context:Context.t -> self:API.ref_host -> value:Clock.Date.t -> unit

ocaml/xapi/xapi_host_ntp.ml

@@ -175,3 +175,12 @@ let promote_legacy_default_servers () =
     set_servers_in_conf defaults ;
     restart_ntp_service ()
   )
+
+let is_synchronized () =
+  let patterns = ["System clock synchronized: yes"; "NTP synchronized: yes"] in
+  try
+    Helpers.call_script !Xapi_globs.timedatectl ["status"]
+    |> String.split_on_char '\n'
+    |> List.exists ((Fun.flip List.mem) patterns)
+    |> Result.ok
+  with e -> Error (ExnHelper.string_of_exn e)

ocaml/xapi/xapi_host_ntp.mli

@@ -35,3 +35,5 @@ val get_servers_from_conf : unit -> string list
 val is_ntp_dhcp_enabled : unit -> bool
 
 val get_servers_status : unit -> (string * string) list
+
+val is_synchronized : unit -> (bool, string) Result.t