Add host.get_ntp_synchronized and host.set_server_localtime

ocaml/idl/datamodel_errors.ml

@@ -2065,6 +2065,12 @@ 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." () ;
+
+  error Api_errors.not_allowed_tz_in_localtime []
+    ~doc:"The timezone is not allowed in localtime." () ;
+
   message
     (fst Api_messages.ha_pool_overcommitted)
     ~doc:

ocaml/idl/datamodel_host.ml

@@ -2627,6 +2627,34 @@ let get_ntp_servers_status =
       )
     ~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_server_localtime =
+  call ~name:"set_server_localtime" ~lifecycle:[]
+    ~doc:
+      "Set the host's system clock in its local timezone when NTP is disabled."
+    ~params:
+      [
+        (Ref _host, "self", "The host")
+      ; ( DateTime
+        , "value"
+        , "A datetime without timezone information. If UTC is specified, the \
+           timezone will be ignored."
+        )
+      ]
+    ~allowed_roles:_R_POOL_OP ()
+
 (** Hosts *)
 let t =
   create_obj ~in_db:true
@@ -2779,6 +2807,8 @@ let t =
       ; disable_ntp
       ; enable_ntp
       ; get_ntp_servers_status
+      ; get_ntp_synchronized
+      ; set_server_localtime
       ]
     ~contents:
       ([

ocaml/libs/clock/date.mli

@@ -21,7 +21,9 @@
     datetime string. This timezone is determined when creating a value and
     cannot be changed. For timestamps created from datetime strings, the
     timezone is maintained. For all other values UTC is used. *)
-type t
+type tz = int option
+
+type t = {t: Ptime.t; tz: tz}
 
 (** Conversions *)
 

ocaml/xapi-consts/api_errors.ml

@@ -1440,3 +1440,8 @@ 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"
+
+let not_allowed_tz_in_localtime = add_error "NOT_ALLOWED_TZ_IN_LOCALTIME"

ocaml/xapi/message_forwarding.ml

@@ -4170,6 +4170,26 @@ functor
         let local_fn = Local.Host.get_ntp_servers_status ~self in
         let remote_fn = Client.Host.get_ntp_servers_status ~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_server_localtime ~__context ~self ~value =
+        info "Host.set_server_localtime: 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_server_localtime ~self ~value in
+          let remote_fn = Client.Host.set_server_localtime ~self ~value in
+          do_op_on ~local_fn ~__context ~host:self ~remote_fn
     end
 
     module Host_crashdump = struct

ocaml/xapi/xapi_globs.ml

@@ -812,6 +812,8 @@ let ntp_dhcp_dir = ref "/run/chrony-dhcp"
 
 let ntp_client_path = ref "/usr/bin/chronyc"
 
+let timedatectl = ref "/usr/bin/timedatectl"
+
 let udhcpd_skel = ref (Filename.concat "/etc/xensource" "udhcpd.skel")
 
 let udhcpd_leases_db = ref "/var/lib/xcp/dhcp-leases.db"
@@ -1904,6 +1906,11 @@ let other_options =
     , (fun () -> !ntp_client_path)
     , "Path to the ntp client binary"
     )
+  ; ( "timedatectl"
+    , Arg.Set_string timedatectl
+    , (fun () -> !timedatectl)
+    , "Path to the timedatectl executable"
+    )
   ; gen_list_option "legacy-default-ntp-servers"
       "space-separated list of legacy default NTP servers"
       (fun s -> s)

ocaml/xapi/xapi_host.ml

@@ -3555,3 +3555,28 @@ let get_ntp_servers_status ~__context ~self:_ =
     Xapi_host_ntp.get_servers_status ()
   else
     []
+
+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_server_localtime ~__context ~self:_ ~value =
+  let param =
+    match value with
+    | Date.{t; tz= Some 0} | Date.{t; tz= None} ->
+        (* Ideally it should be of a new type like NaiveDateTime. For
+           simplicity, reuse DateTime here. But it can't tell if the UTC is
+           specified explicitly or not. Just ignore it in that case. *)
+        let (y, mon, d), ((h, min, s), _) = Ptime.to_date_time t in
+        Printf.sprintf "%04i-%02i-%02i %02i:%02i:%02i" y mon d h min s
+    | _ ->
+        raise
+          (Api_errors.Server_error (Api_errors.not_allowed_tz_in_localtime, []))
+  in
+  try
+    Helpers.call_script !Xapi_globs.timedatectl ["set-time"; param] |> ignore ;
+    ()
+  with e -> Helpers.internal_error "%s" (ExnHelper.string_of_exn e)

ocaml/xapi/xapi_host.mli

@@ -627,3 +627,8 @@ val sync_ntp_config : __context:Context.t -> host:API.ref_host -> unit
 
 val get_ntp_servers_status :
   __context:Context.t -> self:API.ref_host -> (string * string) list
+
+val get_ntp_synchronized : __context:Context.t -> self:API.ref_host -> bool
+
+val set_server_localtime :
+  __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