Epoll: the rest of the changes

.github/workflows/other.yml

@@ -79,6 +79,7 @@ jobs:
           --cov-report xml:.git/coverage${{matrix.python-version}}.xml
         env:
           PYTHONDEVMODE: yes
+          PYTHONPATH: "python3:python3/tests/stubs"
 
       - name: Upload coverage report to Coveralls
         uses: coverallsapp/github-action@v2

doc/content/xapi/guides/howtos/add-field.md

@@ -1,7 +1,7 @@
 +++
 title = "Adding a field to the API"
 +++
-This page describes how to add a field to XenAPI. A field is a parameter of a class that can be used in functions and read from the API. 
+This page describes how to add a field to XenAPI. A field is a parameter of a class that can be used in functions and read from the API.
 
 Bumping the database schema version
 -----------------------------------
@@ -34,15 +34,15 @@ new API fields used for ActiveDirectory integration were added:
 
       (* IMPORTANT: Please bump schema vsn if you change/add/remove a _field_.
          You do not have to dump vsn if you change/add/remove a message *)
-    
+
       let schema_major_vsn = 5
      -let schema_minor_vsn = 55
      +let schema_minor_vsn = 56
-    
+
       (* Historical schema versions just in case this is useful later *)
       let rio_schema_major_vsn = 5
       let rio_schema_minor_vsn = 19
-    
+
      +let miami_release_schema_major_vsn = 5
      +let miami_release_schema_minor_vsn = 35
      +
@@ -95,7 +95,7 @@ See datamodel_types.ml for information about other parameters.
 Adding a field would change the constructors for the class – functions
 Db.*.create – and therefore, any references to these in the code need to be
 updated. In the example, the argument ~ha_enabled:false should be added to any
-call to Db.Pool.create. 
+call to Db.Pool.create.
 
 Examples of where these calls can be found is in `ocaml/tests/common/test_common.ml` and `ocaml/xapi/xapi_[class].ml`.
 
@@ -113,7 +113,7 @@ if you don't want this field to show up in a *_params_list call. As an example,
 here is a field that we've just added to the SM class:
 
     make_field ~name:"versioned-capabilities"
-               ~get:(fun () -> Record_util.s2sm_to_string "; " (x ()).API.sM_versioned_capabilities)
+               ~get:(fun () -> get_from_map (x ()).API.sM_versioned_capabilities)
                ~get_map:(fun () -> (x ()).API.sM_versioned_capabilities)
                ~hidden:true ();
 

ocaml/database/block_device_io.ml

@@ -325,16 +325,19 @@ let listen_on sock =
   s
 
 let accept_conn s latest_response_time =
-  let now = Unix.gettimeofday () in
-  let timeout = latest_response_time -. now in
-  (* Await an incoming connection... *)
-  let ready_to_read, _, _ = Unix.select [s] [] [] timeout in
-  R.info "Finished selecting" ;
-  if List.mem s ready_to_read then
-    (* We've received a connection. Accept it and return the socket. *)
-    fst (Unix.accept s)
-  else (* We must have timed out *)
-    raise Unixext.Timeout
+  match Clock.Timer.remaining latest_response_time with
+  | Expired _ ->
+      raise Unixext.Timeout
+  | Remaining timeout -> (
+      (* Await an incoming connection... *)
+      let timeout = Float.max 1e-6 @@ Clock.Timer.span_to_s timeout in
+      Unixext.with_socket_timeout s (Some timeout) @@ fun () ->
+      try
+        (* We've received a connection. Accept it and return the socket. *)
+        fst (Unix.accept s)
+      with Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) ->
+        raise Unixext.Timeout
+    )
 
 (* Listen on a given socket. Accept a single connection and transfer all the data from it to dest_fd, or raise Timeout if target_response_time happens first. *)
 (* Raises NotEnoughSpace if the next write would exceed the available_space. *)
@@ -731,6 +734,8 @@ let dump = ref false
 
 let empty = ref false
 
+let target_response_time delta = Clock.Timer.start ~duration:delta
+
 let _ =
   (* Initialise debug logging *)
   initialise_logging () ;
@@ -770,11 +775,12 @@ let _ =
     (* Open the block device *)
     let block_dev_fd =
       open_block_device !block_dev
-        (Unix.gettimeofday () +. !Db_globs.redo_log_max_startup_time)
+        (target_response_time !Db_globs.redo_log_max_startup_time)
     in
     R.info "Opened block device." ;
-    let target_response_time = Unix.gettimeofday () +. 3600. in
-    (* Read the validity byte *)
+    let target_response_time =
+      target_response_time !Db_globs.redo_log_max_connect_time
+    in
     try
       let validity = read_validity_byte block_dev_fd target_response_time in
       Printf.printf "*** Validity byte: [%s]\n" validity ;
@@ -841,10 +847,12 @@ let _ =
     (* Open the block device *)
     let block_dev_fd =
       open_block_device !block_dev
-        (Unix.gettimeofday () +. !Db_globs.redo_log_max_startup_time)
+        (target_response_time !Db_globs.redo_log_max_startup_time)
     in
     R.info "Opened block device." ;
-    let target_response_time = Unix.gettimeofday () +. 3600. in
+    let target_response_time =
+      target_response_time !Db_globs.redo_log_max_connect_time
+    in
     initialise_redo_log block_dev_fd target_response_time ;
     Printf.printf "Block device initialised.\n"
   ) ;
@@ -855,9 +863,8 @@ let _ =
     let s = listen_on !ctrlsock in
     (* Main loop: accept a new client, communicate with it until it stops sending commands, repeat. *)
     while true do
-      let start_of_startup = Unix.gettimeofday () in
       let target_startup_response_time =
-        start_of_startup +. !Db_globs.redo_log_max_startup_time
+        target_response_time !Db_globs.redo_log_max_startup_time
       in
       R.info "Awaiting incoming connections on %s..." !ctrlsock ;
       let client = accept_conn s target_startup_response_time in
@@ -898,11 +905,11 @@ let _ =
                           send_failure client (str ^ "|nack")
                             ("Unknown command " ^ str)
                         )
-                      , 0.
+                      , Mtime.Span.zero
                       )
                 in
                 (* "Start the clock!" -- set the latest time by which we need to have responded to the client. *)
-                let target_response_time = Unix.gettimeofday () +. block_time in
+                let target_response_time = target_response_time block_time in
                 action_fn block_dev_fd client !datasock target_response_time
               with
               (* this must be an exception in Unixext.really_read because action_fn doesn't throw exceptions *)

ocaml/database/db_globs.ml

@@ -3,19 +3,22 @@
 let redo_log_block_device_io = ref "block_device_io"
 
 (** The delay between each attempt to connect to the block device I/O process *)
-let redo_log_connect_delay = ref 0.1
+let redo_log_connect_delay = ref Mtime.Span.(100 * ms)
 
 (** The maximum time, in seconds, for which we are prepared to wait for a response from the block device I/O process before assuming that it has died while emptying *)
-let redo_log_max_block_time_empty = ref 2.
+let redo_log_max_block_time_empty = ref Mtime.Span.(2 * s)
 
 (** The maximum time, in seconds, for which we are prepared to wait for a response from the block device I/O process before assuming that it has died while reading *)
-let redo_log_max_block_time_read = ref 30.
+let redo_log_max_block_time_read = ref Mtime.Span.(30 * s)
 
 (** The maximum time, in seconds, for which we are prepared to wait for a response from the block device I/O process before assuming that it has died while writing a delta *)
-let redo_log_max_block_time_writedelta = ref 2.
+let redo_log_max_block_time_writedelta = ref Mtime.Span.(2 * s)
 
 (** The maximum time, in seconds, for which we are prepared to wait for a response from the block device I/O process before assuming that it has died while writing a database *)
-let redo_log_max_block_time_writedb = ref 30.
+let redo_log_max_block_time_writedb = ref Mtime.Span.(30 * s)
+
+(** The maximum amount of time to wait for a connection (used to be hardcoded to 3600s) *)
+let redo_log_max_connect_time = ref Mtime.Span.(1 * hour)
 
 (** {3 Settings related to the exponential back-off of repeated attempts to reconnect after failure} *)
 
@@ -35,7 +38,7 @@ let redo_log_max_dying_processes = 2
 let redo_log_comms_socket_stem = "sock-blkdev-io"
 
 (** The maximum time, in seconds, for which we are prepared to wait for a response from the block device I/O process before assuming that it has died while initially connecting to it *)
-let redo_log_max_startup_time = ref 5.
+let redo_log_max_startup_time = ref Mtime.Span.(5 * s)
 
 (** The length, in bytes, of one redo log which constitutes half of the VDI *)
 let redo_log_length_of_half = 60 * 1024 * 1024

ocaml/database/dune

@@ -28,7 +28,11 @@
       test_schemas unit_test_marshall unit_test_sql))
   (libraries
     forkexec
+    fmt
     gzip
+    mtime
+    mtime.clock
+    mtime.clock.os
     rpclib.core
     rpclib.json
     safe-resources
@@ -61,6 +65,9 @@
   (modules block_device_io)
   (libraries
     dune-build-info
+    mtime
+    mtime.clock
+    mtime.clock.os
     xapi_database
     xapi-log
     xapi-stdext-pervasives

ocaml/database/master_connection.ml

@@ -171,7 +171,11 @@ let open_secure_connection () =
     ~write_to_log:(fun x -> debug "stunnel: %s\n" x)
     ~verify_cert host port
   @@ fun st_proc ->
-  let fd_closed = Thread.wait_timed_read Unixfd.(!(st_proc.Stunnel.fd)) 5. in
+  let fd_closed =
+    Xapi_stdext_unix.Unixext.wait_timed_read
+      Unixfd.(!(st_proc.Stunnel.fd))
+      Mtime.Span.(5 * s)
+  in
   let proc_quit =
     try
       Unix.kill (Stunnel.getpid st_proc.Stunnel.pid) 0 ;

ocaml/database/redo_log.ml

@@ -244,9 +244,7 @@ let generation_size = 16
 
 let length_size = 16
 
-let get_latest_response_time block_time =
-  let now = Unix.gettimeofday () in
-  now +. block_time
+let get_latest_response_time block_time = Clock.Timer.start ~duration:block_time
 
 (* Returns the PID of the process *)
 let start_io_process block_dev ctrlsockpath datasockpath =
@@ -265,26 +263,29 @@ let connect sockpath latest_response_time =
       Unix.connect s (Unix.ADDR_UNIX sockpath) ;
       D.debug "Connected to I/O process via socket %s" sockpath ;
       s
-    with Unix.Unix_error (a, b, _) ->
+    with Unix.Unix_error (a, b, _) -> (
       (* It's probably the case that the process hasn't started yet. *)
       (* See if we can afford to wait and try again *)
       Unix.close s ;
       let attempt_delay = !Db_globs.redo_log_connect_delay in
-      let now = Unix.gettimeofday () in
-      let remaining = latest_response_time -. now in
-      if attempt_delay < remaining then (
-        (* Wait for a while then try again *)
-        D.debug
-          "Waiting to connect to I/O process via socket %s (error was %s: \
-           %s)..."
-          sockpath b (Unix.error_message a) ;
-        D.debug "Remaining time for retries: %f" remaining ;
-        Thread.delay attempt_delay ;
-        attempt ()
-      ) else (
-        D.debug "%s timeout reached" __FUNCTION__ ;
-        raise Unixext.Timeout
-      )
+      match
+        Clock.Timer.remaining
+          (Clock.Timer.shorten_by attempt_delay latest_response_time)
+      with
+      | Remaining remaining ->
+          (* Wait for a while then try again *)
+          D.debug
+            "Waiting to connect to I/O process via socket %s (error was %s: \
+             %s)..."
+            sockpath b (Unix.error_message a) ;
+          D.debug "Remaining time for retries: %a" Debug.Pp.mtime_span remaining ;
+          Unixext.delay_span attempt_delay ;
+          attempt ()
+      | Expired overrun ->
+          D.debug "%s timeout reached (%a overrun)" __FUNCTION__
+            Debug.Pp.mtime_span overrun ;
+          raise Unixext.Timeout
+    )
   in
   attempt ()
 

ocaml/database/redo_log.mli

@@ -99,7 +99,7 @@ type t =
       represents the write to the field with name [fldname] of a row in table [tblname] with key [objref], overwriting its value with [newval]. *)
 
 val apply :
-     (Generation.t -> Unix.file_descr -> int -> float -> unit)
+     (Generation.t -> Unix.file_descr -> int -> Clock.Timer.t -> unit)
   -> (Generation.t -> t -> unit)
   -> [< `RO | `RW] redo_log
   -> unit

ocaml/forkexecd/src/child.ml

@@ -94,14 +94,7 @@ let handle_comms comms_sock fd_sock state =
 let log_failure args child_pid reason =
   (* The commandline might be too long to clip it *)
   let cmdline = String.concat " " args in
-  let limit = 80 - 3 in
-  let cmdline' =
-    if String.length cmdline > limit then
-      String.sub cmdline 0 limit ^ "..."
-    else
-      cmdline
-  in
-  Fe_debug.error "%d (%s) %s" child_pid cmdline' reason
+  Fe_debug.error "%d (%s) %s" child_pid cmdline reason
 
 let report_child_exit comms_sock args child_pid status =
   let module Unixext = Xapi_stdext_unix.Unixext in

ocaml/idl/datamodel_certificate.ml

@@ -69,10 +69,10 @@ let t =
             [(Published, rel_stockholm, ""); (Deprecated, "24.19.0", "")]
           ~ty:String "fingerprint" ~default_value:(Some (VString ""))
           "Use fingerprint_sha256 instead"
-      ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint_sha256"
+      ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:String "fingerprint_sha256"
           ~default_value:(Some (VString ""))
           "The certificate's SHA256 fingerprint / hash"
-      ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint_sha1"
+      ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:String "fingerprint_sha1"
           ~default_value:(Some (VString ""))
           "The certificate's SHA1 fingerprint / hash"
       ]

ocaml/idl/datamodel_cluster.ml

@@ -169,6 +169,16 @@ let pool_resync =
     ~params:[(Ref _cluster, "self", "The cluster to resync")]
     ~lifecycle ~allowed_roles:_R_POOL_OP ~errs:[] ()
 
+let cstack_sync =
+  call ~name:"cstack_sync"
+    ~doc:
+      "Sync xapi db with the cluster stack synchronously, and generate alerts \
+       as needed. Only happens on the coordinator as this is where the cluster \
+       watcher performs updates."
+    ~params:[(Ref _cluster, "self", "The cluster to sync")]
+    ~hide_from_docs:true ~pool_internal:true ~lifecycle
+    ~allowed_roles:_R_POOL_OP ~errs:[] ()
+
 let t =
   create_obj ~name:_cluster ~descr:"Cluster-wide Cluster metadata"
     ~doccomments:[] ~gen_constructor_destructor:false ~gen_events:true
@@ -245,5 +255,6 @@ let t =
       ; pool_force_destroy
       ; pool_destroy
       ; pool_resync
+      ; cstack_sync
       ]
     ()

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 = 779
+let schema_minor_vsn = 780
 
 (* Historical schema versions just in case this is useful later *)
 let rio_schema_major_vsn = 5