Merge master into feature/config-ntp-timezone-maxcstate (#6787)

- Solve the conflict of new added host fileds.
- Add one commit to update lifecycle.

Author: changlei-li

doc/content/toolstack/features/Tracing/index.md

@@ -81,14 +81,17 @@ and also assist newcomers in onboarding to the project.
 
 By default, traces are generated locally in the `/var/log/dt` directory. You can copy or forward
 these traces to another location or endpoint using the `xs-trace` tool. For example, if you have
-a *Jaeger* server running locally, you can run:
+a *Jaeger* server running locally, you can copy a trace to an endpoint by running:
 
 ```sh
-xs-trace /var/log/dt/ http://127.0.0.1:9411/api/v2/spans
+xs-trace cp /var/log/dt/ http://127.0.0.1:9411/api/v2/spans
 ```
 
 You will then be able to visualize the traces in Jaeger.
 
+The `xs-trace` tool also supports trace files in `.ndjson` and compressed `.zst` formats, so
+you can copy or forward these files directly as well.
+
 ### Tagging Trace Sessions for Easier Search
 
 #### Specific attributes

ocaml/idl/datamodel_host.ml

@@ -1398,6 +1398,14 @@ let create_params =
     ; param_release= numbered_release "25.32.0-next"
     ; param_default= Some (VMap [])
     }
+  ; {
+      param_type= Bool
+    ; param_name= "https_only"
+    ; param_doc=
+        "updates firewall to open or close port 80 depending on the value"
+    ; param_release= numbered_release "25.38.0-next"
+    ; param_default= Some (VBool false)
+    }
   ]
 
 let create =
@@ -1416,6 +1424,7 @@ let create =
            --console_idle_timeout --ssh_auto_mode options to allow them to be \
            configured for new host"
         )
+      ; (Changed, "25.38.0-next", "Added --https_only to disable http")
       ]
     ~versioned_params:create_params ~doc:"Create a new host record"
     ~result:(Ref _host, "Reference to the newly created host object.")

ocaml/idl/datamodel_lifecycle.ml

@@ -98,15 +98,15 @@ let prototyped_of_field = function
   | "SM", "host_pending_features" ->
       Some "24.37.0"
   | "host", "timezone" ->
-      Some "25.37.0-next"
+      Some "25.39.0-next"
   | "host", "ntp_custom_servers" ->
-      Some "25.37.0-next"
+      Some "25.39.0-next"
   | "host", "ntp_mode" ->
-      Some "25.37.0-next"
+      Some "25.39.0-next"
   | "host", "secure_boot" ->
       Some "25.31.0"
   | "host", "max_cstate" ->
-      Some "25.37.0-next"
+      Some "25.39.0-next"
   | "host", "ssh_auto_mode" ->
       Some "25.27.0"
   | "host", "console_idle_timeout" ->
@@ -234,21 +234,21 @@ let prototyped_of_message = function
   | "VTPM", "create" ->
       Some "22.26.0"
   | "host", "set_servertime" ->
-      Some "25.37.0-next"
+      Some "25.39.0-next"
   | "host", "get_ntp_synchronized" ->
-      Some "25.37.0-next"
+      Some "25.39.0-next"
   | "host", "list_timezones" ->
-      Some "25.37.0-next"
+      Some "25.39.0-next"
   | "host", "set_timezone" ->
-      Some "25.37.0-next"
+      Some "25.39.0-next"
   | "host", "get_ntp_servers_status" ->
-      Some "25.37.0-next"
+      Some "25.39.0-next"
   | "host", "set_ntp_custom_servers" ->
-      Some "25.37.0-next"
+      Some "25.39.0-next"
   | "host", "set_ntp_mode" ->
-      Some "25.37.0-next"
+      Some "25.39.0-next"
   | "host", "set_max_cstate" ->
-      Some "25.37.0-next"
+      Some "25.39.0-next"
   | "host", "update_firewalld_service_status" ->
       Some "25.34.0"
   | "host", "get_tracked_user_agents" ->

ocaml/libs/ezxenstore/watch/ez_xenstore_watch.ml

@@ -115,6 +115,10 @@ module Make (Debug : DEBUG) = struct
         in
         List.map fst (IntMap.bindings c)
 
+      let need_refresh_domains = Atomic.make false
+
+      let mark_refresh_domains () = Atomic.set need_refresh_domains true
+
       let with_xc_and_xs f =
         Xenctrl.with_intf (fun xc -> with_xs (fun xs -> f xc xs))
 
@@ -196,9 +200,13 @@ module Make (Debug : DEBUG) = struct
               in
 
               let process_one_watch c (path, _token) =
-                if path = _introduceDomain || path = _releaseDomain then
-                  look_for_different_domains ()
-                else
+                if
+                  Atomic.exchange need_refresh_domains false
+                  || path = _introduceDomain
+                  || path = _releaseDomain
+                then
+                  look_for_different_domains () ;
+                if path <> _introduceDomain && path <> _releaseDomain then
                   Client.immediate c (fun h ->
                       let xs = Xs.ops h in
                       Actions.watch_fired xc xs path !domains !watches

ocaml/libs/http-lib/mime.ml

@@ -7,5 +7,9 @@
     qcow-stream
     cmdliner
     unix
+    lwt.unix
+    lwt
+    qcow-types
+    yojson
   )
 )

ocaml/libs/http-lib/mime.mli

@@ -1,11 +1,53 @@
+open Cmdliner
+
 module Impl = struct
   let stream_decode output =
     Qcow_stream.stream_decode Unix.stdin output ;
     `Ok ()
+
+  let read_headers qcow_path =
+    let open Lwt.Syntax in
+    let t =
+      let* fd = Lwt_unix.openfile qcow_path [Unix.O_RDONLY] 0 in
+      let* virtual_size, cluster_bits, _, data_cluster_map =
+        Qcow_stream.start_stream_decode fd
+      in
+      let clusters = Qcow_types.Cluster.Map.bindings data_cluster_map in
+      let clusters =
+        List.map
+          (fun (_, virt_address) ->
+            let ( >> ) = Int64.shift_right_logical in
+            let address =
+              Int64.to_int (virt_address >> Int32.to_int cluster_bits)
+            in
+            `Int address
+          )
+          clusters
+      in
+      let json =
+        `Assoc
+          [
+            ("virtual_size", `Int (Int64.to_int virtual_size))
+          ; ("cluster_bits", `Int (Int32.to_int cluster_bits))
+          ; ("data_clusters", `List clusters)
+          ]
+      in
+      let json_string = Yojson.to_string json in
+      let* () = Lwt_io.print json_string in
+      let* () = Lwt_io.flush Lwt_io.stdout in
+      Lwt.return_unit
+    in
+    Lwt_main.run t ; `Ok ()
 end
 
 module Cli = struct
-  open Cmdliner
+  let output default =
+    let doc = Printf.sprintf "Path to the output file." in
+    Arg.(value & pos 0 string default & info [] ~doc)
+
+  let input =
+    let doc = Printf.sprintf "Path to the input file." in
+    Arg.(required & pos 0 (some string) None & info [] ~doc)
 
   let stream_decode_cmd =
     let doc = "decode qcow2 formatted data from stdin and write a raw image" in
@@ -15,15 +57,28 @@ module Cli = struct
       ; `P "Decode qcow2 formatted data from stdin and write to a raw file."
       ]
     in
-    let output default =
-      let doc = Printf.sprintf "Path to the output file." in
-      Arg.(value & pos 0 string default & info [] ~doc)
-    in
     Cmd.v
       (Cmd.info "stream_decode" ~doc ~man)
       Term.(ret (const Impl.stream_decode $ output "test.raw"))
 
-  let main () = Cmd.eval stream_decode_cmd
+  let read_headers_cmd =
+    let doc =
+      "Determine allocated clusters by parsing qcow2 file at the provided \
+       path. Returns JSON like the following: {'virtual_size': X, \
+       'cluster_bits': Y, 'data_clusters': [1,2,3]}"
+    in
+    let man = [`S "DESCRIPTION"; `P doc] in
+    Cmd.v
+      (Cmd.info "read_headers" ~doc ~man)
+      Term.(ret (const Impl.read_headers $ input))
+
+  let cmds = [stream_decode_cmd; read_headers_cmd]
 end
 
-let () = exit (Cli.main ())
+let info =
+  let doc = "minimal CLI for qcow-stream" in
+  Cmd.info "qcow-stream-tool" ~version:"1.0.0" ~doc
+
+let () =
+  let cmd = Cmd.group info Cli.cmds in
+  exit (Cmd.eval cmd)

ocaml/qcow-stream-tool/dune

@@ -175,7 +175,7 @@ let make_host ~__context ?(uuid = make_uuid ()) ?(name_label = "host")
     ?(last_software_update = Date.epoch) ?(last_update_hash = "")
     ?(ssh_enabled = true) ?(ssh_enabled_timeout = 0L) ?(ssh_expiry = Date.epoch)
     ?(console_idle_timeout = 0L) ?(ssh_auto_mode = false) ?(secure_boot = false)
-    () =
+    ?(https_only = false) () =
   let host =
     Xapi_host.create ~__context ~uuid ~name_label ~name_description ~hostname
       ~address ~external_auth_type ~external_auth_service_name
@@ -184,6 +184,7 @@ let make_host ~__context ?(uuid = make_uuid ()) ?(name_label = "host")
       ~last_update_hash ~ssh_enabled ~ssh_enabled_timeout ~ssh_expiry
       ~console_idle_timeout ~ssh_auto_mode ~secure_boot
       ~software_version:(Xapi_globs.software_version ())
+      ~https_only
   in
   Db.Host.set_cpu_info ~__context ~self:host ~value:default_cpu_info ;
   host
@@ -194,15 +195,14 @@ let make_host2 ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ())
     ?(external_auth_type = "") ?(external_auth_service_name = "")
     ?(external_auth_configuration = []) ?(license_params = [])
     ?(edition = "free") ?(license_server = []) ?(local_cache_sr = Ref.null)
-    ?(chipset_info = []) ?(ssl_legacy = false) () =
+    ?(chipset_info = []) ?(ssl_legacy = false) ?(https_only = false) () =
   let pool = Helpers.get_pool ~__context in
   let tls_verification_enabled =
     Db.Pool.get_tls_verification_enabled ~__context ~self:pool
   in
   Db.Host.create ~__context ~ref ~current_operations:[] ~allowed_operations:[]
     ~software_version:(Xapi_globs.software_version ())
-    ~https_only:false ~enabled:false
-    ~aPI_version_major:Datamodel_common.api_version_major
+    ~enabled:false ~aPI_version_major:Datamodel_common.api_version_major
     ~aPI_version_minor:Datamodel_common.api_version_minor
     ~aPI_version_vendor:Datamodel_common.api_version_vendor
     ~aPI_version_vendor_implementation:
@@ -224,8 +224,8 @@ let make_host2 ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ())
     ~pending_guidances_recommended:[] ~pending_guidances_full:[]
     ~last_update_hash:"" ~ssh_enabled:true ~ssh_enabled_timeout:0L
     ~ssh_expiry:Date.epoch ~console_idle_timeout:0L ~ssh_auto_mode:false
-    ~max_cstate:"" ~secure_boot:false ~ntp_mode:`Factory ~ntp_custom_servers:[]
-    ~timezone:"UTC" ;
+    ~secure_boot:false ~https_only ~max_cstate:"" ~ntp_mode:`Factory
+    ~ntp_custom_servers:[] ~timezone:"UTC" ;
   ref
 
 let make_pif ~__context ~network ~host ?(device = "eth0")

ocaml/qcow-stream-tool/qcow_stream_tool.ml

@@ -117,7 +117,7 @@ let event_next_test () =
   let __context, _ = event_setup_common () in
   let () = Xapi_event.register ~__context ~classes:["pool"] in
   let wait_hdl = Delay.make () in
-  let pool = Db.Pool.get_all ~__context |> List.hd in
+  let pool = Helpers.get_pool ~__context in
   let key = "event_next_test" in
   ( try Db.Pool.remove_from_other_config ~__context ~self:pool ~key
     with _ -> ()
@@ -146,7 +146,7 @@ let event_next_test () =
 let wait_for_pool_key __context key =
   let token = ref "" in
   let finished = ref false in
-  let pool = Db.Pool.get_all ~__context |> List.hd in
+  let pool = Helpers.get_pool ~__context in
   while not !finished do
     let events =
       Xapi_event.from ~__context ~classes:["pool"] ~token:!token ~timeout:10.
@@ -160,7 +160,7 @@ let wait_for_pool_key __context key =
 let event_from_test () =
   let __context, _ = event_setup_common () in
   let wait_hdl = Delay.make () in
-  let pool = Db.Pool.get_all ~__context |> List.hd in
+  let pool = Helpers.get_pool ~__context in
   let key = "event_from_test" in
   ( try Db.Pool.remove_from_other_config ~__context ~self:pool ~key
     with _ -> ()
@@ -180,7 +180,7 @@ let event_from_test () =
 
 let event_from_parallel_test () =
   let __context, _ = event_setup_common () in
-  let pool = Db.Pool.get_all ~__context |> List.hd in
+  let pool = Helpers.get_pool ~__context in
   let key = "event_next_test" in
   ( try Db.Pool.remove_from_other_config ~__context ~self:pool ~key
     with _ -> ()