CP-308855: host.set_servertime

Signed-off-by: Ming Lu <ming.lu@cloud.com>

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

@@ -2659,6 +2659,20 @@ let get_ntp_synchronized =
       )
     ~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
@@ -2814,6 +2828,7 @@ let t =
       ; 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

@@ -4190,6 +4190,20 @@ functor
         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
@@ -3588,3 +3592,27 @@ let get_ntp_synchronized ~__context ~self:_ =
       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

@@ -634,3 +634,6 @@ val set_timezone :
 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