From 9291f21c0d5b8ab7068b4eb800489403107e7eba Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 18 Jun 2024 13:53:22 +0800 Subject: [PATCH 001/157] CA-394343: After clock jump the xapi assumed the host is HOST_OFFLINE Prior to this commit, the xapi on the coordinator host records the 'Unix.gettimeofday' as the timestamps of the heartbeat with other pool supporter hosts. When the system clock is updated with a huge jump forward, the timestamps would be far back into the past. This would cause the xapi assumes that the hosts are offline as long time no heartbeats. In this commit, the timestamps are changed to get from a monotonic clock. In this way, the system clock changes will not impact the heartbeats' timestamps any more. Additionally, Host_metrics.last_updated is only set when the object is created. It's useless in check_host_liveness at all. Signed-off-by: Ming Lu --- ocaml/xapi/db_gc.ml | 56 +++++++++++++++------------------------- ocaml/xapi/xapi_globs.ml | 6 +++-- ocaml/xapi/xapi_ha.ml | 2 +- 3 files changed, 26 insertions(+), 38 deletions(-) diff --git a/ocaml/xapi/db_gc.ml b/ocaml/xapi/db_gc.ml index a0442314448..2efe11b89ee 100644 --- a/ocaml/xapi/db_gc.ml +++ b/ocaml/xapi/db_gc.ml @@ -30,7 +30,8 @@ let use_host_heartbeat_for_liveness = ref true let use_host_heartbeat_for_liveness_m = Mutex.create () -let host_heartbeat_table : (API.ref_host, float) Hashtbl.t = Hashtbl.create 16 +let host_heartbeat_table : (API.ref_host, Clock.Timer.t) Hashtbl.t = + Hashtbl.create 16 let host_skew_table : (API.ref_host, float) Hashtbl.t = Hashtbl.create 16 @@ -77,45 +78,24 @@ let detect_clock_skew ~__context host skew = (* Master compares the database with the in-memory host heartbeat table and sets the live flag accordingly. Called with the use_host_heartbeat_for_liveness_m and use_host_heartbeat_for_liveness is true (ie non-HA mode) *) let check_host_liveness ~__context = - (* Check for rolling upgrade mode - if so, use host metrics for liveness else use hashtbl *) - let rum = - try Helpers.rolling_upgrade_in_progress ~__context with _ -> false - in (* CA-16351: when performing the initial GC pass on first boot there won't be a localhost *) let localhost = try Helpers.get_localhost ~__context with _ -> Ref.null in - (* Look for "true->false" transition on Host_metrics.live *) let check_host host = if host <> localhost then try let hmetric = Db.Host.get_metrics ~__context ~self:host in let live = Db.Host_metrics.get_live ~__context ~self:hmetric in - (* See if the host is using the new HB mechanism, if so we'll use that *) - let new_heartbeat_time = + let timer = with_lock host_table_m (fun () -> - Option.value - (Hashtbl.find_opt host_heartbeat_table host) - ~default:Clock.Date.(epoch |> to_unix_time) + match Hashtbl.find_opt host_heartbeat_table host with + | Some x -> + x + | None -> + Clock.Timer.start + ~duration:!Xapi_globs.host_assumed_dead_interval ) in - let old_heartbeat_time = - if - rum - && Xapi_version.platform_version () - <> Helpers.version_string_of ~__context (Helpers.LocalObject host) - then ( - debug - "Host %s considering using metrics last update time as heartbeat" - (Ref.string_of host) ; - Date.to_float - (Db.Host_metrics.get_last_updated ~__context ~self:hmetric) - ) else - 0.0 - in - (* Use whichever value is the most recent to determine host liveness *) - let host_time = max old_heartbeat_time new_heartbeat_time in - let now = Unix.gettimeofday () in - (* we can now compare 'host_time' with 'now' *) - if now -. host_time < !Xapi_globs.host_assumed_dead_interval then + if not (Clock.Timer.has_expired timer) then (* From the heartbeat PoV the host looks alive. We try to (i) minimise database sets; and (ii) avoid toggling the host back to live if it has been marked as shutting_down. *) with_lock Xapi_globs.hosts_which_are_shutting_down_m (fun () -> @@ -131,10 +111,14 @@ let check_host_liveness ~__context = ) ) else if live then ( + let host_name_label = Db.Host.get_name_label ~__context ~self:host in + let host_uuid = Db.Host.get_uuid ~__context ~self:host in + let elapsed = Clock.Timer.elapsed timer in debug - "Assuming host is offline since the heartbeat/metrics haven't been \ - updated for %.2f seconds; setting live to false" - (now -. host_time) ; + "Assuming host '%s' (%s) is offline since the heartbeat hasn't \ + been updated for %s seconds; setting live to false" + host_name_label host_uuid + (Clock.Timer.span_to_s elapsed |> string_of_float) ; Db.Host_metrics.set_live ~__context ~self:hmetric ~value:false ; Xapi_host_helpers.update_allowed_operations ~__context ~self:host ) ; @@ -252,9 +236,10 @@ let tickle_heartbeat ~__context host stuff = let reason = Xapi_hooks.reason__clean_shutdown in if use_host_heartbeat_for_liveness then Xapi_host_helpers.mark_host_as_dead ~__context ~host ~reason - ) else + ) else ( + Hashtbl.replace host_heartbeat_table host + (Clock.Timer.start ~duration:!Xapi_globs.host_assumed_dead_interval) ; let now = Unix.gettimeofday () in - Hashtbl.replace host_heartbeat_table host now ; (* compute the clock skew for later analysis *) if List.mem_assoc _time stuff then try @@ -262,6 +247,7 @@ let tickle_heartbeat ~__context host stuff = let skew = abs_float (now -. slave) in Hashtbl.replace host_skew_table host skew with _ -> () + ) ) ; [] diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index ad4f35e37ed..9993b27acdd 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -707,7 +707,7 @@ let snapshot_with_quiesce_timeout = ref 600. let host_heartbeat_interval = ref 30. (* If we haven't heard a heartbeat from a host for this interval then the host is assumed dead *) -let host_assumed_dead_interval = ref 600.0 +let host_assumed_dead_interval = ref Mtime.Span.(10 * min) (* If a session has a last_active older than this we delete it *) let inactive_session_timeout = ref 86400. (* 24 hrs in seconds *) @@ -1070,7 +1070,9 @@ let xapi_globs_spec = ; ("wait_memory_target_timeout", Float wait_memory_target_timeout) ; ("snapshot_with_quiesce_timeout", Float snapshot_with_quiesce_timeout) ; ("host_heartbeat_interval", Float host_heartbeat_interval) - ; ("host_assumed_dead_interval", Float host_assumed_dead_interval) + ; ( "host_assumed_dead_interval" + , LongDurationFromSeconds host_assumed_dead_interval + ) ; ("fuse_time", Float Constants.fuse_time) ; ("db_restore_fuse_time", Float Constants.db_restore_fuse_time) ; ("inactive_session_timeout", Float inactive_session_timeout) diff --git a/ocaml/xapi/xapi_ha.ml b/ocaml/xapi/xapi_ha.ml index 9937fea6f28..578788f8c9c 100644 --- a/ocaml/xapi/xapi_ha.ml +++ b/ocaml/xapi/xapi_ha.ml @@ -837,7 +837,7 @@ module Monitor = struct (ExnHelper.string_of_exn e) ; Thread.delay !Xapi_globs.ha_monitor_interval done ; - debug "Re-enabling old Host_metrics.live heartbeat" ; + debug "Re-enabling host heartbeat" ; with_lock Db_gc.use_host_heartbeat_for_liveness_m (fun () -> Db_gc.use_host_heartbeat_for_liveness := true ) ; From 62201478aa44921d3a596f469432211c9adbb38a Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Mon, 15 Jul 2024 10:48:33 +0800 Subject: [PATCH 002/157] CP-49212: Update datamodel for non-CDN update Add a field "origin" in "repository" to indicate the origin of the repository. It's an enum type with 2 values: "remote" and "bundle". Signed-off-by: Bengang Yuan --- ocaml/idl/datamodel_repository.ml | 38 +++++++++++++++++++++++-- ocaml/idl/schematest.ml | 2 +- ocaml/xapi-cli-server/cli_frontend.ml | 11 ++++++- ocaml/xapi-cli-server/cli_operations.ml | 15 ++++++++-- ocaml/xapi-cli-server/record_util.ml | 2 ++ ocaml/xapi-cli-server/records.ml | 5 ++++ ocaml/xapi/message_forwarding.ml | 6 ++++ ocaml/xapi/repository.ml | 35 +++++++++++++++++++---- ocaml/xapi/repository.mli | 6 ++++ ocaml/xapi/repository_helpers.ml | 16 +++++++---- ocaml/xapi/xapi_globs.ml | 4 +++ 11 files changed, 123 insertions(+), 17 deletions(-) diff --git a/ocaml/idl/datamodel_repository.ml b/ocaml/idl/datamodel_repository.ml index 02b17f509e0..114242d913f 100644 --- a/ocaml/idl/datamodel_repository.ml +++ b/ocaml/idl/datamodel_repository.ml @@ -18,10 +18,19 @@ open Datamodel_roles let lifecycle = [(Lifecycle.Published, "1.301.0", "")] +let origin = + Enum + ( "origin" + , [ + ("remote", "The origin of the repository is a remote one") + ; ("bundle", "The origin of the repository is a local bundle file") + ] + ) + let introduce = call ~name:"introduce" ~in_oss_since:None ~lifecycle:[(Published, "1.301.0", "")] - ~doc:"Add the configuration for a new repository" + ~doc:"Add the configuration for a new remote repository" ~versioned_params: [ { @@ -73,6 +82,18 @@ let introduce = ~allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT) () +let introduce_bundle = + call ~name:"introduce_bundle" ~in_oss_since:None ~lifecycle:[] + ~doc:"Add the configuration for a new bundle repository" + ~params: + [ + (String, "name_label", "The name of the repository") + ; (String, "name_description", "The description of the repository") + ] + ~result:(Ref _repository, "The ref of the created repository record.") + ~allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT) + () + let forget = call ~name:"forget" ~in_oss_since:None ~lifecycle:[(Published, "1.301.0", "")] @@ -148,7 +169,15 @@ let t = ~lifecycle:[(Published, "1.301.0", "")] ~persist:PersistEverything ~in_oss_since:None ~messages_default_allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT) - ~messages:[introduce; forget; apply; set_gpgkey_path; apply_livepatch] + ~messages: + [ + introduce + ; introduce_bundle + ; forget + ; apply + ; set_gpgkey_path + ; apply_livepatch + ] ~contents: [ uid _repository ~lifecycle:[(Published, "1.301.0", "")] @@ -187,5 +216,10 @@ let t = ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:String ~default_value:(Some (VString "")) "gpgkey_path" "The file name of the GPG public key of this repository" + ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:origin "origin" + ~default_value:(Some (VEnum "remote")) + "The origin of the repository. 'remote' if the origin of the \ + repository is a remote one, 'bundle' if the origin of the \ + repository is a local bundle file." ] () diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index 4ba16fbfe1c..6091444dcc9 100644 --- a/ocaml/idl/schematest.ml +++ b/ocaml/idl/schematest.ml @@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex (* BEWARE: if this changes, check that schema has been bumped accordingly in ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *) -let last_known_schema_hash = "7885f7b085e4a5e32977a4b222030412" +let last_known_schema_hash = "2a6baa01032827a321845b264c6aaae4" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index 1c71177c3c8..e735d4793ca 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -3659,11 +3659,20 @@ let rec cmdtable_data : (string * cmd_spec) list = , { reqd= ["name-label"; "binary-url"; "source-url"; "update"] ; optn= ["name-description"; "gpgkey-path"] - ; help= "Add the configuration for a new repository." + ; help= "Add the configuration for a new remote repository." ; implementation= No_fd Cli_operations.Repository.introduce ; flags= [] } ) + ; ( "repository-introduce-bundle" + , { + reqd= ["name-label"] + ; optn= ["name-description"] + ; help= "Add the configuration for a new bundle repository." + ; implementation= No_fd Cli_operations.Repository.introduce_bundle + ; flags= [] + } + ) ; ( "repository-forget" , { reqd= ["uuid"] diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 83f10a7a46d..93d0c69f41f 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -1318,6 +1318,7 @@ let gen_cmds rpc session_id = ; "hash" ; "up-to-date" ; "gpgkey-path" + ; "origin" ] rpc session_id ) @@ -7934,9 +7935,7 @@ end module Repository = struct let introduce printer rpc session_id params = let name_label = List.assoc "name-label" params in - let name_description = - try List.assoc "name-description" params with Not_found -> "" - in + let name_description = get_param params "name-description" ~default:"" in let binary_url = List.assoc "binary-url" params in let source_url = List.assoc "source-url" params in let update = get_bool_param params "update" in @@ -7948,6 +7947,16 @@ module Repository = struct let uuid = Client.Repository.get_uuid ~rpc ~session_id ~self:ref in printer (Cli_printer.PList [uuid]) + let introduce_bundle printer rpc session_id params = + let name_label = List.assoc "name-label" params in + let name_description = get_param params "name-description" ~default:"" in + let ref = + Client.Repository.introduce_bundle ~rpc ~session_id ~name_label + ~name_description + in + let uuid = Client.Repository.get_uuid ~rpc ~session_id ~self:ref in + printer (Cli_printer.PList [uuid]) + let forget _printer rpc session_id params = let ref = Client.Repository.get_by_uuid ~rpc ~session_id diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml index 105615fedfd..8e0bb1aaef2 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -1145,3 +1145,5 @@ let vm_placement_policy_of_string a = `anti_affinity | s -> record_failure "Invalid VM placement policy, got %s" s + +let repo_origin_to_string = function `remote -> "remote" | `bundle -> "bundle" diff --git a/ocaml/xapi-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index abcd5f3fb1c..f75809bf592 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -5370,6 +5370,11 @@ let repository_record rpc session_id repository = ~value:x ) () + ; make_field ~name:"origin" + ~get:(fun () -> + Record_util.repo_origin_to_string (x ()).API.repository_origin + ) + () ] } diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 34e420259b8..716274759ee 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -6560,6 +6560,12 @@ functor Local.Repository.introduce ~__context ~name_label ~name_description ~binary_url ~source_url ~update ~gpgkey_path + let introduce_bundle ~__context ~name_label ~name_description = + info "Repository.introduce_bundle: name = '%s'; name_description = '%s'" + name_label name_description ; + Local.Repository.introduce_bundle ~__context ~name_label + ~name_description + let forget ~__context ~self = info "Repository.forget: self = '%s'" (repository_uuid ~__context self) ; Local.Repository.forget ~__context ~self diff --git a/ocaml/xapi/repository.ml b/ocaml/xapi/repository.ml index bd63984c0a1..b3c2266d8ae 100644 --- a/ocaml/xapi/repository.ml +++ b/ocaml/xapi/repository.ml @@ -44,7 +44,22 @@ let introduce ~__context ~name_label ~name_description ~binary_url ~source_url ) ) ; create_repository_record ~__context ~name_label ~name_description ~binary_url - ~source_url ~update ~gpgkey_path + ~source_url ~update ~gpgkey_path ~origin:`remote + +let introduce_bundle ~__context ~name_label ~name_description = + Db.Repository.get_all ~__context + |> List.iter (fun ref -> + if + name_label = Db.Repository.get_name_label ~__context ~self:ref + || Db.Repository.get_origin ~__context ~self:ref = `bundle + then + raise + Api_errors.( + Server_error (repository_already_exists, [Ref.string_of ref]) + ) + ) ; + create_repository_record ~__context ~name_label ~name_description + ~binary_url:"" ~source_url:"" ~update:true ~gpgkey_path:"" ~origin:`bundle let forget ~__context ~self = let pool = Helpers.get_pool ~__context in @@ -112,8 +127,18 @@ let sync ~__context ~self ~token ~token_id = try let repo_name = get_remote_repository_name ~__context ~self in remove_repo_conf_file repo_name ; - let binary_url = Db.Repository.get_binary_url ~__context ~self in - let source_url = Db.Repository.get_source_url ~__context ~self in + let binary_url, source_url = + match Db.Repository.get_origin ~__context ~self with + | `remote -> + ( Db.Repository.get_binary_url ~__context ~self + , Some (Db.Repository.get_source_url ~__context ~self) + ) + | `bundle -> + let uri = + Uri.make ~scheme:"file" ~path:!Xapi_globs.bundle_repository_dir () + in + (Uri.to_string uri, None) + in let gpgkey_path = match Db.Repository.get_gpgkey_path ~__context ~self with | "" -> @@ -122,8 +147,8 @@ let sync ~__context ~self ~token ~token_id = s in let write_initial_yum_config () = - write_yum_config ~source_url:(Some source_url) ~binary_url - ~repo_gpgcheck:true ~gpgkey_path ~repo_name + write_yum_config ~source_url ~binary_url ~repo_gpgcheck:true ~gpgkey_path + ~repo_name in write_initial_yum_config () ; clean_yum_cache repo_name ; diff --git a/ocaml/xapi/repository.mli b/ocaml/xapi/repository.mli index 8b8ee7e09cd..e7bddad8bad 100644 --- a/ocaml/xapi/repository.mli +++ b/ocaml/xapi/repository.mli @@ -22,6 +22,12 @@ val introduce : -> gpgkey_path:string -> [`Repository] API.Ref.t +val introduce_bundle : + __context:Context.t + -> name_label:string + -> name_description:string + -> [`Repository] API.Ref.t + val forget : __context:Context.t -> self:[`Repository] API.Ref.t -> unit val cleanup_all_pool_repositories : unit -> unit diff --git a/ocaml/xapi/repository_helpers.ml b/ocaml/xapi/repository_helpers.ml index f67e8647822..71bf53ed1e3 100644 --- a/ocaml/xapi/repository_helpers.ml +++ b/ocaml/xapi/repository_helpers.ml @@ -134,11 +134,12 @@ module GuidanceSet = struct end let create_repository_record ~__context ~name_label ~name_description - ~binary_url ~source_url ~update ~gpgkey_path = + ~binary_url ~source_url ~update ~gpgkey_path ~origin = let ref = Ref.make () in let uuid = Uuidx.(to_string (make ())) in Db.Repository.create ~__context ~ref ~uuid ~name_label ~name_description - ~binary_url ~source_url ~update ~hash:"" ~up_to_date:false ~gpgkey_path ; + ~binary_url ~source_url ~update ~hash:"" ~up_to_date:false ~gpgkey_path + ~origin ; ref module DomainNameIncludeIP = struct @@ -377,9 +378,14 @@ let get_repository_name ~__context ~self = Db.Repository.get_uuid ~__context ~self let get_remote_repository_name ~__context ~self = - !Xapi_globs.remote_repository_prefix - ^ "-" - ^ get_repository_name ~__context ~self + let prefix = + match Db.Repository.get_origin ~__context ~self with + | `remote -> + !Xapi_globs.remote_repository_prefix + | `bundle -> + !Xapi_globs.bundle_repository_prefix + in + prefix ^ "-" ^ get_repository_name ~__context ~self let get_local_repository_name ~__context ~self = !Xapi_globs.local_repository_prefix diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index 1e03882ead1..a21226cf075 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -925,6 +925,8 @@ let yum_repos_config_dir = ref "/etc/yum.repos.d" let remote_repository_prefix = ref "remote" +let bundle_repository_prefix = ref "bundle" + let local_repository_prefix = ref "local" let yum_config_manager_cmd = ref "/usr/bin/yum-config-manager" @@ -945,6 +947,8 @@ let repository_gpgkey_name = ref "" let repository_gpgcheck = ref true +let bundle_repository_dir = ref "/var/xapi/bundle-repo" + let observer_config_dir = "/etc/xensource/observer" let ignore_vtpm_unimplemented = ref false From 4824a91fe311a00ea40f55f29e2eb3daae4759f3 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Sat, 13 Jul 2024 11:33:44 +0800 Subject: [PATCH 003/157] CP-49212: Add UT for update datamodel for non-CDN update Signed-off-by: Bengang Yuan --- ocaml/tests/test_repository.ml | 40 ++++++++++++++++++++++++++++++---- 1 file changed, 36 insertions(+), 4 deletions(-) diff --git a/ocaml/tests/test_repository.ml b/ocaml/tests/test_repository.ml index e30cf71362a..860dc63a950 100644 --- a/ocaml/tests/test_repository.ml +++ b/ocaml/tests/test_repository.ml @@ -14,7 +14,7 @@ module T = Test_common -let test_introduce_duplicate_name () = +let test_introduce_duplicate_repo_name () = let __context = T.make_test_database () in let name_label = "name" in let name_description = "description" in @@ -28,13 +28,20 @@ let test_introduce_duplicate_name () = Repository.introduce ~__context ~name_label ~name_description ~binary_url ~source_url ~update:true ~gpgkey_path in - Alcotest.check_raises "test_introduce_duplicate_name" + Alcotest.check_raises "test_introduce_duplicate_repo_name_1" Api_errors.(Server_error (repository_already_exists, [Ref.string_of ref])) (fun () -> Repository.introduce ~__context ~name_label ~name_description:name_description_1 ~binary_url:binary_url_1 ~source_url:source_url_1 ~update:true ~gpgkey_path |> ignore + ) ; + Alcotest.check_raises "test_introduce_duplicate_repo_name_2" + Api_errors.(Server_error (repository_already_exists, [Ref.string_of ref])) + (fun () -> + Repository.introduce_bundle ~__context ~name_label + ~name_description:name_description_1 + |> ignore ) let test_introduce_duplicate_binary_url () = @@ -51,7 +58,7 @@ let test_introduce_duplicate_binary_url () = Repository.introduce ~__context ~name_label ~name_description ~binary_url ~source_url ~update:true ~gpgkey_path in - Alcotest.check_raises "test_introduce_duplicate_name" + Alcotest.check_raises "test_introduce_duplicate_binary_url" Api_errors.(Server_error (repository_already_exists, [Ref.string_of ref])) (fun () -> Repository.introduce ~__context ~binary_url ~name_label:name_label_1 @@ -83,9 +90,30 @@ let test_introduce_invalid_gpgkey_path () = |> ignore ) +let test_introduce_duplicate_bundle_repo () = + let __context = T.make_test_database () in + let name_label = "name" in + let name_label_1 = "name1" in + let name_description = "description" in + let name_description_1 = "description1" in + let ref = + Repository.introduce_bundle ~__context ~name_label ~name_description + in + + Alcotest.check_raises "test_introduce_duplicate_bundle_repo" + Api_errors.(Server_error (repository_already_exists, [Ref.string_of ref])) + (fun () -> + Repository.introduce_bundle ~__context ~name_label:name_label_1 + ~name_description:name_description_1 + |> ignore + ) + let test = [ - ("test_introduce_duplicate_name", `Quick, test_introduce_duplicate_name) + ( "test_introduce_duplicate_repo_name" + , `Quick + , test_introduce_duplicate_repo_name + ) ; ( "test_introduce_duplicate_binary_url" , `Quick , test_introduce_duplicate_binary_url @@ -94,6 +122,10 @@ let test = , `Quick , test_introduce_invalid_gpgkey_path ) + ; ( "test_introduce_duplicate_bundle_repo" + , `Quick + , test_introduce_duplicate_bundle_repo + ) ] let () = From f4e944f8d624466cf1981e61807455d1506be683 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 10 Jul 2024 15:57:02 +0100 Subject: [PATCH 004/157] CA-395512: process SMAPIv3 API calls concurrently (default off) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit By default message-switch calls are serialized for backwards compatibility reasons in the Lwt and Async modes. (We tried enabling parallel actions by default but got some hard to debug failures in the CI). This causes very long VM start times when multiple VBDs are plugged/unplugged concurrently: the operations are seen concurrently by message-switch, but xapi-storage-script only retrieves and dispatches them sequentially, so any opportunity for parallel execution is lost. Even though the actions themselves only take seconds, due to serialization, a VM start may take minutes. Enable parallel processing explicitly here (instead of for all message-switch clients). SMAPIv3 should expect to be called concurrently (on different hosts even), so in theory this change should be safe and improve performance, but there are some known bugs in SMAPIv3 plugins currently. So introduce a config file flag 'concurrent' for now, that defaults to false, but that can be turned to 'true' for testing purposes. When all SMAPIv3 concurrency bugs are believed to be fixed we can flip the default, and eventually remove this flag once no more bugs are reported. The configuration value is done as a global to simplify integrating intot he Lwt port, instead of changing a lot of functions to thread through an argument. This doesn't change the behaviour of xapi-storage-script in its default configuration. Signed-off-by: Edwin Török --- ocaml/xapi-storage-script/main.ml | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index 2c904af7a43..b9542fd1963 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -1693,6 +1693,10 @@ let rec diff a b = | a :: aa -> if List.mem b a ~equal:String.( = ) then diff aa b else a :: diff aa b +(* default false due to bugs in SMAPIv3 plugins, + once they are fixed this should be set to true *) +let concurrent = ref false + let watch_volume_plugins ~volume_root ~switch_path ~pipe = let create volume_plugin_name = if Hashtbl.mem servers volume_plugin_name then @@ -1700,7 +1704,9 @@ let watch_volume_plugins ~volume_root ~switch_path ~pipe = else ( info "Adding %s" volume_plugin_name ; let volume_script_dir = Filename.concat volume_root volume_plugin_name in - Message_switch_async.Protocol_async.Server.listen + Message_switch_async.Protocol_async.Server.( + if !concurrent then listen_p else listen + ) ~process:(process_smapiv2_requests (bind ~volume_script_dir)) ~switch:switch_path ~queue:(Filename.basename volume_plugin_name) @@ -1957,6 +1963,11 @@ let _ = , (fun () -> string_of_bool !self_test_only) , "Do only a self-test and exit" ) + ; ( "concurrent" + , Arg.Set concurrent + , (fun () -> string_of_bool !concurrent) + , "Issue SMAPIv3 calls concurrently" + ) ] in configure2 ~name:"xapi-script-storage" ~version:Xapi_version.version From 459f68370d542802d2e9dd731d36ad06e01d5dc2 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Mon, 1 Jul 2024 09:56:00 +0800 Subject: [PATCH 005/157] CP-49213: Add new tar unpacking module Add a module Tar_ext to unpack a tar file. During the unpacking process, verify the tar file, containing total file size, file type, file path, file integrity, etc. Signed-off-by: Bengang Yuan --- ocaml/xapi/tar_ext.ml | 173 +++++++++++++++++++++++++++++++++++++++++ ocaml/xapi/tar_ext.mli | 42 ++++++++++ 2 files changed, 215 insertions(+) create mode 100644 ocaml/xapi/tar_ext.ml create mode 100644 ocaml/xapi/tar_ext.mli diff --git a/ocaml/xapi/tar_ext.ml b/ocaml/xapi/tar_ext.ml new file mode 100644 index 00000000000..3595cbee683 --- /dev/null +++ b/ocaml/xapi/tar_ext.ml @@ -0,0 +1,173 @@ +(* + * Copyright (c) Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Helpers + +module D = Debug.Make (struct let name = __MODULE__ end) + +open D + +let dir_perm = 0o755 + +let dir_size = 4096L + +let inode_size = 4096L + +let ( ++ ) = Int64.add + +let ( // ) = Filename.concat + +type unpack_error = + | Illegal_file_path of string + | Unsupported_file_type of string + | Unpacked_exceeds_max_size_limit of Int64.t + | File_size_mismatch of { + path: string + ; expected_size: Int64.t + ; actual_size: Int64.t + } + | File_incomplete + | File_corrupted + | Unpacking_failure + +let unpack_error_to_string = function + | Illegal_file_path path -> + Printf.sprintf "Illegal file path: %s" path + | Unsupported_file_type t -> + Printf.sprintf "Unsupported file type: %s" t + | Unpacked_exceeds_max_size_limit size -> + Printf.sprintf + "Stop unpacking, otherwise unpacked files exceed max size limit: %s" + (Int64.to_string size) + | File_size_mismatch {path; expected_size; actual_size} -> + Printf.sprintf + "Unpacked file size mismatch, path: %s, expected size: %s, actual \ + size: %s" + path + (Int64.to_string expected_size) + (Int64.to_string actual_size) + | File_incomplete -> + "File incompete" + | File_corrupted -> + "File corrupted" + | Unpacking_failure -> + "Unpacking failure" + +type unpack_result = Next of Int64.t + +(* Unpack one of entries in the tar file to a specified directory. The file's + information is defined in the file header. It includes the following parameters: + dir: which directory to unpack the tar file. + max_size_limit: the maximum size limitation of all the files in the tar. + acc_size: the current accumulated unpacked files size. + ifd: the tar file's descriptor. + head: the header of the file to be unpacked. +*) +let unpack dir max_size_limit acc_size ifd head = + (* Check if the entry's filename is legal. Including: + Check if starting with '/' + Check if including '.' + Check if including '..' + *) + let assert_file_path_is_legal file_path = + let file_list = String.split_on_char '/' file_path in + if + String.starts_with ~prefix:"/" file_path + || List.exists (String.equal ".") file_list + || List.exists (String.equal "..") file_list + then + Error (Illegal_file_path file_path) + else + Ok () + in + let ( let* ) = Result.bind in + (* Check if the accumulated files size plus the current file size exceeds the + maximum size limitation. If so, return an error. *) + let assert_file_not_exceed_max_size acc_size = + if Int64.compare acc_size max_size_limit > 0 then + Error (Unpacked_exceeds_max_size_limit max_size_limit) + else + Ok () + in + let file_name = head.Tar.Header.file_name in + debug "%s: Unpacking tar file: %s" __FUNCTION__ file_name ; + let* () = assert_file_path_is_legal file_name in + let path = dir // file_name in + match head.Tar.Header.link_indicator with + | Tar.Header.Link.Normal -> + let expected_size = head.Tar.Header.file_size in + let acc_size' = acc_size ++ expected_size ++ inode_size in + let* () = assert_file_not_exceed_max_size acc_size' in + Unixext.with_file path [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] + head.Tar.Header.file_mode (fun ofd -> + let actual_size = Unixext.copy_file ~limit:expected_size ifd ofd in + if actual_size <> expected_size then + Error (File_size_mismatch {path; expected_size; actual_size}) + else + Ok (Next acc_size') + ) + | Tar.Header.Link.Directory -> + let acc_size' = acc_size ++ dir_size ++ inode_size in + let* () = assert_file_not_exceed_max_size acc_size' in + Unixext.mkdir_rec path head.Tar.Header.file_mode ; + Ok (Next acc_size') + | Hard + | Symbolic + | Character + | Block + | FIFO + | GlobalExtendedHeader + | PerFileExtendedHeader + | LongLink -> + Error + (Unsupported_file_type + (Tar.Header.Link.to_string head.Tar.Header.link_indicator) + ) + +(* It will call function 'unpack' for every entry in the tar file. Each entry + contains a header and the file self. The header include the destination file + name, file type, file size, etc. The header will be passed to the function + 'unpack' as a parameter, then the function will verify the file size, file + path, etc, and then unpack to the directory which is the other parameter of + this function. +*) +let unpack_tar_file ~dir ~ifd ~max_size_limit = + debug "%s: Unpacking to %s" __FUNCTION__ dir ; + Unixext.rm_rec dir ; + Unixext.mkdir_rec dir dir_perm ; + let rec unpack_all_files f acc_size = + match Tar_unix.Archive.with_next_file ifd (f acc_size) with + | exception Tar.Header.End_of_stream -> + debug "%s: Unpacked to %s successfully" __FUNCTION__ dir ; + Ok () + | Ok (Next size) -> + unpack_all_files f size + | Error _ as err -> + err + | exception End_of_file -> + Error File_incomplete + | exception Tar.Header.Checksum_mismatch -> + Error File_corrupted + | exception e -> + error "%s: Unpacking failure: %s" __FUNCTION__ (Printexc.to_string e) ; + Error Unpacking_failure + in + let unpack' = unpack dir max_size_limit in + unpack_all_files unpack' 0L + |> Result.map_error (fun err -> + error "%s: Failed to unpack to %s due to error: %s" __FUNCTION__ dir + (unpack_error_to_string err) ; + Unixext.rm_rec dir ; + err + ) diff --git a/ocaml/xapi/tar_ext.mli b/ocaml/xapi/tar_ext.mli new file mode 100644 index 00000000000..c56cf23a8be --- /dev/null +++ b/ocaml/xapi/tar_ext.mli @@ -0,0 +1,42 @@ +(* + * Copyright (c) Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type unpack_error = + | Illegal_file_path of string + | Unsupported_file_type of string + | Unpacked_exceeds_max_size_limit of Int64.t + | File_size_mismatch of { + path: string + ; expected_size: Int64.t + ; actual_size: Int64.t + } + | File_incomplete + | File_corrupted + | Unpacking_failure + +val unpack_error_to_string : unpack_error -> string + +val unpack_tar_file : + dir:string + -> ifd:Unix.file_descr + -> max_size_limit:int64 + -> (unit, unpack_error) result +(** [unpack_tar_file dir ifd max_size_limit] unpacks a tar file from file + descriptor [ifd] to specific directory [dir]. The total size of all unpacked + files should not exceed the maximum size limitation [max_size_limit]. + The function result is: + {ul + {- [Ok ()] if successful.} + {- [Error unpack_error] otherwise. [unpack_error] indicates the + failing reason.}} *) From a9b0ef7f95e88c6912c5465c3a8f8987bc073e35 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Mon, 1 Jul 2024 14:00:34 +0800 Subject: [PATCH 006/157] CP-49213: UT for add new tar unpacking module Signed-off-by: Bengang Yuan --- ocaml/tests/dune | 7 +- .../tests/test_data/gen_tar_ext_test_file.sh | 50 ++++++ ocaml/tests/test_tar_ext.ml | 162 ++++++++++++++++++ 3 files changed, 216 insertions(+), 3 deletions(-) create mode 100755 ocaml/tests/test_data/gen_tar_ext_test_file.sh create mode 100644 ocaml/tests/test_tar_ext.ml diff --git a/ocaml/tests/dune b/ocaml/tests/dune index ef0778ce51c..f792e954b81 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -8,7 +8,7 @@ test_vm_placement test_vm_helpers test_repository test_repository_helpers test_ref test_livepatch test_rpm test_updateinfo test_storage_smapiv1_wrapper test_storage_quicktest test_observer - test_pool_periodic_update_sync)) + test_pool_periodic_update_sync test_tar_ext)) (libraries alcotest angstrom @@ -61,15 +61,16 @@ (tests (names test_vm_helpers test_vm_placement test_network_sriov test_vdi_cbt test_clustering test_pusb test_daemon_manager test_repository test_repository_helpers - test_livepatch test_rpm test_updateinfo test_pool_periodic_update_sync) + test_livepatch test_rpm test_updateinfo test_pool_periodic_update_sync test_tar_ext) (package xapi) (modes exe) (modules test_vm_helpers test_vm_placement test_network_sriov test_vdi_cbt test_event test_clustering test_cluster_host test_cluster test_pusb test_daemon_manager test_repository test_repository_helpers test_livepatch test_rpm - test_updateinfo test_pool_periodic_update_sync) + test_updateinfo test_pool_periodic_update_sync test_tar_ext) (libraries alcotest + bos fmt ptime result diff --git a/ocaml/tests/test_data/gen_tar_ext_test_file.sh b/ocaml/tests/test_data/gen_tar_ext_test_file.sh new file mode 100755 index 00000000000..673013a5c31 --- /dev/null +++ b/ocaml/tests/test_data/gen_tar_ext_test_file.sh @@ -0,0 +1,50 @@ +#!/bin/bash + +test_file_dir=$1 +mkdir -p "${test_file_dir}" +cd "${test_file_dir}" || exit + +echo "========= Generating regular tar file =========" +echo "This is file-1" > file1.txt +echo "This is file-2" > file2.txt +tar -cvf test_tar_ext_regular.tar file1.txt file2.txt + +echo "========= Generating tar file with illegal path =========" +mkdir test_illegal_dir +touch test_illegal_dir/file +tar --absolute-names -cvf test_tar_ext_illegal_path.tar test_illegal_dir/../file1.txt + +echo "========= Generating tar file trying to escape the current dir =========" +mkdir current_dir +mkdir another_dir +touch current_dir/file +touch another_dir/escaped_file +tar --absolute-names -cvf current_dir/test_tar_ext_trying_to_escape.tar current_dir/../another_dir/escaped_file + +echo "========= Generating tar file with absolute path starting from '/' =========" +tar --absolute-names -cvf test_tar_ext_absolute_path.tar /usr/bin/ls + +echo "========= Generating tar file with unsupported file type =========" +ln -s file1.txt link +tar -cvf test_tar_ext_unsupported_file_type.tar link + +echo "========= Generating tar file unpacked exceeds max size limit =========" +dd if=/dev/zero of=file1 bs=1M count=1 +dd if=/dev/zero of=file2 bs=1M count=1 +dd if=/dev/zero of=file3 bs=1M count=1 +tar -cvf test_tar_ext_unpacked_exceeds_max_size.tar file1 file2 file3 + +echo "========= Generating size mismatch tar file =========" +split -b 100000 test_tar_ext_unpacked_exceeds_max_size.tar test_tar_ext_file_size_mismatch. +mv test_tar_ext_file_size_mismatch.aa test_tar_ext_file_size_mismatch.tar + +echo "========= Generating incomplete tar file =========" +mv file1.txt test_tar_ext_file_incomplete.tar + +echo "========= Generating corrupted tar file =========" +cp test_tar_ext_regular.tar test_tar_ext_corrupted_file.tar +sed -i 's/file1.txt/file3.txt/g' test_tar_ext_corrupted_file.tar + +echo "========= Generating unpacking failure file =========" +cp test_tar_ext_regular.tar test_tar_ext_unpacking_failure.tar +sed -i 's/file1.txt/file.txt/g' test_tar_ext_unpacking_failure.tar diff --git a/ocaml/tests/test_tar_ext.ml b/ocaml/tests/test_tar_ext.ml new file mode 100644 index 00000000000..49cb0edb63f --- /dev/null +++ b/ocaml/tests/test_tar_ext.ml @@ -0,0 +1,162 @@ +(* + * Copyright (c) Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Helpers +open Tar_ext +open Bos + +let ( // ) = Filename.concat + +let gen_test_file_script = "test_data" // "gen_tar_ext_test_file.sh" + +let max_size_limit = 2000000L + +let create_temp_dir () = + let mktemp = Cmd.v "mktemp" in + let mktemp' = Cmd.(mktemp % "-d") in + let result = OS.Cmd.(run_out mktemp' |> to_string) in + match result with + | Ok path -> + path + | Error (`Msg s) -> + Alcotest.fail + (Printf.sprintf "Test tar_ext creating temp dir failure: %s" s) + +let test_file_dir = create_temp_dir () + +let unpack_dir = test_file_dir // "output" + +type test_case = { + description: string + ; test_file: string + ; expected: (unit, unpack_error) result +} + +let test_cases = + [ + { + description= "Test regular tar file" + ; test_file= "test_tar_ext_regular.tar" + ; expected= Ok () + } + ; { + description= "Test tar file with illegal path" + ; test_file= "test_tar_ext_illegal_path.tar" + ; expected= Error (Illegal_file_path "test_illegal_dir/../file1.txt") + } + ; { + description= "Test tar file trying to escape the current dir" + ; test_file= "current_dir" // "test_tar_ext_trying_to_escape.tar" + ; expected= + Error (Illegal_file_path "current_dir/../another_dir/escaped_file") + } + ; { + description= "Test tar file with absolute path starting from '/'" + ; test_file= "test_tar_ext_absolute_path.tar" + ; expected= Error (Illegal_file_path "/usr/bin/ls") + } + ; { + description= "Test tar file with unsupported file type" + ; test_file= "test_tar_ext_unsupported_file_type.tar" + ; expected= Error (Unsupported_file_type "Symbolic") + } + ; { + description= "Test unpacked exceeds max size limit" + ; test_file= "test_tar_ext_unpacked_exceeds_max_size.tar" + ; expected= Error (Unpacked_exceeds_max_size_limit 2000000L) + } + ; { + description= "Test unpacked file size mismatch" + ; test_file= "test_tar_ext_file_size_mismatch.tar" + ; expected= + Error + (File_size_mismatch + { + path= unpack_dir // "file1" + ; expected_size= 1048576L + ; actual_size= 99488L + } + ) + } + ; { + description= "Test file incomplete" + ; test_file= "test_tar_ext_file_incomplete.tar" + ; expected= Error File_incomplete + } + ; { + description= "Test corrupted tar file" + ; test_file= "test_tar_ext_corrupted_file.tar" + ; expected= Error File_corrupted + } + ; { + description= "Test file unpacking failure" + ; test_file= "test_tar_ext_unpacking_failure.tar" + ; expected= Error Unpacking_failure + } + ] + +let prepare_env () = + let bash = Cmd.v "bash" in + let gen = Cmd.(bash % gen_test_file_script % test_file_dir) in + let result = OS.Cmd.(run_out gen |> out_null |> success) in + match result with + | Ok () -> + () + | Error (`Msg s) -> + Alcotest.fail (Printf.sprintf "Test tar_ext preparing failure: %s" s) + +let test {test_file; expected; _} () = + let unpack () = + Unixext.with_file (test_file_dir // test_file) [Unix.O_RDONLY] 0o644 + (fun ifd -> Tar_ext.unpack_tar_file ~dir:unpack_dir ~ifd ~max_size_limit + ) + in + let result = unpack () in + match (expected, result) with + | Ok (), Ok () -> + let file1_content = Unixext.string_of_file (unpack_dir // "file1.txt") in + let file2_content = Unixext.string_of_file (unpack_dir // "file2.txt") in + Alcotest.(check string) + "Unpacking file inconsistent" "This is file-1\n" file1_content ; + Alcotest.(check string) + "Unpacking file inconsistent" "This is file-2\n" file2_content + | Error exp, Error acl -> + Alcotest.(check string) + "Unpacking Error inconsistent" + (unpack_error_to_string exp) + (unpack_error_to_string acl) + | Ok (), Error acl -> + Alcotest.fail + (Printf.sprintf + "Unpacking result inconsistent, expected: Ok, actual: %s" + (unpack_error_to_string acl) + ) + | Error exp, Ok () -> + Alcotest.fail + (Printf.sprintf + "Unpacking result inconsistent, expected: %s, actual: Success" + (unpack_error_to_string exp) + ) + +let clean_env () = Unixext.rm_rec test_file_dir + +let generate_tests case = (case.description, `Quick, test case) + +let tests = + (("prepare_env", `Quick, prepare_env) :: List.map generate_tests test_cases) + @ [("clean_env", `Quick, clean_env)] + +let () = + Suite_init.harness_init () ; + Alcotest.run "Test Tar_ext suite" [("Test_tar_ext", tests)] From ccc0f3121ae6632ca702ed2d780ab8b7658f69ba Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Thu, 18 Jul 2024 12:56:58 +0100 Subject: [PATCH 007/157] vhd-tool, xen-api-client: Remove duplicated cohttp_unbuffered_io module Signed-off-by: Andrii Sultanov --- ocaml/vhd-tool/src/cohttp_unbuffered_io.ml | 129 ---------- ocaml/vhd-tool/src/dune | 1 + ocaml/vhd-tool/src/impl.ml | 27 ++- .../lwt/cohttp_unbuffered_io.ml | 220 +++++++++--------- ocaml/xen-api-client/lwt/disk.ml | 27 ++- quality-gate.sh | 2 +- 6 files changed, 166 insertions(+), 240 deletions(-) delete mode 100644 ocaml/vhd-tool/src/cohttp_unbuffered_io.ml diff --git a/ocaml/vhd-tool/src/cohttp_unbuffered_io.ml b/ocaml/vhd-tool/src/cohttp_unbuffered_io.ml deleted file mode 100644 index aebc7c1d716..00000000000 --- a/ocaml/vhd-tool/src/cohttp_unbuffered_io.ml +++ /dev/null @@ -1,129 +0,0 @@ -(* - * Copyright (c) 2012 Citrix Inc - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - * - *) - -type 'a t = 'a Lwt.t - -let iter fn x = Lwt_list.iter_s fn x - -let return = Lwt.return - -let ( >>= ) = Lwt.bind - -let ( >> ) m n = m >>= fun _ -> n - -(** Use as few really_{read,write} calls as we can (for efficiency) without - explicitly buffering the stream beyond the HTTP headers. This will - allow us to consume the headers and then pass the file descriptor - safely to another process *) - -type ic = { - mutable header_buffer: string option (** buffered headers *) - ; mutable header_buffer_idx: int (** next char within the buffered headers *) - ; c: Channels.t -} - -let make_input c = - let header_buffer = None in - let header_buffer_idx = 0 in - {header_buffer; header_buffer_idx; c} - -type oc = Channels.t - -type conn = Channels.t - -let really_read_into c buf ofs len = - let tmp = Cstruct.create len in - c.Channels.really_read tmp >>= fun () -> - Cstruct.blit_to_bytes tmp 0 buf ofs len ; - return () - -let read_http_headers c = - let buf = Buffer.create 128 in - (* We can safely read everything up to this marker: *) - let end_of_headers = "\r\n\r\n" in - let tmp = Bytes.make (String.length end_of_headers) '\000' in - let module Scanner = struct - type t = {marker: string; mutable i: int} - - let make x = {marker= x; i= 0} - - let input x c = if c = x.marker.[x.i] then x.i <- x.i + 1 else x.i <- 0 - - let remaining x = String.length x.marker - x.i - - let matched x = x.i = String.length x.marker - end in - let marker = Scanner.make end_of_headers in - - let rec loop () = - if not (Scanner.matched marker) then ( - (* We may be part way through reading the end of header marker, so - be pessimistic and only read enough bytes to read until the end of - the marker. *) - let safe_to_read = Scanner.remaining marker in - - really_read_into c tmp 0 safe_to_read >>= fun () -> - for j = 0 to safe_to_read - 1 do - Scanner.input marker (Bytes.get tmp j) ; - Buffer.add_char buf (Bytes.get tmp j) - done ; - loop () - ) else - return () - in - loop () >>= fun () -> return (Buffer.contents buf) - -(* We assume read_line is only used to read the HTTP header *) -let rec read_line ic = - match (ic.header_buffer, ic.header_buffer_idx) with - | None, _ -> - read_http_headers ic.c >>= fun str -> - ic.header_buffer <- Some str ; - read_line ic - | Some buf, i when i < String.length buf -> ( - match Astring.String.find_sub ~start:i ~sub:"\r\n" buf with - | Some eol -> - let line = String.sub buf i (eol - i) in - ic.header_buffer_idx <- eol + 2 ; - return (Some line) - | None -> - return (Some "") - ) - | Some _, _ -> - return (Some "") - -let read_into_exactly ic buf ofs len = - really_read_into ic.c buf ofs len >>= fun () -> return true - -let read_exactly ic len = - let buf = Bytes.create len in - read_into_exactly ic buf 0 len >>= function - | true -> - return (Some buf) - | false -> - return None - -let read ic n = - let buf = Bytes.make n '\000' in - really_read_into ic.c buf 0 n >>= fun () -> return (Bytes.unsafe_to_string buf) - -let write oc x = - let buf = Cstruct.create (String.length x) in - Cstruct.blit_from_string x 0 buf 0 (String.length x) ; - oc.Channels.really_write buf - -let flush _oc = return () diff --git a/ocaml/vhd-tool/src/dune b/ocaml/vhd-tool/src/dune index 0d8436915ae..3ec83465857 100644 --- a/ocaml/vhd-tool/src/dune +++ b/ocaml/vhd-tool/src/dune @@ -30,6 +30,7 @@ tapctl xapi-stdext-std xapi-stdext-unix + xen-api-client-lwt xenstore xenstore.client xenstore.unix diff --git a/ocaml/vhd-tool/src/impl.ml b/ocaml/vhd-tool/src/impl.ml index 6e699650cfc..54058316625 100644 --- a/ocaml/vhd-tool/src/impl.ml +++ b/ocaml/vhd-tool/src/impl.ml @@ -954,6 +954,27 @@ let make_stream common source relative_to source_format destination_format = | _, _ -> assert false +module ChannelsConstrained : sig + type t = Channels.t + + type reader = Cstruct.t -> unit Lwt.t + + val really_read : t -> reader + + val really_write : t -> reader +end = struct + type t = Channels.t + + type reader = Cstruct.t -> unit Lwt.t + + let really_read x = x.Channels.really_read + + let really_write x = x.Channels.really_write +end + +module Cohttp_io_with_channels = + Xen_api_client_lwt.Cohttp_unbuffered_io.Make (ChannelsConstrained) + (** [write_stream common s destination destination_protocol prezeroed progress tar_filename_prefix ssl_legacy good_ciphersuites legacy_ciphersuites] writes the data stream [s] to [destination], using the specified @@ -1019,8 +1040,8 @@ let write_stream common s destination destination_protocol prezeroed progress Channels.of_raw_fd sock ) >>= fun c -> - let module Request = Request.Make (Cohttp_unbuffered_io) in - let module Response = Response.Make (Cohttp_unbuffered_io) in + let module Request = Request.Make (Cohttp_io_with_channels) in + let module Response = Response.Make (Cohttp_io_with_channels) in let headers = Header.init () in let k, v = Cookie.Cookie_hdr.serialize [("chunked", "true")] in let headers = Header.add headers k v in @@ -1044,7 +1065,7 @@ let write_stream common s destination destination_protocol prezeroed progress Cohttp.Request.make ~meth:`PUT ~version:`HTTP_1_1 ~headers uri' in Request.write (fun _ -> return ()) request c >>= fun () -> - Response.read (Cohttp_unbuffered_io.make_input c) >>= fun r -> + Response.read (Cohttp_io_with_channels.make_input c) >>= fun r -> match r with | `Invalid x -> fail (Failure (Printf.sprintf "Invalid HTTP response: %s" x)) diff --git a/ocaml/xen-api-client/lwt/cohttp_unbuffered_io.ml b/ocaml/xen-api-client/lwt/cohttp_unbuffered_io.ml index 935f3e85ccb..ae88acf576c 100644 --- a/ocaml/xen-api-client/lwt/cohttp_unbuffered_io.ml +++ b/ocaml/xen-api-client/lwt/cohttp_unbuffered_io.ml @@ -15,117 +15,129 @@ * *) -type 'a t = 'a Lwt.t +module type ChannelType = sig + type t -let iter fn x = Lwt_list.iter_s fn x + type reader = Cstruct.t -> unit Lwt.t -let return = Lwt.return + val really_read : t -> reader -let ( >>= ) = Lwt.bind + val really_write : t -> reader +end -let ( >> ) m n = m >>= fun _ -> n +module Make (Ch : ChannelType) = struct + type 'a t = 'a Lwt.t -(** Use as few really_{read,write} calls as we can (for efficiency) without + let iter fn x = Lwt_list.iter_s fn x + + let return = Lwt.return + + let ( >>= ) = Lwt.bind + + let ( >> ) m n = m >>= fun _ -> n + + (** Use as few really_{read,write} calls as we can (for efficiency) without explicitly buffering the stream beyond the HTTP headers. This will allow us to consume the headers and then pass the file descriptor safely to another process *) -type ic = { - mutable header_buffer: string option (** buffered headers *) - ; mutable header_buffer_idx: int (** next char within the buffered headers *) - ; c: Data_channel.t -} - -let make_input c = - let header_buffer = None in - let header_buffer_idx = 0 in - {header_buffer; header_buffer_idx; c} - -type oc = Data_channel.t - -type conn = Data_channel.t - -let really_read_into c buf ofs len = - let tmp = Cstruct.create len in - c.Data_channel.really_read tmp >>= fun () -> - Cstruct.blit_to_bytes tmp 0 buf ofs len ; - return () - -let read_http_headers c = - let buf = Buffer.create 128 in - (* We can safely read everything up to this marker: *) - let end_of_headers = "\r\n\r\n" in - let tmp = Bytes.make (String.length end_of_headers) '\000' in - let module Scanner = struct - type t = {marker: string; mutable i: int} - - let make x = {marker= x; i= 0} - - let input x c = - if c = String.get x.marker x.i then x.i <- x.i + 1 else x.i <- 0 - - let remaining x = String.length x.marker - x.i - - let matched x = x.i = String.length x.marker - (* let to_string x = Printf.sprintf "%d" x.i *) - end in - let marker = Scanner.make end_of_headers in - - let rec loop () = - if not (Scanner.matched marker) then ( - (* We may be part way through reading the end of header marker, so - be pessimistic and only read enough bytes to read until the end of - the marker. *) - let safe_to_read = Scanner.remaining marker in - - really_read_into c tmp 0 safe_to_read >>= fun () -> - for j = 0 to safe_to_read - 1 do - Scanner.input marker (Bytes.get tmp j) ; - Buffer.add_char buf (Bytes.get tmp j) - done ; - loop () - ) else - return () - in - loop () >>= fun () -> return (Buffer.contents buf) - -(* We assume read_line is only used to read the HTTP header *) -let rec read_line ic = - match (ic.header_buffer, ic.header_buffer_idx) with - | None, _ -> - read_http_headers ic.c >>= fun str -> - ic.header_buffer <- Some str ; - read_line ic - | Some buf, i when i < String.length buf -> ( - match Astring.String.find_sub ~start:i ~sub:"\r\n" buf with - | Some eol -> - let line = String.sub buf i (eol - i) in - ic.header_buffer_idx <- eol + 2 ; - return (Some line) - | None -> + type ic = { + mutable header_buffer: string option (** buffered headers *) + ; mutable header_buffer_idx: int + (** next char within the buffered headers *) + ; c: Ch.t + } + + let make_input c = + let header_buffer = None in + let header_buffer_idx = 0 in + {header_buffer; header_buffer_idx; c} + + type oc = Ch.t + + type conn = Ch.t + + let really_read_into c buf ofs len = + let tmp = Cstruct.create len in + (Ch.really_read c) tmp >>= fun () -> + Cstruct.blit_to_bytes tmp 0 buf ofs len ; + return () + + let read_http_headers c = + let buf = Buffer.create 128 in + (* We can safely read everything up to this marker: *) + let end_of_headers = "\r\n\r\n" in + let tmp = Bytes.make (String.length end_of_headers) '\000' in + let module Scanner = struct + type t = {marker: string; mutable i: int} + + let make x = {marker= x; i= 0} + + let input x c = if c = x.marker.[x.i] then x.i <- x.i + 1 else x.i <- 0 + + let remaining x = String.length x.marker - x.i + + let matched x = x.i = String.length x.marker + end in + let marker = Scanner.make end_of_headers in + + let rec loop () = + if not (Scanner.matched marker) then ( + (* We may be part way through reading the end of header marker, so + be pessimistic and only read enough bytes to read until the end of + the marker. *) + let safe_to_read = Scanner.remaining marker in + + really_read_into c tmp 0 safe_to_read >>= fun () -> + for j = 0 to safe_to_read - 1 do + Scanner.input marker (Bytes.get tmp j) ; + Buffer.add_char buf (Bytes.get tmp j) + done ; + loop () + ) else + return () + in + loop () >>= fun () -> return (Buffer.contents buf) + + (* We assume read_line is only used to read the HTTP header *) + let rec read_line ic = + match (ic.header_buffer, ic.header_buffer_idx) with + | None, _ -> + read_http_headers ic.c >>= fun str -> + ic.header_buffer <- Some str ; + read_line ic + | Some buf, i when i < String.length buf -> ( + match Astring.String.find_sub ~start:i ~sub:"\r\n" buf with + | Some eol -> + let line = String.sub buf i (eol - i) in + ic.header_buffer_idx <- eol + 2 ; + return (Some line) + | None -> + return (Some "") + ) + | Some _, _ -> return (Some "") - ) - | Some _, _ -> - return (Some "") - -let read_into_exactly ic buf ofs len = - really_read_into ic.c buf ofs len >>= fun () -> return true - -let read_exactly ic len = - let buf = Bytes.create len in - read_into_exactly ic buf 0 len >>= function - | true -> - return (Some buf) - | false -> - return None - -let read ic n = - let buf = Bytes.make n '\000' in - really_read_into ic.c buf 0 n >>= fun () -> return (Bytes.unsafe_to_string buf) - -let write oc x = - let buf = Cstruct.create (String.length x) in - Cstruct.blit_from_string x 0 buf 0 (String.length x) ; - oc.Data_channel.really_write buf - -let flush _oc = return () + + let read_into_exactly ic buf ofs len = + really_read_into ic.c buf ofs len >>= fun () -> return true + + let read_exactly ic len = + let buf = Bytes.create len in + read_into_exactly ic buf 0 len >>= function + | true -> + return (Some buf) + | false -> + return None + + let read ic n = + let buf = Bytes.make n '\000' in + really_read_into ic.c buf 0 n >>= fun () -> + return (Bytes.unsafe_to_string buf) + + let write oc x = + let buf = Cstruct.create (String.length x) in + Cstruct.blit_from_string x 0 buf 0 (String.length x) ; + (Ch.really_write oc) buf + + let flush _oc = return () +end diff --git a/ocaml/xen-api-client/lwt/disk.ml b/ocaml/xen-api-client/lwt/disk.ml index fb8f4fc9500..e17a816f94a 100644 --- a/ocaml/xen-api-client/lwt/disk.ml +++ b/ocaml/xen-api-client/lwt/disk.ml @@ -60,6 +60,27 @@ let socket sockaddr = in Lwt_unix.socket family Unix.SOCK_STREAM 0 +module DataChannelConstrained : sig + type t = Data_channel.t + + type reader = Cstruct.t -> unit Lwt.t + + val really_read : t -> reader + + val really_write : t -> reader +end = struct + type t = Data_channel.t + + type reader = Cstruct.t -> unit Lwt.t + + let really_read x = x.Data_channel.really_read + + let really_write x = x.Data_channel.really_write +end + +module Cohttp_io_with_channel = + Cohttp_unbuffered_io.Make (DataChannelConstrained) + let start_upload ~chunked ~uri = Uri_util.sockaddr_of_uri uri >>= fun (sockaddr, use_ssl) -> let sock = socket sockaddr in @@ -74,8 +95,8 @@ let start_upload ~chunked ~uri = Data_channel.of_fd ~seekable:false sock ) >>= fun c -> - let module Request = Request.Make (Cohttp_unbuffered_io) in - let module Response = Response.Make (Cohttp_unbuffered_io) in + let module Request = Request.Make (Cohttp_io_with_channel) in + let module Response = Response.Make (Cohttp_io_with_channel) in let headers = Header.init () in let k, v = Cookie.Cookie_hdr.serialize [("chunked", "true")] in let headers = if chunked then Header.add headers k v else headers in @@ -101,7 +122,7 @@ let start_upload ~chunked ~uri = Cohttp.Request.make ~meth:`PUT ~version:`HTTP_1_1 ~headers uri in Request.write (fun _ -> return ()) request c >>= fun () -> - Response.read (Cohttp_unbuffered_io.make_input c) >>= fun r -> + Response.read (Cohttp_io_with_channel.make_input c) >>= fun r -> match r with | `Eof | `Invalid _ -> fail (Failure "Unable to parse HTTP response from server") diff --git a/quality-gate.sh b/quality-gate.sh index b3cd2e67813..edc8415a473 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=515 + N=514 # do not count ml files from the tests in ocaml/{tests/perftest/quicktest} MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) From 6e5893b49452c23b32e1b6ca971a4f85f0fb08c8 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Thu, 18 Jul 2024 13:49:32 +0100 Subject: [PATCH 008/157] vhd-tool, ezxenstore: Remove duplicate xenstore module Signed-off-by: Andrii Sultanov --- ocaml/vhd-tool/src/dune | 1 + ocaml/vhd-tool/src/xenstore.ml | 100 +-------------------------------- 2 files changed, 2 insertions(+), 99 deletions(-) diff --git a/ocaml/vhd-tool/src/dune b/ocaml/vhd-tool/src/dune index 3ec83465857..dab81d82c24 100644 --- a/ocaml/vhd-tool/src/dune +++ b/ocaml/vhd-tool/src/dune @@ -11,6 +11,7 @@ cohttp cohttp-lwt cstruct + (re_export ezxenstore) io-page lwt lwt.unix diff --git a/ocaml/vhd-tool/src/xenstore.ml b/ocaml/vhd-tool/src/xenstore.ml index 603a86e8f60..b0c0dfd9e8d 100644 --- a/ocaml/vhd-tool/src/xenstore.ml +++ b/ocaml/vhd-tool/src/xenstore.ml @@ -12,102 +12,4 @@ * GNU Lesser General Public License for more details. *) -let error fmt = Printf.ksprintf (output_string stderr) fmt - -module Client = Xs_client_unix.Client (Xs_transport_unix_client) - -let make_client () = - try Client.make () - with e -> - error "Failed to connect to xenstore. The raw error was: %s" - (Printexc.to_string e) ; - ( match e with - | Unix.Unix_error (Unix.EACCES, _, _) -> - error "Access to xenstore was denied." ; - let euid = Unix.geteuid () in - if euid <> 0 then ( - error "My effective uid is %d." euid ; - error "Typically xenstore can only be accessed by root (uid 0)." ; - error "Please switch to root (uid 0) and retry." - ) - | Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> - error "Access to xenstore was refused." ; - error "This normally indicates that the service is not running." ; - error "Please start the xenstore service and retry." - | _ -> - () - ) ; - raise e - -let get_client = - let client = ref None in - fun () -> - match !client with - | None -> - let c = make_client () in - client := Some c ; - c - | Some c -> - c - -type domid = int - -module Xs = struct - type domid = int - - type xsh = { - (* - debug: string list -> string; -*) - directory: string -> string list - ; read: string -> string - ; (* - readv : string -> string list -> string list; -*) - write: string -> string -> unit - ; writev: string -> (string * string) list -> unit - ; mkdir: string -> unit - ; rm: string -> unit - ; (* - getperms : string -> perms; - setpermsv : string -> string list -> perms -> unit; - release : domid -> unit; - resume : domid -> unit; -*) - setperms: string -> Xs_protocol.ACL.t -> unit - ; getdomainpath: domid -> string - ; watch: string -> string -> unit - ; unwatch: string -> string -> unit - ; introduce: domid -> nativeint -> int -> unit - ; set_target: domid -> domid -> unit - } - - let ops h = - { - read= Client.read h - ; directory= Client.directory h - ; write= Client.write h - ; writev= - (fun base_path -> - List.iter (fun (k, v) -> Client.write h (base_path ^ "/" ^ k) v) - ) - ; mkdir= Client.mkdir h - ; rm= (fun path -> try Client.rm h path with Xs_protocol.Enoent _ -> ()) - ; setperms= Client.setperms h - ; getdomainpath= Client.getdomainpath h - ; watch= Client.watch h - ; unwatch= Client.unwatch h - ; introduce= Client.introduce h - ; set_target= Client.set_target h - } - - let with_xs f = Client.immediate (get_client ()) (fun h -> f (ops h)) - - let wait f = Client.wait (get_client ()) (fun h -> f (ops h)) - - let transaction _ f = Client.transaction (get_client ()) (fun h -> f (ops h)) -end - -module Xst = Xs - -let with_xs = Xs.with_xs +include Ezxenstore_core.Xenstore From 56ef633657d391660dd13e9b32c65683cab46e8a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 1 Jul 2024 17:19:55 +0100 Subject: [PATCH 009/157] Fix Short/Long duration printing MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi/xapi_globs.ml | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index 0c2417bb829..8b899e6d054 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -1160,15 +1160,8 @@ let options_of_xapi_globs_spec = string_of_float !x | Int x -> string_of_int !x - | ShortDurationFromSeconds x -> - let literal = - Mtime.Span.to_uint64_ns !x |> fun ns -> - Int64.div ns 1_000_000_000L |> Int64.to_int |> string_of_int - in - Fmt.str "%s (%a)" literal Mtime.Span.pp !x - | LongDurationFromSeconds x -> - let literal = Clock.Timer.span_to_s !x |> string_of_float in - Fmt.str "%s (%a)" literal Mtime.Span.pp !x + | ShortDurationFromSeconds x | LongDurationFromSeconds x -> + Fmt.str "%Luns (%a)" (Mtime.Span.to_uint64_ns !x) Mtime.Span.pp !x ) , Printf.sprintf "Set the value of '%s'" name ) From 857be9e2b25530556277ebbc5b80e4a3c738ac44 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 3 Jul 2024 17:48:38 +0100 Subject: [PATCH 010/157] forkexecd: do not clip commandline in logs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit If we want to reproduce a failure we need to know the exact commandline that was used. Longer than 80 chars is not a problem, this is a logfile, and a truncated line is worse than a long line. Signed-off-by: Edwin Török --- ocaml/forkexecd/src/child.ml | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/ocaml/forkexecd/src/child.ml b/ocaml/forkexecd/src/child.ml index ef4ad887f31..e800e8bf95f 100644 --- a/ocaml/forkexecd/src/child.ml +++ b/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 From 71c39605b3a2dd6eddeba42a5b482b4fc1b3a4e8 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 8 Jul 2024 14:14:52 +0100 Subject: [PATCH 011/157] CA-395174: Try to unarchive VM's metrics when they aren't running Non-running VMs' metrics are stored in the coordinator. When the coordinator is asked about the metrics try to unarchive them instead of failing while trying to fetch the coordinator's IP address. This needs to force the HTTP method of the query to be POST Also returns a Service Unavailable when the host is marked as Broken. Signed-off-by: Pau Ruiz Safont --- ocaml/libs/http-lib/http.ml | 7 +++++++ ocaml/libs/http-lib/http.mli | 2 ++ ocaml/xapi/rrdd_proxy.ml | 30 +++++++++++++++++++++--------- 3 files changed, 30 insertions(+), 9 deletions(-) diff --git a/ocaml/libs/http-lib/http.ml b/ocaml/libs/http-lib/http.ml index c6ff41be709..09dc4a66ed4 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -94,6 +94,13 @@ let http_501_method_not_implemented ?(version = "1.0") () = ; "Cache-Control: no-cache, no-store" ] +let http_503_service_unavailable ?(version = "1.0") () = + [ + Printf.sprintf "HTTP/%s 503 Service Unavailable" version + ; "Connection: close" + ; "Cache-Control: no-cache, no-store" + ] + module Hdr = struct let task_id = "task-id" diff --git a/ocaml/libs/http-lib/http.mli b/ocaml/libs/http-lib/http.mli index 687c4d2f8c7..384367e2463 100644 --- a/ocaml/libs/http-lib/http.mli +++ b/ocaml/libs/http-lib/http.mli @@ -189,6 +189,8 @@ val http_500_internal_server_error : ?version:string -> unit -> string list val http_501_method_not_implemented : ?version:string -> unit -> string list +val http_503_service_unavailable : ?version:string -> unit -> string list + module Hdr : sig val task_id : string (** Header used for task id *) diff --git a/ocaml/xapi/rrdd_proxy.ml b/ocaml/xapi/rrdd_proxy.ml index 68b04862f73..fdea2a40373 100644 --- a/ocaml/xapi/rrdd_proxy.ml +++ b/ocaml/xapi/rrdd_proxy.ml @@ -75,17 +75,19 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = Http_svr.headers s (Http.http_302_redirect url) in let unarchive () = - let req = {req with uri= Constants.rrd_unarchive_uri} in + let req = {req with m= Post; uri= Constants.rrd_unarchive_uri} in ignore (Xapi_services.hand_over_connection req s !Rrd_interface.forwarded_path ) in + let unavailable () = + Http_svr.headers s (Http.http_503_service_unavailable ()) + in (* List of conditions involved. *) let is_unarchive_request = List.mem_assoc Constants.rrd_unarchive query in - let is_master = Pool_role.is_master () in let is_owner_online owner = Db.is_valid_ref __context owner in let is_xapi_initialising = List.mem_assoc "dbsync" query in (* The logic. *) @@ -97,15 +99,25 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = let owner = Db.VM.get_resident_on ~__context ~self:vm_ref in let owner_uuid = Db.Host.get_uuid ~__context ~self:owner in let is_owner_localhost = owner_uuid = localhost_uuid in - if is_owner_localhost then - if is_master then + let owner_is_available = + is_owner_online owner && not is_xapi_initialising + in + match + (Pool_role.get_role (), is_owner_localhost, owner_is_available) + with + | (Master | Slave _), false, true -> + (* VM is running elsewhere *) + read_at_owner owner + | Master, true, _ | Master, false, false -> + (* VM running on node, or not running at all. *) unarchive () - else + | Slave _, true, _ | Slave _, _, false -> + (* Coordinator knows best *) unarchive_at_master () - else if is_owner_online owner && not is_xapi_initialising then - read_at_owner owner - else - unarchive_at_master () + | Broken, _, _ -> + info "%s: host is broken, VM's metrics are not available" + __FUNCTION__ ; + unavailable () ) (* Forward the request for host RRD data to the RRDD HTTP handler. If the host From 7fe19554f3dcfa99b4e72015a7c62974a4a19424 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 8 Jul 2024 14:29:40 +0100 Subject: [PATCH 012/157] rrdd_proxy: Change *_at to specify the IP address Forces users to use an address, instead of being implicit, this avoid the underlying cause for the issue fixed in the previous commit: it allowed a coordinator to call Pool_role.get_master_address, which always fails. Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/rrdd_proxy.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/ocaml/xapi/rrdd_proxy.ml b/ocaml/xapi/rrdd_proxy.ml index fdea2a40373..3ca7687f361 100644 --- a/ocaml/xapi/rrdd_proxy.ml +++ b/ocaml/xapi/rrdd_proxy.ml @@ -68,8 +68,7 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = let url = make_url ~address ~req in Http_svr.headers s (Http.http_302_redirect url) in - let unarchive_at_master () = - let address = Pool_role.get_master_address () in + let unarchive_at address = let query = (Constants.rrd_unarchive, "") :: query in let url = make_url_from_query ~address ~uri:req.uri ~query in Http_svr.headers s (Http.http_302_redirect url) @@ -111,9 +110,9 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = | Master, true, _ | Master, false, false -> (* VM running on node, or not running at all. *) unarchive () - | Slave _, true, _ | Slave _, _, false -> + | Slave coordinator, true, _ | Slave coordinator, _, false -> (* Coordinator knows best *) - unarchive_at_master () + unarchive_at coordinator | Broken, _, _ -> info "%s: host is broken, VM's metrics are not available" __FUNCTION__ ; From 6bb7702454f291db6815235c9695f41b4d6b1acf Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 8 Jul 2024 14:54:14 +0100 Subject: [PATCH 013/157] rrdd_proxy: Use Option to encode where VMs might be available at This makes the selection of the action obvious, previously the two booleans made it hazy to understand the decision, and was part of the error why the coordinator tried to get the coordinator address from the pool_role file (and failed badly) Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/rrdd_proxy.ml | 50 ++++++++++++++++++++++------------------ 1 file changed, 27 insertions(+), 23 deletions(-) diff --git a/ocaml/xapi/rrdd_proxy.ml b/ocaml/xapi/rrdd_proxy.ml index 3ca7687f361..bec5ef0f84b 100644 --- a/ocaml/xapi/rrdd_proxy.ml +++ b/ocaml/xapi/rrdd_proxy.ml @@ -63,8 +63,7 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = Xapi_http.with_context ~dummy:true "Get VM RRD." req s (fun __context -> let open Http.Request in (* List of possible actions. *) - let read_at_owner owner = - let address = Db.Host.get_address ~__context ~self:owner in + let read_at address = let url = make_url ~address ~req in Http_svr.headers s (Http.http_302_redirect url) in @@ -87,33 +86,38 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = let is_unarchive_request = List.mem_assoc Constants.rrd_unarchive query in - let is_owner_online owner = Db.is_valid_ref __context owner in - let is_xapi_initialising = List.mem_assoc "dbsync" query in + let metrics_at () = + let ( let* ) = Option.bind in + let owner_of vm = + let owner = Db.VM.get_resident_on ~__context ~self:vm in + let is_xapi_initialising = List.mem_assoc "dbsync" query in + let is_available = not is_xapi_initialising in + if Db.is_valid_ref __context owner && is_available then + Some owner + else + None + in + let* owner = owner_of (Db.VM.get_by_uuid ~__context ~uuid:vm_uuid) in + let owner_uuid = Db.Host.get_uuid ~__context ~self:owner in + if owner_uuid = Helpers.get_localhost_uuid () then + (* VM is local but metrics aren't available *) + None + else + let address = Db.Host.get_address ~__context ~self:owner in + Some address + in (* The logic. *) if is_unarchive_request then unarchive () else - let localhost_uuid = Helpers.get_localhost_uuid () in - let vm_ref = Db.VM.get_by_uuid ~__context ~uuid:vm_uuid in - let owner = Db.VM.get_resident_on ~__context ~self:vm_ref in - let owner_uuid = Db.Host.get_uuid ~__context ~self:owner in - let is_owner_localhost = owner_uuid = localhost_uuid in - let owner_is_available = - is_owner_online owner && not is_xapi_initialising - in - match - (Pool_role.get_role (), is_owner_localhost, owner_is_available) - with - | (Master | Slave _), false, true -> - (* VM is running elsewhere *) - read_at_owner owner - | Master, true, _ | Master, false, false -> - (* VM running on node, or not running at all. *) + match (Pool_role.get_role (), metrics_at ()) with + | (Master | Slave _), Some owner -> + read_at owner + | Master, None -> unarchive () - | Slave coordinator, true, _ | Slave coordinator, _, false -> - (* Coordinator knows best *) + | Slave coordinator, None -> unarchive_at coordinator - | Broken, _, _ -> + | Broken, _ -> info "%s: host is broken, VM's metrics are not available" __FUNCTION__ ; unavailable () From 110c1121f1e5faa0baba1028457819688b9a290e Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 18 Jul 2024 08:47:06 +0100 Subject: [PATCH 014/157] http-lib: avoid double-queries to the radix tree Signed-off-by: Pau Ruiz Safont --- ocaml/libs/http-lib/http_svr.ml | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index d8718bd68a6..26ad35f712f 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -41,6 +41,8 @@ open D module E = Debug.Make (struct let name = "http_internal_errors" end) +let ( let* ) = Option.bind + type uri_path = string module Stats = struct @@ -296,10 +298,7 @@ module Server = struct let add_handler x ty uri handler = let existing = - if MethodMap.mem ty x.handlers then - MethodMap.find ty x.handlers - else - Radix_tree.empty + Option.value (MethodMap.find_opt ty x.handlers) ~default:Radix_tree.empty in x.handlers <- MethodMap.add ty @@ -307,11 +306,9 @@ module Server = struct x.handlers let find_stats x m uri = - if not (MethodMap.mem m x.handlers) then - None - else - let rt = MethodMap.find m x.handlers in - Option.map (fun te -> te.TE.stats) (Radix_tree.longest_prefix uri rt) + let* rt = MethodMap.find_opt m x.handlers in + let* te = Radix_tree.longest_prefix uri rt in + Some te.TE.stats let all_stats x = let open Radix_tree in From 3658806b80ec5f17032fd3b242e98560cc28a5c4 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 19 Jul 2024 13:06:16 +0100 Subject: [PATCH 015/157] rrdd_proxy: Return 400 on bad vm request Currently a List.assoc is used, which raises an unhandled exception. Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/rrdd_proxy.ml | 130 +++++++++++++++++++-------------------- 1 file changed, 63 insertions(+), 67 deletions(-) diff --git a/ocaml/xapi/rrdd_proxy.ml b/ocaml/xapi/rrdd_proxy.ml index bec5ef0f84b..a824f77f23a 100644 --- a/ocaml/xapi/rrdd_proxy.ml +++ b/ocaml/xapi/rrdd_proxy.ml @@ -51,76 +51,72 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ = debug "put_rrd_forwarder: start" ; let query = req.Http.Request.query in req.Http.Request.close <- true ; - let vm_uuid = List.assoc "uuid" query in - if (not (List.mem_assoc "ref" query)) && not (List.mem_assoc "uuid" query) - then - fail_req_with s "get_vm_rrd: missing the 'uuid' parameter" - Http.http_400_badrequest - else if Rrdd.has_vm_rrd vm_uuid then - ignore - (Xapi_services.hand_over_connection req s !Rrd_interface.forwarded_path) - else - Xapi_http.with_context ~dummy:true "Get VM RRD." req s (fun __context -> - let open Http.Request in - (* List of possible actions. *) - let read_at address = - let url = make_url ~address ~req in - Http_svr.headers s (Http.http_302_redirect url) - in - let unarchive_at address = - let query = (Constants.rrd_unarchive, "") :: query in - let url = make_url_from_query ~address ~uri:req.uri ~query in - Http_svr.headers s (Http.http_302_redirect url) - in - let unarchive () = - let req = {req with m= Post; uri= Constants.rrd_unarchive_uri} in - ignore - (Xapi_services.hand_over_connection req s - !Rrd_interface.forwarded_path - ) - in - let unavailable () = - Http_svr.headers s (Http.http_503_service_unavailable ()) - in - (* List of conditions involved. *) - let is_unarchive_request = - List.mem_assoc Constants.rrd_unarchive query - in - let metrics_at () = - let ( let* ) = Option.bind in - let owner_of vm = - let owner = Db.VM.get_resident_on ~__context ~self:vm in - let is_xapi_initialising = List.mem_assoc "dbsync" query in - let is_available = not is_xapi_initialising in - if Db.is_valid_ref __context owner && is_available then - Some owner - else - None - in - let* owner = owner_of (Db.VM.get_by_uuid ~__context ~uuid:vm_uuid) in - let owner_uuid = Db.Host.get_uuid ~__context ~self:owner in - if owner_uuid = Helpers.get_localhost_uuid () then - (* VM is local but metrics aren't available *) - None + match List.assoc_opt "uuid" query with + | None -> + fail_req_with s "get_vm_rrd: missing the 'uuid' parameter" + Http.http_400_badrequest + | Some vm_uuid when Rrdd.has_vm_rrd vm_uuid -> + ignore + (Xapi_services.hand_over_connection req s !Rrd_interface.forwarded_path) + | Some vm_uuid -> ( + Xapi_http.with_context ~dummy:true "Get VM RRD." req s @@ fun __context -> + (* List of possible actions. *) + let read_at address = + let url = make_url ~address ~req in + Http_svr.headers s (Http.http_302_redirect url) + in + let unarchive_at address = + let query = (Constants.rrd_unarchive, "") :: query in + let url = make_url_from_query ~address ~uri:req.uri ~query in + Http_svr.headers s (Http.http_302_redirect url) + in + let unarchive () = + let req = {req with m= Post; uri= Constants.rrd_unarchive_uri} in + ignore + (Xapi_services.hand_over_connection req s + !Rrd_interface.forwarded_path + ) + in + let unavailable () = + Http_svr.headers s (Http.http_503_service_unavailable ()) + in + (* List of conditions involved. *) + let is_unarchive_request = List.mem_assoc Constants.rrd_unarchive query in + let metrics_at () = + let ( let* ) = Option.bind in + let owner_of vm = + let owner = Db.VM.get_resident_on ~__context ~self:vm in + let is_xapi_initialising = List.mem_assoc "dbsync" query in + let is_available = not is_xapi_initialising in + if Db.is_valid_ref __context owner && is_available then + Some owner else - let address = Db.Host.get_address ~__context ~self:owner in - Some address + None in - (* The logic. *) - if is_unarchive_request then - unarchive () + let* owner = owner_of (Db.VM.get_by_uuid ~__context ~uuid:vm_uuid) in + let owner_uuid = Db.Host.get_uuid ~__context ~self:owner in + if owner_uuid = Helpers.get_localhost_uuid () then + (* VM is local but metrics aren't available *) + None else - match (Pool_role.get_role (), metrics_at ()) with - | (Master | Slave _), Some owner -> - read_at owner - | Master, None -> - unarchive () - | Slave coordinator, None -> - unarchive_at coordinator - | Broken, _ -> - info "%s: host is broken, VM's metrics are not available" - __FUNCTION__ ; - unavailable () + let address = Db.Host.get_address ~__context ~self:owner in + Some address + in + (* The logic. *) + if is_unarchive_request then + unarchive () + else + match (Pool_role.get_role (), metrics_at ()) with + | (Master | Slave _), Some owner -> + read_at owner + | Master, None -> + unarchive () + | Slave coordinator, None -> + unarchive_at coordinator + | Broken, _ -> + info "%s: host is broken, VM's metrics are not available" + __FUNCTION__ ; + unavailable () ) (* Forward the request for host RRD data to the RRDD HTTP handler. If the host From c60e482b196d7c4dea6eb34e6cec6dae54d89ce1 Mon Sep 17 00:00:00 2001 From: Alex Brett Date: Tue, 16 Jul 2024 11:18:59 +0000 Subject: [PATCH 016/157] CA-394148: Fix dry-run handling in xe-restore-metadata Shell quoting changes in xen-api.git 65f152de687229946eaea6ddcaa5e3d0a11b2b01 broke the dry-run functionality, as by quoting parameters in the way it was done it meant the space separation was not properly handled to separate parameters etc. Signed-off-by: Alex Brett --- scripts/xe-restore-metadata | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scripts/xe-restore-metadata b/scripts/xe-restore-metadata index 093cd772192..e3bd471e5e2 100755 --- a/scripts/xe-restore-metadata +++ b/scripts/xe-restore-metadata @@ -319,8 +319,8 @@ else fi shopt -s nullglob for meta in *.vmmeta; do - echo xe vm-import filename="${meta}" sr-uuid="${sr_uuid}" --metadata --preserve"${force_flag}""${dry_run_flag}" - "@OPTDIR@/bin/xe" vm-import filename="${full_dir}/${meta}" sr-uuid="${sr_uuid}" --metadata --preserve"${force_flag}""${dry_run_flag}" + echo xe vm-import filename="${meta}" sr-uuid="${sr_uuid}" --metadata --preserve${force_flag}${dry_run_flag} + "@OPTDIR@/bin/xe" vm-import filename="${full_dir}/${meta}" sr-uuid="${sr_uuid}" --metadata --preserve${force_flag}${dry_run_flag} if [ $? -gt 0 ]; then error_count=$(( $error_count + 1 )) else From 0270f25479bdc9be47ea44b22b94ecfbdf6a6257 Mon Sep 17 00:00:00 2001 From: Alex Brett Date: Tue, 16 Jul 2024 11:20:20 +0000 Subject: [PATCH 017/157] CA-393578: Fix vbd cleanup in metadata scripts The xe-[backup,restore]-metadata scripts have cleanup logic designed to ensure we do not leave any vbd objects etc behind. This logic calls `vbd-unplug` with a 20s timeout, and then (regardless of the result) allows up to 10s for any device specified in the VBD to disappear - if it does not, it does not trigger a `vbd-destroy`. This logic fails in the case where a VDI is attached to a VM running on the same host, as the `device` field in the new VBD will be populated with the backend device for the running VM. In this case, the `vbd-unplug` fails immediately (as the vbd is not plugged because the original `vbd-plug` attempt fails as the VDI is in use), but then we sit waiting for 10s for the device to disappear (which is obviously does not), and then fail to trigger a `vbd-destroy`, leaving the VBD behind. Fix this by simply removing the wait for the device to disappear and always attempting a `vbd-destroy`, as I am not aware of any situation where this additional 10s wait will give any benefit given current behaviours. Signed-off-by: Alex Brett --- scripts/xe-backup-metadata | 21 ++------------------- scripts/xe-restore-metadata | 23 +++-------------------- 2 files changed, 5 insertions(+), 39 deletions(-) diff --git a/scripts/xe-backup-metadata b/scripts/xe-backup-metadata index 47b21108b9d..86495047b03 100755 --- a/scripts/xe-backup-metadata +++ b/scripts/xe-backup-metadata @@ -135,25 +135,8 @@ function cleanup { if [ ! -z "${vbd_uuid}" ]; then ${debug} echo -n "Unplugging VBD: " ${XE} vbd-unplug uuid="${vbd_uuid}" timeout=20 - # poll for the device to go away if we know its name - if [ "${device}" != "" ]; then - device_gone=0 - for ((i=0; i<10; i++)); do - ${debug} echo -n "." - if [ ! -b "${device}" ]; then - ${debug} echo " done" - device_gone=1 - break - fi - sleep 1 - done - if [ ${device_gone} -eq 0 ]; then - ${debug} echo " failed" - echo "Please destroy VBD ${vbd_uuid} manually." - else - ${XE} vbd-destroy uuid="${vbd_uuid}" - fi - fi + ${debug} echo -n "Destroying VBD: " + ${XE} vbd-destroy uuid="${vbd_uuid}" fi if [ ${fs_uninitialised} -eq 1 -a -n "${vdi_uuid}" ] ; then ${XE} vdi-destroy uuid="${vdi_uuid}" diff --git a/scripts/xe-restore-metadata b/scripts/xe-restore-metadata index e3bd471e5e2..ebfb745887f 100755 --- a/scripts/xe-restore-metadata +++ b/scripts/xe-restore-metadata @@ -131,26 +131,9 @@ function cleanup { if [ ! -z "${vbd_uuid}" ]; then ${debug} echo -n "Unplugging VBD: " >&2 ${XE} vbd-unplug uuid="${vbd_uuid}" timeout=20 - # poll for the device to go away if we know its name - if [ "${device}" != "" ]; then - device_gone=0 - for ((i=0; i<10; i++)); do - ${debug} echo -n "." >&2 - if [ ! -b "${device}" ]; then - ${debug} echo " done" >&2 - device_gone=1 - break - fi - sleep 1 - done - if [ ${device_gone} -eq 0 ]; then - ${debug} echo " failed" >&2 - ${debug} echo "Please destroy VBD ${vbd_uuid} manually." >&2 - else - ${XE} vbd-destroy uuid="${vbd_uuid}" - vbd_uuid="" - fi - fi + ${debug} echo -n "Destroying VBD: " >&2 + ${XE} vbd-destroy uuid="${vbd_uuid}" + vbd_uuid="" device="" fi } From 6fb77381c04c3b3efd354d1fb4cbc294fb336973 Mon Sep 17 00:00:00 2001 From: Alejandro Vallejo Date: Mon, 25 Sep 2023 14:45:27 +0000 Subject: [PATCH 018/157] CA-383491: [Security fix] Use debugfs on xe-restore-metadata probes This patch makes the feature use the debugfs utility, part of e2fsprogs. This makes the system as a whole a heck of a lot better, if only because it won't be able to parse XFS, ReiserFS or any of the many plugins of libfsimage. Signed-off-by: Alejandro Vallejo --- scripts/Makefile | 1 - scripts/probe-device-for-file | 56 ----------------------------------- scripts/xe-restore-metadata | 17 +++++++---- 3 files changed, 11 insertions(+), 63 deletions(-) delete mode 100755 scripts/probe-device-for-file diff --git a/scripts/Makefile b/scripts/Makefile index 18e923c69fa..b47c36f5358 100644 --- a/scripts/Makefile +++ b/scripts/Makefile @@ -121,7 +121,6 @@ install: $(IPROG) print-custom-templates $(DESTDIR)$(LIBEXECDIR) $(IPROG) backup-sr-metadata.py $(DESTDIR)$(LIBEXECDIR) $(IPROG) restore-sr-metadata.py $(DESTDIR)$(LIBEXECDIR) - $(IPROG) probe-device-for-file $(DESTDIR)$(LIBEXECDIR) $(IPROG) backup-metadata-cron $(DESTDIR)$(LIBEXECDIR) $(IPROG) pbis-force-domain-leave $(DESTDIR)$(LIBEXECDIR) mkdir -p $(DESTDIR)/etc/sysconfig diff --git a/scripts/probe-device-for-file b/scripts/probe-device-for-file deleted file mode 100755 index be07f40758f..00000000000 --- a/scripts/probe-device-for-file +++ /dev/null @@ -1,56 +0,0 @@ -#!/usr/bin/env python3 -# (c) Anil Madhavapeddy, Citrix Systems Inc, 2008 -# Checks for the existence of a file on a device - -import os, sys -try: - import xenfsimage -except ImportError: - import fsimage as xenfsimage -from contextlib import contextmanager - -# https://stackoverflow.com/a/17954769 -@contextmanager -def stderr_redirected(to=os.devnull): - ''' - import os - - with stderr_redirected(to=filename): - print("from Python") - os.system("echo non-Python applications are also supported") - ''' - fd = sys.stderr.fileno() - - ##### assert that Python and C stdio write using the same file descriptor - ####assert libc.fileno(ctypes.c_void_p.in_dll(libc, "stderr")) == fd == 1 - - def _redirect_stderr(to): - sys.stderr.close() # + implicit flush() - os.dup2(to.fileno(), fd) # fd writes to 'to' file - sys.stderr = os.fdopen(fd, 'w') # Python writes to fd - - with os.fdopen(os.dup(fd), 'w') as old_stderr: - with open(to, 'w') as file: - _redirect_stderr(to=file) - try: - yield # allow code to be run with the redirected stderr - finally: - _redirect_stderr(to=old_stderr) # restore stderr. - # buffering and flags such as - # CLOEXEC may be different - -if __name__ == "__main__": - if len(sys.argv) != 3: - print("Usage: %s " % sys.argv[0]) - sys.exit(2) - device = sys.argv[1] - file = sys.argv[2] - try: - # CA-316241 - fsimage prints to stderr - with stderr_redirected(to="/dev/null"): - fs = xenfsimage.open(device, 0) - if fs.file_exists(file): - os._exit(0) - except: - pass - os._exit(1) diff --git a/scripts/xe-restore-metadata b/scripts/xe-restore-metadata index ebfb745887f..35fa50b649a 100755 --- a/scripts/xe-restore-metadata +++ b/scripts/xe-restore-metadata @@ -2,6 +2,14 @@ # Script which restores metadata into a VDI # Citrix Systems Inc, 2008 +function file_exists() { + local out + out="$(debugfs -R "stat $2" "$1" 2>/dev/null | head -n1 | grep "Type: regular")" + if [ -n "${out}" ]; then + echo y + fi +} + if [ ! -e @INVENTORY@ ]; then echo Must run on a XAPI host. exit 1 @@ -178,22 +186,19 @@ for vdi_uuid in ${vdis}; do ${debug} echo "${device}" >&2 ${debug} echo -n "Probing device: " >&2 - probecmd="@LIBEXECDIR@/probe-device-for-file" - metadata_stamp="/.ctxs-metadata-backup" mnt= - ${probecmd} "${device}" "${metadata_stamp}" - if [ $? -eq 0 ]; then + if [ "$(file_exists "${device}" "/.ctxs-metadata-backup")" = y ]; then ${debug} echo "found metadata backup" >&2 ${debug} echo -n "Mounting filesystem: " >&2 mnt="/var/run/pool-backup-${vdi_uuid}" mkdir -p "${mnt}" - /sbin/fsck -a "${device}" >/dev/null 2>&1 + /sbin/e2fsck -p -f "${device}" >/dev/null 2>&1 if [ $? -ne 0 ]; then echo "File system integrity error. Please correct manually." >&2 cleanup continue fi - mount "${device}" "${mnt}" >/dev/null 2>&1 + mount -o ro,nosuid,noexec,nodev "${device}" "${mnt}" >/dev/null 2>&1 if [ $? -ne 0 ]; then ${debug} echo failed >&2 cleanup From f51cb8cbe30704a58a1cc6af91838092de326e3c Mon Sep 17 00:00:00 2001 From: Alex Brett Date: Tue, 16 Jul 2024 11:26:40 +0000 Subject: [PATCH 019/157] Updates to Portable SR Functionality Add a new option `-o` to xe-restore-metadata, which is used to distinguish whether to allow use of legacy backup VDIs, or enforce only use of the new format VDIs with known UUIDs. Also modify xe-restore-metadata such that it no longer stops searching the candidate list if only one VDI is found, but instead identifies all possible backup VDIs. If more than one is found, and you are doing anything other than listing the VDIs, the script will abort. This is to cover the case where a malicious legacy format VDI is present - we will detect it and the expected 'real' backup VDI. Modify xe-backup-metadata to always expect to use the deterministic UUID to identify the VDI to add backups to, do not rely on the `other-config:ctxs-pool-backup` property for identification in any way. This is XSA-459 / CVE-2024-31144 Signed-off-by: Alex Brett --- scripts/xe-backup-metadata | 32 +------ scripts/xe-restore-metadata | 161 ++++++++++++++++++++++++------------ 2 files changed, 110 insertions(+), 83 deletions(-) diff --git a/scripts/xe-backup-metadata b/scripts/xe-backup-metadata index 86495047b03..9aac72573e9 100755 --- a/scripts/xe-backup-metadata +++ b/scripts/xe-backup-metadata @@ -55,23 +55,6 @@ function uuid5 { python -c "import uuid; print (uuid.uuid5(uuid.UUID('$1'), '$2'))" } -function validate_vdi_uuid { - # we check that vdi has the expected UUID which depends on the UUID of - # the SR. This is a deterministic hash of the SR UUID and the - # namespace UUID $NS. This UUID must match what Xapi's Uuidx module is using. - local NS="e93e0639-2bdb-4a59-8b46-352b3f408c19" - local sr="$1" - local vdi="$2" - local uuid - - uuid=$(uuid5 "$NS" "$sr") - if [ "$vdi" != "$uuid" ]; then - return 1 - else - return 0 - fi -} - function test_sr { sr_uuid_found=$(${XE} sr-list uuid="$1" --minimal) if [ "${sr_uuid_found}" != "$1" ]; then @@ -120,8 +103,8 @@ fi test_sr "${sr_uuid}" sr_name=$(${XE} sr-param-get uuid="${sr_uuid}" param-name=name-label) -# see if a backup VDI already exists on the selected SR -vdi_uuid=$(${XE} vdi-list other-config:ctxs-pool-backup=true sr-uuid="${sr_uuid}" params=uuid --minimal) +# assume use of the new format predictable UUID +vdi_uuid=$(${XE} vdi-list uuid="$(uuid5 "e93e0639-2bdb-4a59-8b46-352b3f408c19" "$sr_uuid")" --minimal) mnt= function cleanup { @@ -143,17 +126,6 @@ function cleanup { fi } -# if we can't validate the UUID of the VDI, prompt the user -if [ -n "${vdi_uuid}" ]; then - if ! validate_vdi_uuid "${sr_uuid}" "${vdi_uuid}" && [ "$yes" -eq 0 ]; then - echo "Backup VDI $vdi_uuid was most likley create by an earlier" - echo "version of this code. Make sure this is a VDI that you" - echo "created as we can't validate it without mounting it." - read -p "Continue? [Y/N]" -n 1 -r; echo - if [[ ! $REPLY =~ ^[Yy]$ ]]; then exit 1; fi - fi -fi - echo "Using SR: ${sr_name}" if [ -z "${vdi_uuid}" ]; then if [ "${create_vdi}" -gt 0 ]; then diff --git a/scripts/xe-restore-metadata b/scripts/xe-restore-metadata index 35fa50b649a..008c737358e 100755 --- a/scripts/xe-restore-metadata +++ b/scripts/xe-restore-metadata @@ -35,11 +35,11 @@ default_restore_mode="all" debug="/bin/true" function usage { - echo "Usage: $0 [-h] [-v] [-y] [-n] [-p] [-f] [-x ] [-u ] [-m all|sr]" + echo "Usage: $0 [-h] [-v] [-y] [-n] [-p] [-f] [-o] [-x ] [-u ] [-m all|sr]" echo echo " -h: Display this help message" echo " -x: Specify the VDI UUID to override probing" - echo " -p: Just scan for a metadata VDI and print out its UUID to stdout" + echo " -p: Just scan for metadata VDI(s) and print out UUID(s) to stdout" echo " -u: UUID of the SR you wish to restore from" echo " -n: Perform a dry run of the metadata import commands (default: false)" echo " -l: Just list the available backup dates" @@ -48,6 +48,7 @@ function usage { echo " -v: Verbose output" echo " -y: Assume non-interactive mode and yes to all questions" echo " -f: Forcibly restore VM metadata, dangerous due to its destructive nature, please always do a dry run before using this (default: false)" + echo " -o: Allow use of legacy backup VDIs (this should not be used with SRs with untrusted VDIs)" echo exit 1 } @@ -75,7 +76,9 @@ just_probe=0 chosen_date="" restore_mode=${default_restore_mode} force=0 -while getopts "yhpvx:d:lnu:m:f" opt ; do +legacy=0 +specified_vdi= +while getopts "yhpvx:d:lnu:m:fo" opt ; do case $opt in h) usage ;; u) sr_uuid=${OPTARG} ;; @@ -85,9 +88,10 @@ while getopts "yhpvx:d:lnu:m:f" opt ; do v) debug="" ;; d) chosen_date=${OPTARG} ;; m) restore_mode=${OPTARG} ;; - x) vdis=${OPTARG} ;; + x) specified_vdi=${OPTARG} ;; y) yes=1 ;; f) force=1 ;; + o) legacy=1 ;; *) echo "Invalid option"; usage ;; esac done @@ -118,16 +122,75 @@ sr_name=$(${XE} sr-param-get uuid="${sr_uuid}" param-name=name-label) # probe first for a VDI with known UUID derived from the SR to avoid # scanning for a VDI backup_vdi=$(uuid5 "${NS}" "${sr_uuid}") -if [ -z "${vdis}" ]; then - vdis=$(${XE} vdi-list uuid="${backup_vdi}" sr-uuid="${sr_uuid}" read-only=false --minimal) + +# Only allow a specified VDI that does not match the known UUID if operating in +# legacy mode +if [ -n "${specified_vdi}" ]; then + if [ "${specified_vdi}" != "${backup_vdi}" ] && [ "$legacy" -eq 0 ]; then + echo "The specified VDI UUID is not permitted, if attempting to use a legacy backup VDI please use the -o flag" >&2 + exit 1 + fi + vdis=${specified_vdi} fi -# get a list of all VDIs if an override has not been provided on the cmd line if [ -z "${vdis}" ]; then - vdis=$(${XE} vdi-list params=uuid sr-uuid="${sr_uuid}" read-only=false --minimal) + if [ "$legacy" -eq 0 ]; then + # In non-legacy mode, only use the known backup_vdi UUID + vdis=$(${XE} vdi-list uuid="${backup_vdi}" sr-uuid="${sr_uuid}" read-only=false --minimal) + else + # In legacy mode, scan all VDIs + vdis=$(${XE} vdi-list params=uuid sr-uuid="${sr_uuid}" read-only=false --minimal) + fi fi mnt= +vdi_uuid= +vbd_uuid= +device= +function createvbd { + ${debug} echo -n "Creating VBD: " >&2 + vbd_uuid=$(${XE} vbd-create vm-uuid="${CONTROL_DOMAIN_UUID}" vdi-uuid="${vdi_uuid}" device=autodetect 2>/dev/null) + + if [ $? -ne 0 -o -z "${vbd_uuid}" ]; then + ${debug} echo "error creating VBD for VDI ${vdi_uuid}" >&2 + cleanup + return 1 + fi + + ${debug} echo "${vbd_uuid}" >&2 + + ${debug} echo -n "Plugging VBD: " >&2 + ${XE} vbd-plug uuid="${vbd_uuid}" + device=/dev/$(${XE} vbd-param-get uuid="${vbd_uuid}" param-name=device) + + if [ ! -b "${device}" ]; then + ${debug} echo "${device}: not a block special" >&2 + cleanup + return 1 + fi + + ${debug} echo "${device}" >&2 + return 0 +} + +function mountvbd { + mnt="/var/run/pool-backup-${vdi_uuid}" + mkdir -p "${mnt}" + /sbin/fsck -a "${device}" >/dev/null 2>&1 + if [ $? -ne 0 ]; then + echo "File system integrity error. Please correct manually." >&2 + cleanup + return 1 + fi + mount "${device}" "${mnt}" >/dev/null 2>&1 + if [ $? -ne 0 ]; then + ${debug} echo failed >&2 + cleanup + return 1 + fi + return 0 +} + function cleanup { cd / if [ ! -z "${mnt}" ]; then @@ -148,66 +211,34 @@ function cleanup { if [ -z "${vdis}" ]; then echo "No VDIs found on SR." >&2 + if [ "$legacy" -eq 0 ]; then + echo "If you believe there may be a legacy backup VDI present, you can use the -o flag to search for it (this should not be used with untrusted VDIs)" >&2 + fi exit 0 fi trap cleanup SIGINT ERR +declare -a matched_vdis for vdi_uuid in ${vdis}; do - if [ "${vdi_uuid}" != "${backup_vdi}" ] && [ "$yes" -eq 0 ]; then - echo "Probing VDI ${vdi_uuid}." - echo "This VDI was created with a prior version of this code." - echo "Its validity can't be checked without mounting it first." - read -p "Continue? [Y/N]" -n 1 -r; echo - if [[ ! $REPLY =~ ^[Yy]$ ]]; then exit 1; fi - fi - - ${debug} echo -n "Creating VBD: " >&2 - vbd_uuid=$(${XE} vbd-create vm-uuid="${CONTROL_DOMAIN_UUID}" vdi-uuid="${vdi_uuid}" device=autodetect 2>/dev/null) - - if [ $? -ne 0 -o -z "${vbd_uuid}" ]; then - ${debug} echo "error creating VBD for VDI ${vdi_uuid}" >&2 - cleanup - continue - fi - - ${debug} echo "${vbd_uuid}" >&2 - - ${debug} echo -n "Plugging VBD: " >&2 - ${XE} vbd-plug uuid="${vbd_uuid}" - device=/dev/$(${XE} vbd-param-get uuid="${vbd_uuid}" param-name=device) - - if [ ! -b "${device}" ]; then - ${debug} echo "${device}: not a block special" >&2 - cleanup + createvbd + if [ $? -ne 0 ]; then continue fi - ${debug} echo "${device}" >&2 - ${debug} echo -n "Probing device: " >&2 mnt= if [ "$(file_exists "${device}" "/.ctxs-metadata-backup")" = y ]; then ${debug} echo "found metadata backup" >&2 ${debug} echo -n "Mounting filesystem: " >&2 - mnt="/var/run/pool-backup-${vdi_uuid}" - mkdir -p "${mnt}" - /sbin/e2fsck -p -f "${device}" >/dev/null 2>&1 + mountvbd if [ $? -ne 0 ]; then - echo "File system integrity error. Please correct manually." >&2 - cleanup continue fi - mount -o ro,nosuid,noexec,nodev "${device}" "${mnt}" >/dev/null 2>&1 - if [ $? -ne 0 ]; then - ${debug} echo failed >&2 - cleanup - else - if [ -e "${mnt}/.ctxs-metadata-backup" ]; then - ${debug} echo "Found backup metadata on VDI: ${vdi_uuid}" >&2 - xe vdi-param-set uuid="${vdi_uuid}" other-config:ctxs-pool-backup=true - break - fi + + if [ -e "${mnt}/.ctxs-metadata-backup" ]; then + ${debug} echo "Found backup metadata on VDI: ${vdi_uuid}" >&2 + matched_vdis+=( ${vdi_uuid} ) fi else ${debug} echo "backup metadata not found" >&2 @@ -216,11 +247,35 @@ for vdi_uuid in ${vdis}; do done if [ $just_probe -gt 0 ]; then - echo "${vdi_uuid}" - cleanup + for vdi_uuid in "${matched_vdis[@]}"; do + echo "${vdi_uuid}" + done exit 0 fi +if [ "${#matched_vdis[@]}" -eq 0 ]; then + echo "Metadata backups not found." >&2 + exit 1 +fi + +if [ "${#matched_vdis[@]}" -gt 1 ]; then + echo "Multiple metadata backups found, please use -x to specify the VDI UUID to use" >&2 + exit 1 +fi + +vdi_uuid=${matched_vdis[0]} +xe vdi-param-set uuid="${vdi_uuid}" other-config:ctxs-pool-backup=true +createvbd +if [ $? -ne 0 ]; then + echo "Failure creating VBD for backup VDI ${vdi_uuid}" >&2 + exit 1 +fi +mountvbd +if [ $? -ne 0 ]; then + echo "Failure mounting backup VDI ${vdi_uuid}" >&2 + exit 1 +fi + cd "${mnt}" ${debug} echo "" >&2 From 0a11d0b63985c5ce691a6d6e365a450d8f9d079e Mon Sep 17 00:00:00 2001 From: Alex Brett Date: Tue, 16 Jul 2024 12:45:30 +0000 Subject: [PATCH 020/157] Fixes for shellcheck - Quote a parameter - Adjust how we check the returncode of some function calls to satifsy shellcheck - Disable the warnings where we are explicitly relying on string splitting Signed-off-by: Alex Brett --- scripts/xe-restore-metadata | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/scripts/xe-restore-metadata b/scripts/xe-restore-metadata index 008c737358e..5968dc102e8 100755 --- a/scripts/xe-restore-metadata +++ b/scripts/xe-restore-metadata @@ -231,14 +231,13 @@ for vdi_uuid in ${vdis}; do if [ "$(file_exists "${device}" "/.ctxs-metadata-backup")" = y ]; then ${debug} echo "found metadata backup" >&2 ${debug} echo -n "Mounting filesystem: " >&2 - mountvbd - if [ $? -ne 0 ]; then + if ! mountvbd; then continue fi if [ -e "${mnt}/.ctxs-metadata-backup" ]; then ${debug} echo "Found backup metadata on VDI: ${vdi_uuid}" >&2 - matched_vdis+=( ${vdi_uuid} ) + matched_vdis+=( "${vdi_uuid}" ) fi else ${debug} echo "backup metadata not found" >&2 @@ -265,13 +264,11 @@ fi vdi_uuid=${matched_vdis[0]} xe vdi-param-set uuid="${vdi_uuid}" other-config:ctxs-pool-backup=true -createvbd -if [ $? -ne 0 ]; then +if ! createvbd; then echo "Failure creating VBD for backup VDI ${vdi_uuid}" >&2 exit 1 fi -mountvbd -if [ $? -ne 0 ]; then +if ! mountvbd; then echo "Failure mounting backup VDI ${vdi_uuid}" >&2 exit 1 fi @@ -362,9 +359,10 @@ else fi shopt -s nullglob for meta in *.vmmeta; do + # shellcheck disable=SC2086 echo xe vm-import filename="${meta}" sr-uuid="${sr_uuid}" --metadata --preserve${force_flag}${dry_run_flag} - "@OPTDIR@/bin/xe" vm-import filename="${full_dir}/${meta}" sr-uuid="${sr_uuid}" --metadata --preserve${force_flag}${dry_run_flag} - if [ $? -gt 0 ]; then + # shellcheck disable=SC2086 + if ! "@OPTDIR@/bin/xe" vm-import filename="${full_dir}/${meta}" sr-uuid="${sr_uuid}" --metadata --preserve${force_flag}${dry_run_flag}; then error_count=$(( $error_count + 1 )) else good_count=$(( $good_count + 1 )) From 21899964974fff772cc2c1494e0cf17e5066197d Mon Sep 17 00:00:00 2001 From: Alex Brett Date: Fri, 19 Jul 2024 13:58:30 +0000 Subject: [PATCH 021/157] Remove unused `yes` parameter in xe-backup-metadata This parameter was added in 7f1d315135651a84d39f0512fc433f28f3bdba33, but the changes to always use the new metadata VDIs with known UUIDs means it is no longer required, so remove it. Signed-off-by: Alex Brett --- scripts/xe-backup-metadata | 3 --- 1 file changed, 3 deletions(-) diff --git a/scripts/xe-backup-metadata b/scripts/xe-backup-metadata index 9aac72573e9..43c4617ec3b 100755 --- a/scripts/xe-backup-metadata +++ b/scripts/xe-backup-metadata @@ -39,7 +39,6 @@ function usage { echo " -k: Number of older backups to preserve (default: ${history_kept})" echo " -n: Just try to find a backup VDI and stop the script after that" echo " -f Force backup even when less than 10% free capacity is left on the backup VDI" - echo " -y: Assume non-interactive mode and yes to all questions" echo " -v: Verbose output" echo echo @@ -70,7 +69,6 @@ just_find_vdi=0 fs_uninitialised=0 usage_alert=90 force_backup=0 -yes=0 while getopts "yhvink:u:dcf" opt ; do case $opt in h) usage ;; @@ -81,7 +79,6 @@ while getopts "yhvink:u:dcf" opt ; do d) leave_mounted=1 ;; n) just_find_vdi=1 ;; v) debug="" ;; - y) yes=1 ;; f) force_backup=1 ;; *) echo "Invalid option"; usage ;; esac From 4c77a5e2e8a12021fbb789cb7acac6a1054de288 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Mon, 22 Jul 2024 09:45:09 +0100 Subject: [PATCH 022/157] IH-662: Add tests for Helpers.filter_args Signed-off-by: Andrii Sultanov --- ocaml/tests/dune | 8 +++--- ocaml/tests/test_xapi_helpers.ml | 45 ++++++++++++++++++++++++++++++++ 2 files changed, 50 insertions(+), 3 deletions(-) create mode 100644 ocaml/tests/test_xapi_helpers.ml diff --git a/ocaml/tests/dune b/ocaml/tests/dune index d48056d3b70..831cc02ff87 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -6,7 +6,7 @@ (:standard \ test_daemon_manager test_vdi_cbt test_event test_clustering test_cluster_host test_cluster test_pusb test_network_sriov test_vm_placement test_vm_helpers test_repository test_repository_helpers - test_ref + test_ref test_xapi_helpers test_livepatch test_rpm test_updateinfo test_storage_smapiv1_wrapper test_storage_quicktest test_observer test_pool_periodic_update_sync test_pkg_mgr)) (libraries @@ -61,13 +61,15 @@ (tests (names test_vm_helpers test_vm_placement test_network_sriov test_vdi_cbt test_clustering test_pusb test_daemon_manager test_repository test_repository_helpers - test_livepatch test_rpm test_updateinfo test_pool_periodic_update_sync test_pkg_mgr) + test_livepatch test_rpm test_updateinfo test_pool_periodic_update_sync test_pkg_mgr + test_xapi_helpers) (package xapi) (modes exe) (modules test_vm_helpers test_vm_placement test_network_sriov test_vdi_cbt test_event test_clustering test_cluster_host test_cluster test_pusb test_daemon_manager test_repository test_repository_helpers test_livepatch test_rpm - test_updateinfo test_pool_periodic_update_sync test_pkg_mgr) + test_updateinfo test_pool_periodic_update_sync test_pkg_mgr + test_xapi_helpers) (libraries alcotest fmt diff --git a/ocaml/tests/test_xapi_helpers.ml b/ocaml/tests/test_xapi_helpers.ml new file mode 100644 index 00000000000..172e5c6e6a1 --- /dev/null +++ b/ocaml/tests/test_xapi_helpers.ml @@ -0,0 +1,45 @@ +(* + * Copyright (C) Cloud Software Group, Inc + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +let strings = + [ + ("foobar", "foobar") + ; ("foobarproxy_username=password", "foobarproxy_username=(filtered)") + ; ("barfooproxy_password=secret", "barfooproxy_password=(filtered)") + ; ("password", "password") + ; ("username=password", "username=password") + ; ("password=password", "password=password") + ; ("proxy_username=", "proxy_username=(filtered)") + ] + +let filtering_test = + List.map + (fun (input, expected) -> + let test_filtering () = + let filtered = + match Helpers.filter_args [input] with x :: _ -> x | _ -> "" + in + Printf.printf "%s\n" input ; + Alcotest.(check string) "secrets must be filtered out" expected filtered + in + ( Printf.sprintf {|Validation of argument filtering of "%s"|} input + , `Quick + , test_filtering + ) + ) + strings + +let () = + Suite_init.harness_init () ; + Alcotest.run "Test XAPI Helpers suite" [("Test_xapi_helpers", filtering_test)] From c148dbd1a7fa6201753ddd91318d2657da9afa7d Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Mon, 22 Jul 2024 09:51:34 +0100 Subject: [PATCH 023/157] IH-662 - helpers.ml: Move to a threadsafe Re.Pcre instead of Re.Str Signed-off-by: Andrii Sultanov --- ocaml/xapi/helpers.ml | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 4d3cb36ebdd..e782bec8991 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -42,21 +42,15 @@ let log_exn_continue msg f x = type log_output = Always | Never | On_failure let filter_patterns = - [ - ( Re.Str.regexp "^\\(.*proxy_\\(username\\|password\\)=\\)\\(.*\\)$" - , "\\1(filtered)" - ) - ] + [(Re.Pcre.regexp "^(.*proxy_(username|password)=)(.*)$", "(filtered)")] let filter_args args = List.map (fun arg -> List.fold_left (fun acc (r, t) -> - if Re.Str.string_match r acc 0 then - Re.Str.replace_matched t acc - else - acc + try String.concat "" [(Re.Pcre.extract ~rex:r acc).(1); t] + with Not_found -> acc ) arg filter_patterns ) From 8337fa94b76097428621d1e1987c5d66c1b82095 Mon Sep 17 00:00:00 2001 From: Colin Date: Mon, 22 Jul 2024 13:00:52 +0100 Subject: [PATCH 024/157] Remove ineffectual parameter wiping (#5868) * Remove redundant parameter wiping Removes ineffectual parameter wiping introduced by 6e24ca434fb2e358e. Signed-off-by: Colin James --- ocaml/xapi/xapi_session.ml | 843 ++++++++++++++++++------------------- 1 file changed, 399 insertions(+), 444 deletions(-) diff --git a/ocaml/xapi/xapi_session.ml b/ocaml/xapi/xapi_session.ml index 1417b4d8313..2a5a933fe6a 100644 --- a/ocaml/xapi/xapi_session.ml +++ b/ocaml/xapi/xapi_session.ml @@ -268,29 +268,14 @@ let set_local_auth_max_threads n = let set_ext_auth_max_threads n = Locking_helpers.Semaphore.set_max throttle_auth_external @@ Int64.to_int n -let wipe_string_contents str = - for i = 0 to Bytes.length str - 1 do - Bytes.set str i '\000' - done - -let wipe ss = List.iter (fun s -> wipe_string_contents s) ss - -(* wrapper that erases sensitive string parameters from functions *) -let wipe_params_after_fn params fn = - try - let r = fn () in - wipe params ; r - with e -> wipe params ; raise e - let do_external_auth uname pwd = with_throttle throttle_auth_external (fun () -> - (Ext_auth.d ()).authenticate_username_password uname - (Bytes.unsafe_to_string pwd) + (Ext_auth.d ()).authenticate_username_password uname pwd ) let do_local_auth uname pwd = with_throttle throttle_auth_internal (fun () -> - try Pam.authenticate uname (Bytes.unsafe_to_string pwd) + try Pam.authenticate uname pwd with Failure msg -> raise Api_errors.(Server_error (session_authentication_failed, [uname; msg])) @@ -298,7 +283,7 @@ let do_local_auth uname pwd = let do_local_change_password uname newpwd = with_throttle throttle_auth_internal (fun () -> - Pam.change_password uname (Bytes.unsafe_to_string newpwd) + Pam.change_password uname newpwd ) let trackid session_id = Context.trackid_of_session (Some session_id) @@ -725,22 +710,19 @@ let slave_local_login ~__context ~psecret = (* Emergency mode login, uses local storage *) let slave_local_login_with_password ~__context ~uname ~pwd = Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - let pwd = Bytes.of_string pwd in - wipe_params_after_fn [pwd] (fun () -> - if Context.preauth ~__context <> Some `root then ( - try - (* CP696 - only tries to authenticate against LOCAL superuser account *) - do_local_auth uname pwd - with Failure msg -> - debug "Failed to authenticate user %s: %s" uname msg ; - raise - (Api_errors.Server_error - (Api_errors.session_authentication_failed, [uname; msg]) - ) - ) ; - debug "Add session to local storage" ; - Xapi_local_session.create ~__context ~pool:false - ) + if Context.preauth ~__context <> Some `root then ( + try + (* CP696 - only tries to authenticate against LOCAL superuser account *) + do_local_auth uname pwd + with Failure msg -> + debug "Failed to authenticate user %s: %s" uname msg ; + raise + (Api_errors.Server_error + (Api_errors.session_authentication_failed, [uname; msg]) + ) + ) ; + debug "Add session to local storage" ; + Xapi_local_session.create ~__context ~pool:false (* CP-714: Modify session.login_with_password to first try local super-user login; and then call into external auth plugin if this is enabled @@ -757,415 +739,396 @@ let slave_local_login_with_password ~__context ~uname ~pwd = *) let login_with_password ~__context ~uname ~pwd ~version:_ ~originator = Context.with_tracing ~originator ~__context __FUNCTION__ @@ fun __context -> - let pwd = Bytes.of_string pwd in - wipe_params_after_fn [pwd] (fun () -> - (* !!! Do something with the version number *) - match Context.preauth ~__context with - | Some `root -> - (* in this case, the context origin of this login request is a unix socket bound locally to a filename *) - (* we trust requests from local unix filename sockets, so no need to authenticate them before login *) + (* !!! Do something with the version number *) + match Context.preauth ~__context with + | Some `root -> + (* in this case, the context origin of this login request is a unix socket bound locally to a filename *) + (* we trust requests from local unix filename sockets, so no need to authenticate them before login *) + login_no_password_common ~__context ~uname:(Some uname) ~originator + ~host:(Helpers.get_localhost ~__context) + ~pool:false ~is_local_superuser:true ~subject:Ref.null ~auth_user_sid:"" + ~auth_user_name:uname ~rbac_permissions:[] ~db_ref:None + ~client_certificate:false + | Some `client_cert -> + (* The session was authenticated by stunnel's verification of the client certificate, + so we do not need to verify the username/password. Grant access to functions + based on the special "client_cert" RBAC role. *) + let role = + match + Xapi_role.get_by_name_label ~__context + ~label:Datamodel_roles.role_client_cert + with + | role :: _ -> + role + | [] -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [Datamodel_roles.role_client_cert ^ " role not found"] + ) + ) + in + let rbac_permissions = + Xapi_role.get_permissions_name_label ~__context ~self:role + in + login_no_password_common ~__context ~uname:(Some uname) ~originator + ~host:(Helpers.get_localhost ~__context) + ~pool:false ~is_local_superuser:false ~subject:Ref.null + ~auth_user_sid:"" ~auth_user_name:uname ~rbac_permissions ~db_ref:None + ~client_certificate:true + | None -> ( + let () = + if Pool_role.is_slave () then + raise + (Api_errors.Server_error + (Api_errors.host_is_slave, [Pool_role.get_master_address ()]) + ) + in + let login_as_local_superuser auth_type = + if auth_type <> "" && uname <> local_superuser then + (* makes local superuser = root only*) + failwith ("Local superuser must be " ^ local_superuser) + else ( + do_local_auth uname pwd ; + debug "Success: local auth, user %s from %s" uname + (Context.get_origin __context) ; login_no_password_common ~__context ~uname:(Some uname) ~originator ~host:(Helpers.get_localhost ~__context) ~pool:false ~is_local_superuser:true ~subject:Ref.null ~auth_user_sid:"" ~auth_user_name:uname ~rbac_permissions:[] ~db_ref:None ~client_certificate:false - | Some `client_cert -> - (* The session was authenticated by stunnel's verification of the client certificate, - so we do not need to verify the username/password. Grant access to functions - based on the special "client_cert" RBAC role. *) - let role = - match - Xapi_role.get_by_name_label ~__context - ~label:Datamodel_roles.role_client_cert - with - | role :: _ -> - role - | [] -> - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [Datamodel_roles.role_client_cert ^ " role not found"] - ) - ) - in - let rbac_permissions = - Xapi_role.get_permissions_name_label ~__context ~self:role - in - login_no_password_common ~__context ~uname:(Some uname) ~originator - ~host:(Helpers.get_localhost ~__context) - ~pool:false ~is_local_superuser:false ~subject:Ref.null - ~auth_user_sid:"" ~auth_user_name:uname ~rbac_permissions - ~db_ref:None ~client_certificate:true - | None -> ( - let () = - if Pool_role.is_slave () then - raise - (Api_errors.Server_error - (Api_errors.host_is_slave, [Pool_role.get_master_address ()]) - ) - in - let login_as_local_superuser auth_type = - if auth_type <> "" && uname <> local_superuser then - (* makes local superuser = root only*) - failwith ("Local superuser must be " ^ local_superuser) - else ( - do_local_auth uname pwd ; - debug "Success: local auth, user %s from %s" uname - (Context.get_origin __context) ; - login_no_password_common ~__context ~uname:(Some uname) - ~originator - ~host:(Helpers.get_localhost ~__context) - ~pool:false ~is_local_superuser:true ~subject:Ref.null - ~auth_user_sid:"" ~auth_user_name:uname ~rbac_permissions:[] - ~db_ref:None ~client_certificate:false + ) + in + let thread_delay_and_raise_error ~error uname msg = + let some_seconds = 5.0 in + Thread.delay some_seconds ; + (* sleep a bit to avoid someone brute-forcing the password *) + if error = Api_errors.session_authentication_failed then + raise (Api_errors.Server_error (error, [uname; msg])) + else if error = Api_errors.session_authorization_failed then + raise Api_errors.(Server_error (error, [uname; msg])) + else + raise + (Api_errors.Server_error + (error, ["session.login_with_password"; msg]) ) - in - let thread_delay_and_raise_error ~error uname msg = - let some_seconds = 5.0 in - Thread.delay some_seconds ; - (* sleep a bit to avoid someone brute-forcing the password *) - if error = Api_errors.session_authentication_failed then - raise (Api_errors.Server_error (error, [uname; msg])) - else if error = Api_errors.session_authorization_failed then - raise Api_errors.(Server_error (error, [uname; msg])) - else - raise - (Api_errors.Server_error - (error, ["session.login_with_password"; msg]) - ) - in - match - Db.Host.get_external_auth_type ~__context - ~self:(Helpers.get_localhost ~__context) - with - | "" as auth_type -> ( - try - (* no external authentication *) + in + match + Db.Host.get_external_auth_type ~__context + ~self:(Helpers.get_localhost ~__context) + with + | "" as auth_type -> ( + try + (* no external authentication *) - (*debug "External authentication is disabled";*) - (* only attempts to authenticate against the local superuser credentials *) - login_as_local_superuser auth_type - with Failure msg -> - info "Failed to locally authenticate user %s from %s: %s" uname + (*debug "External authentication is disabled";*) + (* only attempts to authenticate against the local superuser credentials *) + login_as_local_superuser auth_type + with Failure msg -> + info "Failed to locally authenticate user %s from %s: %s" uname + (Context.get_origin __context) + msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authentication_failed uname msg + ) + | _ as auth_type -> ( + (* external authentication required *) + debug "External authentication %s is enabled" auth_type ; + (* 1. first attempts to authenticate against the local superuser *) + try login_as_local_superuser auth_type + with Failure msg -> ( + try + debug "Failed to locally authenticate user %s from %s: %s" uname (Context.get_origin __context) msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authentication_failed uname msg - ) - | _ as auth_type -> ( - (* external authentication required *) - debug "External authentication %s is enabled" auth_type ; - (* 1. first attempts to authenticate against the local superuser *) - try login_as_local_superuser auth_type - with Failure msg -> ( + (* 2. then against the external auth service *) + (* 2.1. we first check the external auth service status *) + let rec waiting_event_hook_auth_on_xapi_initialize_succeeded + seconds = + if not !Xapi_globs.event_hook_auth_on_xapi_initialize_succeeded + then ( + if seconds <= 0 then ( + let msg = + Printf.sprintf + "External authentication %s service still initializing" + auth_type + in + error "%s" msg ; + thread_delay_and_raise_error uname msg + ~error:Api_errors.internal_error + ) else + debug "External authentication %s service initializing..." + auth_type ; + Thread.delay 1.0 ; + waiting_event_hook_auth_on_xapi_initialize_succeeded + (seconds - 1) + ) + in + waiting_event_hook_auth_on_xapi_initialize_succeeded 120 ; + (* 2.2. we then authenticate the usee using the external authentication plugin *) + (* so that we know that he/she exists there *) + let subject_identifier = try - debug "Failed to locally authenticate user %s from %s: %s" + let _subject_identifier = do_external_auth uname pwd in + debug + "Successful external authentication user %s \ + (subject_identifier, %s from %s)" + uname _subject_identifier + (Context.get_origin __context) ; + _subject_identifier + with Auth_signature.Auth_failure msg -> + info "Failed to externally authenticate user %s from %s: %s" uname (Context.get_origin __context) msg ; - (* 2. then against the external auth service *) - (* 2.1. we first check the external auth service status *) - let rec waiting_event_hook_auth_on_xapi_initialize_succeeded - seconds = - if - not - !Xapi_globs.event_hook_auth_on_xapi_initialize_succeeded - then ( - if seconds <= 0 then ( - let msg = - Printf.sprintf - "External authentication %s service still \ - initializing" - auth_type - in - error "%s" msg ; - thread_delay_and_raise_error uname msg - ~error:Api_errors.internal_error - ) else - debug - "External authentication %s service initializing..." - auth_type ; - Thread.delay 1.0 ; - waiting_event_hook_auth_on_xapi_initialize_succeeded - (seconds - 1) - ) - in - waiting_event_hook_auth_on_xapi_initialize_succeeded 120 ; - (* 2.2. we then authenticate the usee using the external authentication plugin *) - (* so that we know that he/she exists there *) - let subject_identifier = - try - let _subject_identifier = do_external_auth uname pwd in - debug - "Successful external authentication user %s \ - (subject_identifier, %s from %s)" - uname _subject_identifier - (Context.get_origin __context) ; - _subject_identifier - with Auth_signature.Auth_failure msg -> - info - "Failed to externally authenticate user %s from %s: %s" - uname - (Context.get_origin __context) - msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authentication_failed uname - msg + thread_delay_and_raise_error + ~error:Api_errors.session_authentication_failed uname msg + in + (* as per tests in CP-827, there should be no need to call is_subject_suspended function here, *) + (* because the authentication server in 2.1 will already reflect if account/password expired, *) + (* disabled, locked-out etc, but since likewise doesn't timely reflect this information *) + (* at the same time for both authentication and subject info queries (modification in the AD *) + (* reflects immediately for AD authentication, but can take 1 hour to reflect on subject info), *) + (* we need to call it here in order to be consistent with the session revalidation function. *) + (* Otherwise, there might be cases where the initial authentication/login succeeds, but *) + (* then a few minutes later the revalidation finds that the user is 'suspended' (due to *) + (* subject info caching problems in likewise) and closes the user's session *) + let subject_suspended, subject_name = + try + let suspended, name = + is_subject_suspended ~__context ~cache:true + subject_identifier in - (* as per tests in CP-827, there should be no need to call is_subject_suspended function here, *) - (* because the authentication server in 2.1 will already reflect if account/password expired, *) - (* disabled, locked-out etc, but since likewise doesn't timely reflect this information *) - (* at the same time for both authentication and subject info queries (modification in the AD *) - (* reflects immediately for AD authentication, but can take 1 hour to reflect on subject info), *) - (* we need to call it here in order to be consistent with the session revalidation function. *) - (* Otherwise, there might be cases where the initial authentication/login succeeds, but *) - (* then a few minutes later the revalidation finds that the user is 'suspended' (due to *) - (* subject info caching problems in likewise) and closes the user's session *) - let subject_suspended, subject_name = - try - let suspended, name = - is_subject_suspended ~__context ~cache:true + if suspended then + is_subject_suspended ~__context ~cache:false + subject_identifier + else + (suspended, name) + with Auth_signature.Auth_service_error (_, msg) -> + debug + "Failed to find if user %s (subject_id %s, from %s) is \ + suspended: %s" + uname subject_identifier + (Context.get_origin __context) + msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + in + if subject_suspended then ( + let msg = + Printf.sprintf + "User %s (subject_id %s, from %s) suspended in external \ + directory" + uname subject_identifier + (Context.get_origin __context) + in + debug "%s" msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + ) else + (* 2.2. then, we verify if any elements of the the membership closure of the externally *) + (* authenticated subject_id is inside our local allowed-to-login subjects list *) + (* finds all the groups a user belongs to (non-reflexive closure of member-of relation) *) + let group_membership_closure = + try + (Ext_auth.d ()).query_group_membership subject_identifier + with + | Not_found | Auth_signature.Subject_cannot_be_resolved -> + let msg = + Printf.sprintf + "Failed to obtain the group membership closure for \ + user %s (subject_id %s, from %s): user not found in \ + external directory" + uname + (Context.get_origin __context) subject_identifier in - if suspended then - is_subject_suspended ~__context ~cache:false - subject_identifier - else - (suspended, name) - with Auth_signature.Auth_service_error (_, msg) -> + debug "%s" msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + | Auth_signature.Auth_service_error (_, msg) -> debug - "Failed to find if user %s (subject_id %s, from %s) is \ - suspended: %s" + "Failed to obtain the group membership closure for \ + user %s (subject_id %s, from %s): %s" uname subject_identifier (Context.get_origin __context) msg ; thread_delay_and_raise_error ~error:Api_errors.session_authorization_failed uname msg + in + (* finds the intersection between group_membership_closure and pool's table of subject_ids *) + let subjects_in_db = Db.Subject.get_all ~__context in + let subject_ids_in_db = + List.map + (fun subj -> + ( subj + , Db.Subject.get_subject_identifier ~__context ~self:subj + ) + ) + subjects_in_db + in + let reflexive_membership_closure = + subject_identifier :: group_membership_closure + in + (* returns all elements of reflexive_membership_closure that are inside subject_ids_in_db *) + let intersect ext_sids db_sids = + List.filter + (fun (_, db_sid) -> List.mem db_sid ext_sids) + db_sids + in + let intersection = + intersect reflexive_membership_closure subject_ids_in_db + in + (* 2.3. finally, we create the session for the authenticated subject if any membership intersection was found *) + let in_intersection = intersection <> [] in + if not in_intersection then ( + (* empty intersection: externally-authenticated subject has no login rights in the pool *) + let msg = + Printf.sprintf + "Subject %s (identifier %s, from %s) has no access \ + rights in this pool" + uname subject_identifier + (Context.get_origin __context) + in + info "%s" msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + ) else (* compute RBAC structures for the session *) + let subject_membership = List.map fst intersection in + debug "subject membership intersection with subject-list=[%s]" + (List.fold_left + (fun i (subj_ref, sid) -> + let subj_ref = + try + (* attempt to resolve subject_ref -> subject_name *) + List.assoc + Auth_signature + .subject_information_field_subject_name + (Db.Subject.get_other_config ~__context + ~self:subj_ref + ) + with _ -> Ref.string_of subj_ref + in + if i = "" then + subj_ref ^ " (" ^ sid ^ ")" + else + i ^ "," ^ subj_ref ^ " (" ^ sid ^ ")" + ) + "" intersection + ) ; + let rbac_permissions = + get_permissions ~__context ~subject_membership in - if subject_suspended then ( + (* CP-1260: If a subject has no roles assigned, then authentication will fail with an error such as PERMISSION_DENIED.*) + if rbac_permissions = [] then ( let msg = Printf.sprintf - "User %s (subject_id %s, from %s) suspended in \ - external directory" + "Subject %s (identifier %s) has no roles in this pool" uname subject_identifier - (Context.get_origin __context) in - debug "%s" msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname msg + info "%s" msg ; + thread_delay_and_raise_error uname msg + ~error:Api_errors.rbac_permission_denied ) else - (* 2.2. then, we verify if any elements of the the membership closure of the externally *) - (* authenticated subject_id is inside our local allowed-to-login subjects list *) - (* finds all the groups a user belongs to (non-reflexive closure of member-of relation) *) - let group_membership_closure = + (* non-empty intersection: externally-authenticated subject has login rights in the pool *) + let subject = + (* return reference for the subject obj in the db *) + (* obs: this obj ref can point to either a user or a group contained in the local subject db list *) try - (Ext_auth.d ()).query_group_membership - subject_identifier - with - | Not_found | Auth_signature.Subject_cannot_be_resolved -> - let msg = - Printf.sprintf - "Failed to obtain the group membership closure \ - for user %s (subject_id %s, from %s): user not \ - found in external directory" - uname - (Context.get_origin __context) - subject_identifier - in - debug "%s" msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname - msg - | Auth_signature.Auth_service_error (_, msg) -> - debug - "Failed to obtain the group membership closure for \ - user %s (subject_id %s, from %s): %s" - uname subject_identifier - (Context.get_origin __context) - msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname - msg - in - (* finds the intersection between group_membership_closure and pool's table of subject_ids *) - let subjects_in_db = Db.Subject.get_all ~__context in - let subject_ids_in_db = - List.map - (fun subj -> - ( subj - , Db.Subject.get_subject_identifier ~__context - ~self:subj + List.find + (fun subj -> + (* is this the subject ref that returned the non-empty intersection?*) + List.hd intersection + = ( subj + , Db.Subject.get_subject_identifier ~__context + ~self:subj + ) ) - ) - subjects_in_db - in - let reflexive_membership_closure = - subject_identifier :: group_membership_closure - in - (* returns all elements of reflexive_membership_closure that are inside subject_ids_in_db *) - let intersect ext_sids db_sids = - List.filter - (fun (_, db_sid) -> List.mem db_sid ext_sids) - db_sids - in - let intersection = - intersect reflexive_membership_closure subject_ids_in_db - in - (* 2.3. finally, we create the session for the authenticated subject if any membership intersection was found *) - let in_intersection = intersection <> [] in - if not in_intersection then ( - (* empty intersection: externally-authenticated subject has no login rights in the pool *) - let msg = - Printf.sprintf - "Subject %s (identifier %s, from %s) has no access \ - rights in this pool" - uname subject_identifier - (Context.get_origin __context) - in - info "%s" msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname msg - ) else (* compute RBAC structures for the session *) - let subject_membership = List.map fst intersection in - debug - "subject membership intersection with subject-list=[%s]" - (List.fold_left - (fun i (subj_ref, sid) -> - let subj_ref = - try - (* attempt to resolve subject_ref -> subject_name *) - List.assoc - Auth_signature - .subject_information_field_subject_name - (Db.Subject.get_other_config ~__context - ~self:subj_ref - ) - with _ -> Ref.string_of subj_ref - in - if i = "" then - subj_ref ^ " (" ^ sid ^ ")" - else - i ^ "," ^ subj_ref ^ " (" ^ sid ^ ")" - ) - "" intersection - ) ; - let rbac_permissions = - get_permissions ~__context ~subject_membership - in - (* CP-1260: If a subject has no roles assigned, then authentication will fail with an error such as PERMISSION_DENIED.*) - if rbac_permissions = [] then ( + subjects_in_db + (* goes through exactly the same subject list that we went when computing the intersection, *) + (* so that no one is able to undetectably remove/add another subject with the same subject_identifier *) + (* between that time 2.2 and now 2.3 *) + with Not_found -> + (* this should never happen, it shows an inconsistency in the db between 2.2 and 2.3 *) let msg = Printf.sprintf - "Subject %s (identifier %s) has no roles in this \ - pool" + "Subject %s (identifier %s, from %s) is not \ + present in this pool" uname subject_identifier + (Context.get_origin __context) in - info "%s" msg ; - thread_delay_and_raise_error uname msg - ~error:Api_errors.rbac_permission_denied - ) else - (* non-empty intersection: externally-authenticated subject has login rights in the pool *) - let subject = - (* return reference for the subject obj in the db *) - (* obs: this obj ref can point to either a user or a group contained in the local subject db list *) - try - List.find - (fun subj -> - (* is this the subject ref that returned the non-empty intersection?*) - List.hd intersection - = ( subj - , Db.Subject.get_subject_identifier ~__context - ~self:subj - ) - ) - subjects_in_db - (* goes through exactly the same subject list that we went when computing the intersection, *) - (* so that no one is able to undetectably remove/add another subject with the same subject_identifier *) - (* between that time 2.2 and now 2.3 *) - with Not_found -> - (* this should never happen, it shows an inconsistency in the db between 2.2 and 2.3 *) - let msg = - Printf.sprintf - "Subject %s (identifier %s, from %s) is not \ - present in this pool" - uname subject_identifier - (Context.get_origin __context) - in - debug "%s" msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed - uname msg - in - login_no_password_common ~__context ~uname:(Some uname) - ~originator - ~host:(Helpers.get_localhost ~__context) - ~pool:false ~is_local_superuser:false ~subject - ~auth_user_sid:subject_identifier - ~auth_user_name:subject_name ~rbac_permissions - ~db_ref:None ~client_certificate:false - (* we only reach this point if for some reason a function above forgot to catch a possible exception in the Auth_signature module*) - with - | Not_found | Auth_signature.Subject_cannot_be_resolved -> - let msg = - Printf.sprintf - "user %s from %s not found in external directory" uname - (Context.get_origin __context) + debug "%s" msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname + msg in - debug - "A function failed to catch this exception for user %s \ - during external authentication: %s" - uname msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname msg - | Auth_signature.Auth_failure msg -> - debug - "A function failed to catch this exception for user %s. \ - Auth_failure: %s" - uname msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authentication_failed uname msg - | Auth_signature.Auth_service_error (_, msg) -> - debug - "A function failed to catch this exception for user %s \ - from %s during external authentication: %s" - uname - (Context.get_origin __context) - msg ; - thread_delay_and_raise_error - ~error:Api_errors.session_authorization_failed uname msg - | Api_errors.Server_error _ as e -> - (* bubble up any api_error already generated *) - raise e - | e -> - (* generic catch-all for unexpected exceptions during external authentication *) - let msg = ExnHelper.string_of_exn e in - debug - "(generic) A function failed to catch this exception for \ - user %s from %s during external authentication: %s" - uname - (Context.get_origin __context) - msg ; - thread_delay_and_raise_error - ~error:Api_errors.internal_error uname msg - ) - ) + login_no_password_common ~__context ~uname:(Some uname) + ~originator + ~host:(Helpers.get_localhost ~__context) + ~pool:false ~is_local_superuser:false ~subject + ~auth_user_sid:subject_identifier + ~auth_user_name:subject_name ~rbac_permissions + ~db_ref:None ~client_certificate:false + (* we only reach this point if for some reason a function above forgot to catch a possible exception in the Auth_signature module*) + with + | Not_found | Auth_signature.Subject_cannot_be_resolved -> + let msg = + Printf.sprintf + "user %s from %s not found in external directory" uname + (Context.get_origin __context) + in + debug + "A function failed to catch this exception for user %s \ + during external authentication: %s" + uname msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + | Auth_signature.Auth_failure msg -> + debug + "A function failed to catch this exception for user %s. \ + Auth_failure: %s" + uname msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authentication_failed uname msg + | Auth_signature.Auth_service_error (_, msg) -> + debug + "A function failed to catch this exception for user %s from \ + %s during external authentication: %s" + uname + (Context.get_origin __context) + msg ; + thread_delay_and_raise_error + ~error:Api_errors.session_authorization_failed uname msg + | Api_errors.Server_error _ as e -> + (* bubble up any api_error already generated *) + raise e + | e -> + (* generic catch-all for unexpected exceptions during external authentication *) + let msg = ExnHelper.string_of_exn e in + debug + "(generic) A function failed to catch this exception for \ + user %s from %s during external authentication: %s" + uname + (Context.get_origin __context) + msg ; + thread_delay_and_raise_error ~error:Api_errors.internal_error + uname msg + ) ) - ) + ) let change_password ~__context ~old_pwd ~new_pwd = + ignore old_pwd ; Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - let old_pwd = Bytes.of_string old_pwd in - let new_pwd = Bytes.of_string new_pwd in - wipe_params_after_fn [old_pwd; new_pwd] (fun () -> - let session_id = Context.get_session_id __context in - (*let user = Db.Session.get_this_user ~__context ~self:session_id in - let uname = Db.User.get_short_name ~__context ~self:user in*) - let uname = local_superuser in - (* user class has been deprecated *) - if Db.Session.get_is_local_superuser ~__context ~self:session_id then ( - try - (* CP-696: only change password if session has is_local_superuser bit set *) - (* + let session_id = Context.get_session_id __context in + (*let user = Db.Session.get_this_user ~__context ~self:session_id in + let uname = Db.User.get_short_name ~__context ~self:user in*) + let uname = local_superuser in + (* user class has been deprecated *) + if Db.Session.get_is_local_superuser ~__context ~self:session_id then ( + try + (* CP-696: only change password if session has is_local_superuser bit set *) + (* CA-13567: If you have root privileges then we do not authenticate old_pwd; right now, since we only ever have root privileges we just comment this out. @@ -1177,47 +1140,39 @@ let change_password ~__context ~old_pwd ~new_pwd = raise (Api_errors.Server_error (Api_errors.session_authentication_failed,[uname;msg])) end; *) - do_local_change_password uname new_pwd ; - info "Password changed successfully for user %s" uname ; - info "Syncing password change across hosts in pool" ; - (* tell all hosts (except me to sync new passwd file) *) - let hash = Helpers.compute_hash () in - let hosts = Db.Host.get_all ~__context in - let hosts = - List.filter - (fun hostref -> hostref <> !Xapi_globs.localhost_ref) - hosts - in - Helpers.call_api_functions ~__context (fun rpc session_id -> - List.iter - (fun host -> - try - Client.Host.request_config_file_sync ~rpc ~session_id ~host - ~hash - with e -> - error "Failed to sync password to host %s: %s" - (Db.Host.get_name_label ~__context ~self:host) - (Printexc.to_string e) - ) - hosts - ) ; - info "Finished syncing password across pool" - with Failure msg -> - error "Failed to change password for user %s: %s" uname msg ; - raise - (Api_errors.Server_error (Api_errors.change_password_rejected, [msg]) + do_local_change_password uname new_pwd ; + info "Password changed successfully for user %s" uname ; + info "Syncing password change across hosts in pool" ; + (* tell all hosts (except me to sync new passwd file) *) + let hash = Helpers.compute_hash () in + let hosts = Db.Host.get_all ~__context in + let hosts = + List.filter (fun hostref -> hostref <> !Xapi_globs.localhost_ref) hosts + in + Helpers.call_api_functions ~__context (fun rpc session_id -> + List.iter + (fun host -> + try + Client.Host.request_config_file_sync ~rpc ~session_id ~host + ~hash + with e -> + error "Failed to sync password to host %s: %s" + (Db.Host.get_name_label ~__context ~self:host) + (Printexc.to_string e) ) - ) else - (* CP-696: session does not have is_local_superuser bit set, so we must fail *) - let msg = - Printf.sprintf "Failed to change password for user %s" uname - in - debug "User %s is not local superuser: %s" uname msg ; - raise - (Api_errors.Server_error - (Api_errors.user_is_not_local_superuser, [msg]) - ) - ) + hosts + ) ; + info "Finished syncing password across pool" + with Failure msg -> + error "Failed to change password for user %s: %s" uname msg ; + raise + (Api_errors.Server_error (Api_errors.change_password_rejected, [msg])) + ) else + (* CP-696: session does not have is_local_superuser bit set, so we must fail *) + let msg = Printf.sprintf "Failed to change password for user %s" uname in + debug "User %s is not local superuser: %s" uname msg ; + raise + (Api_errors.Server_error (Api_errors.user_is_not_local_superuser, [msg])) let logout ~__context = Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> From f39ea999fcde62a48d485ccd20becf9c610d6231 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 15:27:16 +0100 Subject: [PATCH 025/157] CP-47536: Drop posix_channel and channel_helper: unused and a mix of Unix/Lwt MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It was a mix of Lwt and Unix code, which means that if the Unix call blocks the entire Lwt code blocks too. This was only installed by the specfile in a -devel package. `message-cli tail --follow` can be used to debug the IDL protocol instead. Signed-off-by: Edwin Török --- ocaml/xapi-idl/README.md | 1 - ocaml/xapi-idl/lib/posix_channel.ml | 234 ------------------------ ocaml/xapi-idl/lib/posix_channel.mli | 21 --- ocaml/xapi-idl/lib/xcp_channel.ml | 17 -- ocaml/xapi-idl/lib/xcp_channel.mli | 13 -- ocaml/xapi-idl/lib_test/channel_test.ml | 77 -------- ocaml/xapi-idl/misc/channel_helper.ml | 221 ---------------------- ocaml/xapi-idl/misc/dune | 16 -- quality-gate.sh | 2 +- 9 files changed, 1 insertion(+), 601 deletions(-) delete mode 100644 ocaml/xapi-idl/lib/posix_channel.ml delete mode 100644 ocaml/xapi-idl/lib/posix_channel.mli delete mode 100644 ocaml/xapi-idl/lib/xcp_channel.ml delete mode 100644 ocaml/xapi-idl/lib/xcp_channel.mli delete mode 100644 ocaml/xapi-idl/lib_test/channel_test.ml delete mode 100644 ocaml/xapi-idl/misc/channel_helper.ml delete mode 100644 ocaml/xapi-idl/misc/dune diff --git a/ocaml/xapi-idl/README.md b/ocaml/xapi-idl/README.md index 3b34349a152..2da87aa0c20 100644 --- a/ocaml/xapi-idl/README.md +++ b/ocaml/xapi-idl/README.md @@ -10,7 +10,6 @@ This repository contains * argument parsing * RPCs 3. The following CLI tools for debugging: - * lib/channel_helper.exe -- a channel passing helper CLI * memory/memory_cli.exe -- a squeezed debugging CLI * v6/v6_cli.exe -- a V6d debugging CLI * cluster/cluster_cli.exe -- a xapi-clusterd debugging CLI diff --git a/ocaml/xapi-idl/lib/posix_channel.ml b/ocaml/xapi-idl/lib/posix_channel.ml deleted file mode 100644 index 06708561011..00000000000 --- a/ocaml/xapi-idl/lib/posix_channel.ml +++ /dev/null @@ -1,234 +0,0 @@ -let my_domid = 0 (* TODO: figure this out *) - -exception End_of_file - -exception Channel_setup_failed - -module CBuf = struct - (** A circular buffer constructed from a string *) - type t = { - mutable buffer: bytes - ; mutable len: int (** bytes of valid data in [buffer] *) - ; mutable start: int (** index of first valid byte in [buffer] *) - ; mutable r_closed: bool (** true if no more data can be read due to EOF *) - ; mutable w_closed: bool - (** true if no more data can be written due to EOF *) - } - - let empty length = - { - buffer= Bytes.create length - ; len= 0 - ; start= 0 - ; r_closed= false - ; w_closed= false - } - - let drop (x : t) n = - if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len) ; - x.start <- (x.start + n) mod Bytes.length x.buffer ; - x.len <- x.len - n - - let should_read (x : t) = - (not x.r_closed) && x.len < Bytes.length x.buffer - 1 - - let should_write (x : t) = (not x.w_closed) && x.len > 0 - - let end_of_reads (x : t) = x.r_closed && x.len = 0 - - let end_of_writes (x : t) = x.w_closed - - let write (x : t) fd = - (* Offset of the character after the substring *) - let next = min (Bytes.length x.buffer) (x.start + x.len) in - let len = next - x.start in - let written = - try Unix.single_write fd x.buffer x.start len - with _e -> - x.w_closed <- true ; - len - in - drop x written - - let read (x : t) fd = - (* Offset of the next empty character *) - let next = (x.start + x.len) mod Bytes.length x.buffer in - let len = - min (Bytes.length x.buffer - next) (Bytes.length x.buffer - x.len) - in - let read = Unix.read fd x.buffer next len in - if read = 0 then x.r_closed <- true ; - x.len <- x.len + read -end - -let proxy (a : Unix.file_descr) (b : Unix.file_descr) = - let size = 64 * 1024 in - (* [a'] is read from [a] and will be written to [b] *) - (* [b'] is read from [b] and will be written to [a] *) - let a' = CBuf.empty size and b' = CBuf.empty size in - Unix.set_nonblock a ; - Unix.set_nonblock b ; - try - while true do - let r = - (if CBuf.should_read a' then [a] else []) - @ if CBuf.should_read b' then [b] else [] - in - let w = - (if CBuf.should_write a' then [b] else []) - @ if CBuf.should_write b' then [a] else [] - in - (* If we can't make any progress (because fds have been closed), then stop *) - if r = [] && w = [] then raise End_of_file ; - let r, w, _ = Unix.select r w [] (-1.0) in - (* Do the writing before the reading *) - List.iter - (fun fd -> if a = fd then CBuf.write b' a else CBuf.write a' b) - w ; - List.iter (fun fd -> if a = fd then CBuf.read a' a else CBuf.read b' b) r ; - (* If there's nothing else to read or write then signal the other end *) - List.iter - (fun (buf, fd) -> - if CBuf.end_of_reads buf then Unix.shutdown fd Unix.SHUTDOWN_SEND ; - if CBuf.end_of_writes buf then Unix.shutdown fd Unix.SHUTDOWN_RECEIVE - ) - [(a', b); (b', a)] - done - with _ -> ( - (try Unix.clear_nonblock a with _ -> ()) ; - try Unix.clear_nonblock b with _ -> () - ) - -let finally f g = - try - let result = f () in - g () ; result - with e -> g () ; raise e - -let ip = ref "127.0.0.1" - -let send proxy_socket = - let to_close = ref [] in - let to_unlink = ref [] in - finally - (fun () -> - let s_ip = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - to_close := s_ip :: !to_close ; - Unix.bind s_ip (Unix.ADDR_INET (Unix.inet_addr_of_string !ip, 0)) ; - Unix.listen s_ip 5 ; - let port = - match Unix.getsockname s_ip with - | Unix.ADDR_INET (_, port) -> - port - | _ -> - assert false - in - let s_unix = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - to_close := s_unix :: !to_close ; - let path = Filename.temp_file "channel" "" in - to_unlink := path :: !to_unlink ; - if Sys.file_exists path then Unix.unlink path ; - Unix.bind s_unix (Unix.ADDR_UNIX path) ; - Unix.listen s_unix 5 ; - let token = "token" in - let protocols = - let open Xcp_channel_protocol in - [TCP_proxy (!ip, port); Unix_sendmsg (my_domid, path, token)] - in - (* We need to hang onto a copy of the proxy_socket so we can run a proxy - in a background thread, allowing the caller to close their copy. *) - let proxy_socket = Unix.dup proxy_socket in - to_close := proxy_socket :: !to_close ; - let (_ : Thread.t) = - Thread.create - (fun (fds, paths) -> - (* The thread takes over management of the listening sockets *) - let to_close = ref fds in - let to_unlink = ref paths in - let close fd = - if List.mem fd !to_close then ( - to_close := List.filter (fun x -> x <> fd) !to_close ; - Unix.close fd - ) - in - finally - (fun () -> - let readable, _, _ = Unix.select [s_ip; s_unix] [] [] (-1.0) in - if List.mem s_unix readable then ( - let fd, _peer = Unix.accept s_unix in - to_close := fd :: !to_close ; - let buffer = Bytes.make (String.length token) '\000' in - let n = Unix.recv fd buffer 0 (Bytes.length buffer) [] in - let token' = Bytes.sub_string buffer 0 n in - if token = token' then - let (_ : int) = - Fd_send_recv.send_fd_substring fd token 0 - (String.length token) [] proxy_socket - in - () - ) else if List.mem s_ip readable then ( - let fd, _peer = Unix.accept s_ip in - List.iter close !to_close ; - to_close := fd :: !to_close ; - proxy fd proxy_socket - ) else - assert false - (* can never happen *) - ) - (fun () -> - List.iter close !to_close ; - List.iter Unix.unlink !to_unlink - ) - ) - (!to_close, !to_unlink) - in - (* Handover of listening sockets successful *) - to_close := [] ; - to_unlink := [] ; - protocols - ) - (fun () -> - List.iter Unix.close !to_close ; - List.iter Unix.unlink !to_unlink - ) - -let receive protocols = - let open Xcp_channel_protocol in - let weight = function - | TCP_proxy (_, _) -> - 2 - | Unix_sendmsg (domid, _, _) -> - if my_domid = domid then 3 else 0 - | V4V_proxy (_, _) -> - 0 - in - let protocol = - match List.sort (fun a b -> compare (weight b) (weight a)) protocols with - | [] -> - raise Channel_setup_failed - | best :: _ -> - if weight best = 0 then raise Channel_setup_failed else best - in - match protocol with - | V4V_proxy (_, _) -> - assert false (* weight is 0 above *) - | TCP_proxy (ip, port) -> ( - let unwrapped_ip = Scanf.ksscanf ip (fun _ _ -> ip) "[%s@]" Fun.id in - let addr = Unix.ADDR_INET (Unix.inet_addr_of_string unwrapped_ip, port) in - let family = Unix.domain_of_sockaddr addr in - let s = Unix.socket family Unix.SOCK_STREAM 0 in - try Unix.connect s addr ; s with e -> Unix.close s ; raise e - ) - | Unix_sendmsg (_, path, token) -> - let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - finally - (fun () -> - Unix.connect s (Unix.ADDR_UNIX path) ; - let (_ : int) = - Unix.send_substring s token 0 (String.length token) [] - in - let buf = Bytes.create (String.length token) in - let _, _, fd = Fd_send_recv.recv_fd s buf 0 (Bytes.length buf) [] in - fd - ) - (fun () -> Unix.close s) diff --git a/ocaml/xapi-idl/lib/posix_channel.mli b/ocaml/xapi-idl/lib/posix_channel.mli deleted file mode 100644 index 8610f27a86d..00000000000 --- a/ocaml/xapi-idl/lib/posix_channel.mli +++ /dev/null @@ -1,21 +0,0 @@ -(* - * Copyright (C) Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -val send : Unix.file_descr -> Xcp_channel_protocol.t list -(** [send fd] attempts to send the channel represented by [fd] to a remote - process. Note the file descriptor remains open in the original process and - should still be closed normally. *) - -val receive : Xcp_channel_protocol.t list -> Unix.file_descr -(** [receive protocols] receives a channel from a remote. *) diff --git a/ocaml/xapi-idl/lib/xcp_channel.ml b/ocaml/xapi-idl/lib/xcp_channel.ml deleted file mode 100644 index 395da851a5f..00000000000 --- a/ocaml/xapi-idl/lib/xcp_channel.ml +++ /dev/null @@ -1,17 +0,0 @@ -type t = Unix.file_descr - -let file_descr_of_t t = t - -let t_of_file_descr t = t - -[@@@ocaml.warning "-34"] - -type protocols = Xcp_channel_protocol.t list [@@deriving rpc] - -let rpc_of_t fd = - let protocols = Posix_channel.send fd in - rpc_of_protocols protocols - -let t_of_rpc x = - let protocols = protocols_of_rpc x in - Posix_channel.receive protocols diff --git a/ocaml/xapi-idl/lib/xcp_channel.mli b/ocaml/xapi-idl/lib/xcp_channel.mli deleted file mode 100644 index 35849a1e5d4..00000000000 --- a/ocaml/xapi-idl/lib/xcp_channel.mli +++ /dev/null @@ -1,13 +0,0 @@ -type t - -val rpc_of_t : t -> Rpc.t - -val t_of_rpc : Rpc.t -> t - -val file_descr_of_t : t -> Unix.file_descr - -val t_of_file_descr : Unix.file_descr -> t - -val protocols_of_rpc : Rpc.t -> Xcp_channel_protocol.t list - -val rpc_of_protocols : Xcp_channel_protocol.t list -> Rpc.t diff --git a/ocaml/xapi-idl/lib_test/channel_test.ml b/ocaml/xapi-idl/lib_test/channel_test.ml deleted file mode 100644 index dd607935778..00000000000 --- a/ocaml/xapi-idl/lib_test/channel_test.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* - * Copyright (C) 2011-2013 Citrix Inc - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -let dup_automatic x = - let x = Xcp_channel.t_of_file_descr x in - let y = Xcp_channel.rpc_of_t x in - let z = Xcp_channel.t_of_rpc y in - Xcp_channel.file_descr_of_t z - -let dup_sendmsg x = - let protos = Posix_channel.send x in - let proto = - List.find - (function - | Xcp_channel_protocol.Unix_sendmsg (_, _, _) -> true | _ -> false - ) - protos - in - Posix_channel.receive [proto] - -let count_fds () = Array.length (Sys.readdir "/proc/self/fd") - -(* dup stdout, check /proc/pid/fd *) -let check_for_leak dup_function () = - let before = count_fds () in - let stdout2 = dup_function Unix.stdout in - let after = count_fds () in - Alcotest.(check int) "fds" (before + 1) after ; - Unix.close stdout2 ; - let after' = count_fds () in - Alcotest.(check int) "fds" before after' - -let dup_proxy x = - let protos = Posix_channel.send x in - let proto = - List.find - (function - | Xcp_channel_protocol.TCP_proxy (_ip, _port) -> true | _ -> false - ) - protos - in - Posix_channel.receive [proto] - -let check_for_leak_proxy () = - let a, _b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in - let before = count_fds () in - let c = dup_proxy a in - (* background fd closing *) - Thread.delay 1.0 ; - let after = count_fds () in - Alcotest.(check int) "fds" (before + 2) after ; - Unix.close c ; - (* background fd closing *) - Thread.delay 1.0 ; - let after' = count_fds () in - Alcotest.(check int) "fds" before after' - -let tests = - [ - ( "check_for_leak with automatic selection" - , `Quick - , check_for_leak dup_automatic - ) - ; ("check_for_leak with sendmsg", `Quick, check_for_leak dup_sendmsg) - ; ("check_for_leak_proxy", `Quick, check_for_leak_proxy) - ] diff --git a/ocaml/xapi-idl/misc/channel_helper.ml b/ocaml/xapi-idl/misc/channel_helper.ml deleted file mode 100644 index 1485e6a5ead..00000000000 --- a/ocaml/xapi-idl/misc/channel_helper.ml +++ /dev/null @@ -1,221 +0,0 @@ -let project_url = "https://github.com/xen-org/xcp-idl" - -open Lwt - -let my_domid = 0 (* TODO: figure this out *) - -exception Short_write of int * int - -exception End_of_file - -let copy_all src dst = - let buffer = Bytes.make 16384 '\000' in - let rec loop () = - Lwt_unix.read src buffer 0 (Bytes.length buffer) >>= fun n -> - if n = 0 then - Lwt.fail End_of_file - else - Lwt_unix.write dst buffer 0 n >>= fun m -> - if n <> m then Lwt.fail (Short_write (m, n)) else loop () - in - loop () - -let proxy a b = - let copy _id src dst = - Lwt.catch - (fun () -> copy_all src dst) - (fun _e -> - (try Lwt_unix.shutdown src Lwt_unix.SHUTDOWN_RECEIVE with _ -> ()) ; - (try Lwt_unix.shutdown dst Lwt_unix.SHUTDOWN_SEND with _ -> ()) ; - return () - ) - in - let ts = [copy "ab" a b; copy "ba" b a] in - Lwt.join ts - -let file_descr_of_int (x : int) : Unix.file_descr = Obj.magic x - -(* Keep this in sync with ocaml's file_descr type *) - -let ip = ref "127.0.0.1" - -let unix = ref "/tmp" - -module Common = struct - type t = {verbose: bool; debug: bool; port: int} [@@deriving rpc] - - let make verbose debug port = {verbose; debug; port} -end - -let _common_options = "COMMON OPTIONS" - -open Cmdliner - -(* Options common to all commands *) -let common_options_t = - let docs = _common_options in - let debug = - let doc = "Give only debug output." in - Arg.(value & flag & info ["debug"] ~docs ~doc) - in - let verb = - let doc = "Give verbose output." in - let verbose = (true, Arg.info ["v"; "verbose"] ~docs ~doc) in - Arg.(last & vflag_all [false] [verbose]) - in - let port = - let doc = Printf.sprintf "Specify port to connect to the message switch." in - Arg.(value & opt int 8080 & info ["port"] ~docs ~doc) - in - Term.(const Common.make $ debug $ verb $ port) - -(* Help sections common to all commands *) -let help = - [ - `S _common_options - ; `P "These options are common to all commands." - ; `S "MORE HELP" - ; `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command." - ; `Noblank - ; `S "BUGS" - ; `P (Printf.sprintf "Check bug reports at %s" project_url) - ] - -(* Commands *) -let advertise_t _common_options_t proxy_socket = - let unwrapped_ip = Scanf.ksscanf !ip (fun _ _ -> !ip) "[%s@]" Fun.id in - let addr = Lwt_unix.ADDR_INET (Unix.inet_addr_of_string unwrapped_ip, 0) in - let family = Unix.domain_of_sockaddr addr in - let s_ip = Lwt_unix.socket family Lwt_unix.SOCK_STREAM 0 in - (* INET socket, can't block *) - Lwt_unix.bind s_ip addr >>= fun () -> - Lwt_unix.listen s_ip 5 ; - let port = - match Lwt_unix.getsockname s_ip with - | Unix.ADDR_INET (_, port) -> - port - | _ -> - assert false - in - let s_unix = Lwt_unix.socket Lwt_unix.PF_UNIX Lwt_unix.SOCK_STREAM 0 in - (* Try to avoid polluting the filesystem with unused unix domain sockets *) - let path = - Printf.sprintf "%s/%s.%d" !unix - (Filename.basename Sys.argv.(0)) - (Unix.getpid ()) - in - if Sys.file_exists path then Unix.unlink path ; - Lwt_unix.bind s_unix (Lwt_unix.ADDR_UNIX path) >>= fun () -> - List.iter - (fun signal -> - ignore (Lwt_unix.on_signal signal (fun _ -> Unix.unlink path ; exit 1)) - ) - [Sys.sigterm; Sys.sigint] ; - Lwt_unix.listen s_unix 5 ; - let token = "token" in - let protocols = - let open Xcp_channel_protocol in - [TCP_proxy (!ip, port); Unix_sendmsg (my_domid, path, token)] - in - Printf.fprintf stdout "%s\n%!" - (Jsonrpc.to_string (Xcp_channel.rpc_of_protocols protocols)) ; - let t_ip = - Lwt_unix.accept s_ip >>= fun (fd, _peer) -> - Lwt_unix.close s_ip >>= fun () -> - proxy fd (Lwt_unix.of_unix_file_descr proxy_socket) - in - let t_unix = - Lwt_unix.accept s_unix >>= fun (fd, _peer) -> - let buffer = Bytes.make (String.length token) '\000' in - let io_vector = Lwt_unix.IO_vectors.create () in - Lwt_unix.IO_vectors.append_bytes io_vector buffer 0 (Bytes.length buffer) ; - Lwt_unix.recv_msg ~socket:fd ~io_vectors:io_vector >>= fun (n, fds) -> - List.iter Unix.close fds ; - let token' = Bytes.sub buffer 0 n in - let io_vector' = Lwt_unix.IO_vectors.create () in - Lwt_unix.IO_vectors.append_bytes io_vector' token' 0 (Bytes.length token') ; - if token = Bytes.to_string token' then - Lwt_unix.send_msg ~socket:fd ~io_vectors:io_vector' ~fds:[proxy_socket] - >>= fun _ -> return () - else - return () - in - Lwt.pick [t_ip; t_unix] >>= fun () -> Unix.unlink path ; return () - -let advertise common_options_t fd = - match fd with - | Some x -> - Lwt_main.run (advertise_t common_options_t (file_descr_of_int x)) ; - `Ok () - | None -> - `Error (true, "you must provide a file descriptor to proxy") - -let advertise_cmd = - let doc = "advertise a given channel represented as a file-descriptor" in - let man = - [ - `S "DESCRIPTION" - ; `P - "Advertises a given channel over as many protocols as possible, and \ - waits for someone to connect." - ] - @ help - in - let fd = - let doc = Printf.sprintf "File descriptor to advertise" in - Arg.(value & pos 0 (some int) None & info [] ~docv:"FD" ~doc) - in - Cmd.v - (Cmd.info "advertise" ~sdocs:_common_options ~doc ~man) - Term.(ret (const advertise $ common_options_t $ fd)) - -let connect_t _common_options_t = - (Lwt_io.read_line_opt Lwt_io.stdin >>= function - | None -> - return "" - | Some x -> - return x - ) - >>= fun advertisement -> - let open Xcp_channel in - let fd = - Lwt_unix.of_unix_file_descr - (file_descr_of_t (t_of_rpc (Jsonrpc.of_string advertisement))) - in - let a = copy_all Lwt_unix.stdin fd in - let b = copy_all fd Lwt_unix.stdout in - Lwt.join [a; b] - -let connect common_options_t = - Lwt_main.run (connect_t common_options_t) ; - `Ok () - -let connect_cmd = - let doc = "connect to a channel and proxy to the terminal" in - let man = - [ - `S "DESCRIPTION" - ; `P - "Connect to a channel which has been advertised and proxy I/O to the \ - console. The advertisement will be read from stdin as a single line \ - of text." - ] - @ help - in - Cmd.v - (Cmd.info "connect" ~sdocs:_common_options ~doc ~man) - Term.(ret (const connect $ common_options_t)) - -let cmds = [advertise_cmd; connect_cmd] - -let () = - let default = - Term.(ret (const (fun _ -> `Help (`Pager, None)) $ common_options_t)) - in - let info = - let doc = "channel (file-descriptor) passing helper program" in - let man = help in - Cmd.info "proxy" ~version:"1.0.0" ~sdocs:_common_options ~doc ~man - in - let cmd = Cmd.group ~default info cmds in - exit (Cmd.eval cmd) diff --git a/ocaml/xapi-idl/misc/dune b/ocaml/xapi-idl/misc/dune deleted file mode 100644 index 9d009d01260..00000000000 --- a/ocaml/xapi-idl/misc/dune +++ /dev/null @@ -1,16 +0,0 @@ -(executable - (name channel_helper) - (public_name xcp-idl-debugger) - (modules channel_helper) - (package xapi-idl) - (libraries - cmdliner - dune-build-info - lwt - lwt.unix - rpclib.core - rpclib.json - xapi-idl - xapi-log - ) - (preprocess (pps ppx_deriving_rpc))) diff --git a/quality-gate.sh b/quality-gate.sh index edc8415a473..be4e470fc94 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=514 + N=512 # do not count ml files from the tests in ocaml/{tests/perftest/quicktest} MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) From d3460a35122d0ea5e6faaed470d7755bf34d74c8 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 22 Jul 2024 15:37:37 +0100 Subject: [PATCH 026/157] opam: dunify vhd-tool's metadata Also add missing dependencies added recently Signed-off-by: Pau Ruiz Safont --- dune-project | 26 +++++++++++++++++++++ vhd-tool.opam | 52 ++++++++++++++++++++++++------------------ vhd-tool.opam.template | 40 -------------------------------- 3 files changed, 56 insertions(+), 62 deletions(-) delete mode 100644 vhd-tool.opam.template diff --git a/dune-project b/dune-project index 6d0c661ee31..fde96410f19 100644 --- a/dune-project +++ b/dune-project @@ -321,6 +321,32 @@ (package (name vhd-tool) + (synopsis "Manipulate .vhd files") + (tags ("org.mirage" "org:xapi-project")) + (depends + (alcotest-lwt :with-test) + cohttp-lwt + conf-libssl + (cstruct (>= "3.0.0")) + (ezxenstore (= :version)) + (forkexec (= :version)) + io-page + lwt + nbd-unix + ppx_cstruct + ppx_deriving_rpc + re + rpclib + sha + tar + (vhd-format (= :version)) + (vhd-format-lwt (= :version)) + (xapi-idl (= :version)) + (xapi-log (= :version)) + (xen-api-client-lwt (= :version)) + xenstore + xenstore_transport + ) ) (package diff --git a/vhd-tool.opam b/vhd-tool.opam index c1f8135c98d..9549a608df3 100644 --- a/vhd-tool.opam +++ b/vhd-tool.opam @@ -1,25 +1,20 @@ # This file is generated by dune, edit dune-project instead -license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" +synopsis: "Manipulate .vhd files" +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +tags: ["org.mirage" "org:xapi-project"] +homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -tags: [ - "org:mirage" - "org:xapi-project" -] -build: [[ "dune" "build" "-p" name "-j" jobs ] -] depends: [ - "ocaml" - "dune" + "dune" {>= "3.0"} "alcotest-lwt" {with-test} "cohttp-lwt" "conf-libssl" "cstruct" {>= "3.0.0"} - "forkexec" + "ezxenstore" {= version} + "forkexec" {= version} "io-page" "lwt" "nbd-unix" @@ -29,14 +24,27 @@ depends: [ "rpclib" "sha" "tar" - "vhd-format" - "vhd-format-lwt" - "xapi-idl" - "xapi-log" + "vhd-format" {= version} + "vhd-format-lwt" {= version} + "xapi-idl" {= version} + "xapi-log" {= version} + "xen-api-client-lwt" {= version} "xenstore" "xenstore_transport" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] ] -synopsis: ".vhd file manipulation" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} +dev-repo: "git+https://github.com/xapi-project/xen-api.git" diff --git a/vhd-tool.opam.template b/vhd-tool.opam.template deleted file mode 100644 index 52cf0e72d43..00000000000 --- a/vhd-tool.opam.template +++ /dev/null @@ -1,40 +0,0 @@ -opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" -bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -tags: [ - "org:mirage" - "org:xapi-project" -] -build: [[ "dune" "build" "-p" name "-j" jobs ] -] -depends: [ - "ocaml" - "dune" - "alcotest-lwt" {with-test} - "cohttp-lwt" - "conf-libssl" - "cstruct" {>= "3.0.0"} - "forkexec" - "io-page" - "lwt" - "nbd-unix" - "ppx_cstruct" - "ppx_deriving_rpc" - "re" - "rpclib" - "sha" - "tar" - "vhd-format" - "vhd-format-lwt" - "xapi-idl" - "xapi-log" - "xenstore" - "xenstore_transport" -] -synopsis: ".vhd file manipulation" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} From 541c03dcab7370a86bf023e57bb82e8695764e16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 10 May 2024 11:47:50 +0100 Subject: [PATCH 027/157] CP-47536: replace Protocol_unix.scheduler.Delay with Threadext.Delay MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Its implementation was identical, except for the use of time_limited_read in Threadext, but the semantics is identical. Use one well tested implementation instead of duplicating code. One less function to convert to epoll. Signed-off-by: Edwin Török --- message-switch-unix.opam | 1 + ocaml/message-switch/unix/dune | 1 + .../unix/protocol_unix_scheduler.ml | 66 +------------------ 3 files changed, 3 insertions(+), 65 deletions(-) diff --git a/message-switch-unix.opam b/message-switch-unix.opam index 64fd72db241..67b0bd817e3 100644 --- a/message-switch-unix.opam +++ b/message-switch-unix.opam @@ -19,6 +19,7 @@ depends: [ "base-threads" "message-switch-core" "ppx_deriving_rpc" + "xapi-stdext-unix" ] synopsis: "A simple store-and-forward message switch" description: """ diff --git a/ocaml/message-switch/unix/dune b/ocaml/message-switch/unix/dune index 54b6c0e77bf..3e088a12556 100644 --- a/ocaml/message-switch/unix/dune +++ b/ocaml/message-switch/unix/dune @@ -11,6 +11,7 @@ rpclib.core rpclib.json threads.posix + xapi-stdext-threads ) (preprocess (pps ppx_deriving_rpc)) ) diff --git a/ocaml/message-switch/unix/protocol_unix_scheduler.ml b/ocaml/message-switch/unix/protocol_unix_scheduler.ml index 92e6cdd3b1b..3eaeb83218c 100644 --- a/ocaml/message-switch/unix/protocol_unix_scheduler.ml +++ b/ocaml/message-switch/unix/protocol_unix_scheduler.ml @@ -34,71 +34,7 @@ module Int64Map = Map.Make (struct let compare = compare end) -module Delay = struct - (* Concrete type is the ends of a pipe *) - type t = { - (* A pipe is used to wake up a thread blocked in wait: *) - mutable pipe_out: Unix.file_descr option - ; mutable pipe_in: Unix.file_descr option - ; (* Indicates that a signal arrived before a wait: *) - mutable signalled: bool - ; m: Mutex.t - } - - let make () = - {pipe_out= None; pipe_in= None; signalled= false; m= Mutex.create ()} - - exception Pre_signalled - - let wait (x : t) (seconds : float) = - let to_close = ref [] in - let close' fd = - if List.mem fd !to_close then Unix.close fd ; - to_close := List.filter (fun x -> fd <> x) !to_close - in - finally' - (fun () -> - try - let pipe_out = - Mutex.execute x.m (fun () -> - if x.signalled then ( - x.signalled <- false ; - raise Pre_signalled - ) ; - let pipe_out, pipe_in = Unix.pipe () in - (* these will be unconditionally closed on exit *) - to_close := [pipe_out; pipe_in] ; - x.pipe_out <- Some pipe_out ; - x.pipe_in <- Some pipe_in ; - x.signalled <- false ; - pipe_out - ) - in - let r, _, _ = Unix.select [pipe_out] [] [] seconds in - (* flush the single byte from the pipe *) - if r <> [] then ignore (Unix.read pipe_out (Bytes.create 1) 0 1) ; - (* return true if we waited the full length of time, false if we were woken *) - r = [] - with Pre_signalled -> false - ) - (fun () -> - Mutex.execute x.m (fun () -> - x.pipe_out <- None ; - x.pipe_in <- None ; - List.iter close' !to_close - ) - ) - - let signal (x : t) = - Mutex.execute x.m (fun () -> - match x.pipe_in with - | Some fd -> - ignore (Unix.write fd (Bytes.of_string "X") 0 1) - | None -> - x.signalled <- true - (* If the wait hasn't happened yet then store up the signal *) - ) -end +module Delay = Xapi_stdext_threads.Threadext.Delay type item = {id: int; name: string; fn: unit -> unit} From d9590a0b341a88b3b047b2a4c4945954535ca10b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 10 Jun 2024 17:19:05 +0100 Subject: [PATCH 028/157] fix(xapi-idl): replace PipeDelay with Delay, avoid another Thread.wait_timed_read MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-idl/lib/scheduler.ml | 28 +--------------------------- 1 file changed, 1 insertion(+), 27 deletions(-) diff --git a/ocaml/xapi-idl/lib/scheduler.ml b/ocaml/xapi-idl/lib/scheduler.ml index 407120c9fc6..d4d5c7c5cca 100644 --- a/ocaml/xapi-idl/lib/scheduler.ml +++ b/ocaml/xapi-idl/lib/scheduler.ml @@ -18,33 +18,7 @@ open D let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute -module PipeDelay = struct - (* Concrete type is the ends of a pipe *) - type t = { - (* A pipe is used to wake up a thread blocked in wait: *) - pipe_out: Unix.file_descr - ; pipe_in: Unix.file_descr - } - - let make () = - let pipe_out, pipe_in = Unix.pipe () in - {pipe_out; pipe_in} - - let wait (x : t) (seconds : float) = - let timeout = if seconds < 0.0 then 0.0 else seconds in - if Thread.wait_timed_read x.pipe_out timeout then - (* flush the single byte from the pipe *) - let (_ : int) = Unix.read x.pipe_out (Bytes.create 1) 0 1 in - (* return false if we were woken *) - false - else - (* return true if we waited the full length of time, false if we were woken *) - true - - let signal (x : t) = - let (_ : int) = Unix.write x.pipe_in (Bytes.of_string "X") 0 1 in - () -end +module PipeDelay = Xapi_stdext_threads.Threadext.Delay type handle = Mtime.span * int From 4f587b0b7f9ff452195bd8d889bed123e70a8b4e Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 22 Jul 2024 16:39:25 +0100 Subject: [PATCH 029/157] opam: dunify message-switch-unix's metadata Signed-off-by: Pau Ruiz Safont --- dune-project | 10 ++++++ message-switch-unix.opam | 51 +++++++++++++++++-------------- message-switch-unix.opam.template | 27 ---------------- 3 files changed, 38 insertions(+), 50 deletions(-) delete mode 100644 message-switch-unix.opam.template diff --git a/dune-project b/dune-project index fde96410f19..481ea148048 100644 --- a/dune-project +++ b/dune-project @@ -464,6 +464,16 @@ This package provides an Lwt compatible interface to the library.") (package (name message-switch-unix) + (synopsis "A simple store-and-forward message switch") + (description "The switch stores messages in queues with well-known names. Clients use a simple HTTP protocol to enqueue and dequeue messages.") + (depends + base-threads + cohttp + (message-switch-core (= :version)) + ppx_deriving_rpc + rpclib + (xapi-stdext-threads (= :version)) + ) ) (package diff --git a/message-switch-unix.opam b/message-switch-unix.opam index 67b0bd817e3..cd086195cb2 100644 --- a/message-switch-unix.opam +++ b/message-switch-unix.opam @@ -1,30 +1,35 @@ # This file is generated by dune, edit dune-project instead -license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" opam-version: "2.0" -name: "message-switch-unix" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" +synopsis: "A simple store-and-forward message switch" +description: + "The switch stores messages in queues with well-known names. Clients use a simple HTTP protocol to enqueue and dequeue messages." +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -tags: [ "org:xapi-project" ] -build: [ - ["./configure" "--prefix" "%{prefix}%"] - [ "dune" "build" "-p" name "-j" jobs ] -] depends: [ - "ocaml" - "dune" {build & >= "1.4"} - "odoc" {with-doc} + "dune" {>= "3.0"} "base-threads" - "message-switch-core" + "cohttp" + "message-switch-core" {= version} "ppx_deriving_rpc" - "xapi-stdext-unix" + "rpclib" + "xapi-stdext-threads" {= version} + "odoc" {with-doc} ] -synopsis: "A simple store-and-forward message switch" -description: """ -The switch stores messages in queues with well-known names. Clients use -a simple HTTP protocol to enqueue and dequeue messages.""" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" diff --git a/message-switch-unix.opam.template b/message-switch-unix.opam.template deleted file mode 100644 index f21bd6e1883..00000000000 --- a/message-switch-unix.opam.template +++ /dev/null @@ -1,27 +0,0 @@ -opam-version: "2.0" -name: "message-switch-unix" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" -bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -tags: [ "org:xapi-project" ] -build: [ - ["./configure" "--prefix" "%{prefix}%"] - [ "dune" "build" "-p" name "-j" jobs ] -] -depends: [ - "ocaml" - "dune" {build & >= "1.4"} - "odoc" {with-doc} - "base-threads" - "message-switch-core" - "ppx_deriving_rpc" -] -synopsis: "A simple store-and-forward message switch" -description: """ -The switch stores messages in queues with well-known names. Clients use -a simple HTTP protocol to enqueue and dequeue messages.""" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} From d88017e65c4eb814f7a522b11f3f952664c57c70 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 22 Jul 2024 10:42:25 +0100 Subject: [PATCH 030/157] IH-507: xapi_xenops: raise an error when the kernel isn't allowed Previously the path was replaced by an empty string, when trying to start he vm. The only feedback was on the logs as a debug message, but not all users that start VMs have access to the logs. Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/xapi_xenops.ml | 110 +++++++++++++++++++------------------- 1 file changed, 54 insertions(+), 56 deletions(-) diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 50aa2c6c53d..1da207c74f8 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -337,19 +337,43 @@ let rtc_timeoffset_of_vm ~__context (vm, vm_t) vbds = ) ) -(* /boot/ contains potentially sensitive files like xen-initrd, so we will only*) -(* allow directly booting guests from the subfolder /boot/guest/ *) +(* /boot/ contains potentially sensitive files like xen-initrd, only allow + directly booting guests from the subfolder /boot/guest/ *) let allowed_dom0_directories_for_boot_files = - ["/boot/guest/"; "/var/lib/xcp/guest"] - -let is_boot_file_whitelisted filename = - let safe_str str = not (String.has_substr str "..") in - (* make sure the script prefix is the allowed dom0 directory *) - List.exists - (fun allowed -> String.starts_with ~prefix:allowed filename) - allowed_dom0_directories_for_boot_files - (* avoid ..-style attacks and other weird things *) - && safe_str filename + ["/boot/guest/"; "/var/lib/xcp/guest/"] + +let kernel_path filename = + let ( let* ) = Result.bind in + let* real_path = + try Ok (Unix.realpath filename) with + | Unix.(Unix_error (ENOENT, _, _)) -> + let reason = "File does not exist" in + Error (filename, reason) + | exn -> + let reason = Printexc.to_string exn in + Error (filename, reason) + in + let* () = + match Unix.stat real_path with + | {st_kind= Unix.S_REG; _} -> + Ok () + | _ -> + let reason = "Is not a regular file" in + Error (filename, reason) + in + let allowed = + List.exists + (fun allowed -> String.starts_with ~prefix:allowed real_path) + allowed_dom0_directories_for_boot_files + in + if not allowed then + let reason = + Printf.sprintf "Is not in any of the allowed kernel directories: [%s]" + (String.concat "; " allowed_dom0_directories_for_boot_files) + in + Error (filename, reason) + else + Ok real_path let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu = let open Vm in @@ -372,19 +396,12 @@ let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu = Cirrus in let pci_emulations = - let s = - try Some (List.assoc "mtc_pci_emulations" vm.API.vM_other_config) - with _ -> None - in + let s = List.assoc_opt "mtc_pci_emulations" vm.API.vM_other_config in match s with | None -> [] - | Some x -> ( - try - let l = String.split ',' x in - List.map (String.strip String.isspace) l - with _ -> [] - ) + | Some x -> + String.split_on_char ',' x |> List.map String.trim in let make_hvmloader_boot_record () = if bool vm.API.vM_platform false "qemu_stubdom" then @@ -427,15 +444,10 @@ let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu = ; acpi= bool vm.API.vM_platform true "acpi" ; serial= ((* The platform value should override the other_config value. If - * neither are set, use pty. *) + neither are set, use pty. *) let key = "hvm_serial" in - let other_config_value = - try Some (List.assoc key vm.API.vM_other_config) - with Not_found -> None - in - let platform_value = - try Some (List.assoc key vm.API.vM_platform) with Not_found -> None - in + let other_config_value = List.assoc_opt key vm.API.vM_other_config in + let platform_value = List.assoc_opt key vm.API.vM_platform in match (other_config_value, platform_value) with | None, None -> Some "pty" @@ -444,10 +456,7 @@ let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu = | Some value, None -> Some value ) - ; keymap= - ( try Some (List.assoc "keymap" vm.API.vM_platform) - with Not_found -> None - ) + ; keymap= List.assoc_opt "keymap" vm.API.vM_platform ; vnc_ip= None (*None PR-1255*) ; pci_emulations ; pci_passthrough @@ -464,30 +473,19 @@ let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu = ; tpm= tpm_of_vm () } in - let make_direct_boot_record - {Helpers.kernel= k; kernel_args= ka; ramdisk= initrd} = - let k = - if is_boot_file_whitelisted k then - k - else ( - debug "kernel %s is not in the whitelist: ignoring" k ; - "" - ) - in - let initrd = - Option.map - (fun x -> - if is_boot_file_whitelisted x then - x - else ( - debug "initrd %s is not in the whitelist: ignoring" k ; - "" - ) - ) - initrd + let make_direct_boot_record {Helpers.kernel; kernel_args= ka; ramdisk} = + let resolve name ~path = + match kernel_path path with + | Ok k -> + k + | Error (file, msg) -> + info {|%s: refusing to load %s "%s": %s|} __FUNCTION__ name file msg ; + raise Api_errors.(Server_error (invalid_value, [name; file; msg])) in + let kernel = resolve "kernel" ~path:kernel in + let ramdisk = Option.map (fun k -> resolve "ramdisk" ~path:k) ramdisk in { - boot= Direct {kernel= k; cmdline= ka; ramdisk= initrd} + boot= Direct {kernel; cmdline= ka; ramdisk} ; framebuffer= bool vm.API.vM_platform false "pvfb" ; framebuffer_ip= None (* None PR-1255 *) ; vncterm= not (List.mem_assoc "disable_pv_vnc" vm.API.vM_other_config) From 5dc2900f1f808c2b49a6ecbda3720b0b8d70a917 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 23 Jul 2024 11:23:07 +0100 Subject: [PATCH 031/157] IH-507: Do not allow guest kernels in /boot/ This location is for dom0's boot chain exclusively Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/xapi_xenops.ml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 1da207c74f8..cb1932aab0a 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -337,10 +337,7 @@ let rtc_timeoffset_of_vm ~__context (vm, vm_t) vbds = ) ) -(* /boot/ contains potentially sensitive files like xen-initrd, only allow - directly booting guests from the subfolder /boot/guest/ *) -let allowed_dom0_directories_for_boot_files = - ["/boot/guest/"; "/var/lib/xcp/guest/"] +let allowed_dom0_directories_for_boot_files = ["/var/lib/xcp/guest/"] let kernel_path filename = let ( let* ) = Result.bind in From ba3f0e7309d8021ee31450e0d1d7b9bbdc69b716 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Mon, 22 Jul 2024 15:34:57 +0100 Subject: [PATCH 032/157] CP-50181: Percent decode all Uri paths before using them `Uri.path` returns percent-encoded output, therefore it can't be expected to behave correctly in cases where it's used to map to Unix files. Our PR upstream introduced 'Uri.path_unencoded' function, use that instead. Signed-off-by: Andrii Sultanov --- ocaml/libs/http-lib/http.ml | 4 ++-- ocaml/libs/http-lib/http_svr.ml | 2 +- ocaml/libs/open-uri/open_uri.ml | 2 +- ocaml/message-switch/switch/switch_main.ml | 2 +- ocaml/nbd/src/main.ml | 2 +- ocaml/vhd-tool/src/impl.ml | 4 ++-- ocaml/xapi-guard/lib/server_interface.ml | 9 ++++----- ocaml/xapi-idl/lib/xcp_service.ml | 6 +++--- .../volume/org.xen.xcp.storage.plainlvm/common.ml | 2 +- ocaml/xapi-storage-script/main.ml | 4 ++-- ocaml/xe-cli/newcli.ml | 2 +- ocaml/xen-api-client/lwt/xen_api_lwt_unix.ml | 2 +- ocaml/xenopsd/lib/xenops_server.ml | 8 ++++---- 13 files changed, 24 insertions(+), 25 deletions(-) diff --git a/ocaml/libs/http-lib/http.ml b/ocaml/libs/http-lib/http.ml index c6ff41be709..ed009448ab1 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -916,7 +916,7 @@ module Url = struct in let data = { - uri= (match Uri.path uri with "" -> "/" | path -> path) + uri= (match Uri.path_unencoded uri with "" -> "/" | path -> path) ; query_params= Uri.query uri |> List.map query } in @@ -929,7 +929,7 @@ module Url = struct | Some "https" -> (scheme ~ssl:true, data) | Some "file" -> - let scheme = File {path= Uri.path uri} in + let scheme = File {path= Uri.path_unencoded uri} in (scheme, {data with uri= "/"}) | _ -> failwith "unsupported URI scheme" diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index d8718bd68a6..9eff99cbd22 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -377,7 +377,7 @@ let request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length bio (* Request-Line = Method SP Request-URI SP HTTP-Version CRLF *) let uri_t = Uri.of_string uri in if uri_t = Uri.empty then raise Http_parse_failure ; - let uri = Uri.path uri_t |> Uri.pct_decode in + let uri = Uri.path_unencoded uri_t in let query = Uri.query uri_t |> kvlist_flatten in let m = Http.method_t_of_string meth in let version = diff --git a/ocaml/libs/open-uri/open_uri.ml b/ocaml/libs/open-uri/open_uri.ml index 84cbd3b6ab5..2e3cda05413 100644 --- a/ocaml/libs/open-uri/open_uri.ml +++ b/ocaml/libs/open-uri/open_uri.ml @@ -74,7 +74,7 @@ let with_open_uri ?verify_cert uri f = ) ) | Some "file" -> - let filename = Uri.path_and_query uri in + let filename = Uri.path_and_query uri |> Uri.pct_decode in let sockaddr = Unix.ADDR_UNIX filename in let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in finally diff --git a/ocaml/message-switch/switch/switch_main.ml b/ocaml/message-switch/switch/switch_main.ml index 583baf6e594..7fb907d1cb2 100644 --- a/ocaml/message-switch/switch/switch_main.ml +++ b/ocaml/message-switch/switch/switch_main.ml @@ -222,7 +222,7 @@ let make_server config trace_config = let open Message_switch_core.Protocol in Cohttp_lwt.Body.to_string body >>= fun body -> let uri = Cohttp.Request.uri req in - let path = Uri.path uri in + let path = Uri.path_unencoded uri in match In.of_request body (Cohttp.Request.meth req) path with | None -> error "<- [unparsable request; path = %s; body = %s]" path diff --git a/ocaml/nbd/src/main.ml b/ocaml/nbd/src/main.ml index d8f67a8c49a..25919464839 100644 --- a/ocaml/nbd/src/main.ml +++ b/ocaml/nbd/src/main.ml @@ -59,7 +59,7 @@ let handle_connection fd tls_role = >>= fun session_id -> f uri rpc session_id in let serve t uri rpc session_id = - let path = Uri.path uri in + let path = Uri.path_unencoded uri in (* note preceeding / *) let vdi_uuid = if path <> "" then String.sub path 1 (String.length path - 1) else path diff --git a/ocaml/vhd-tool/src/impl.ml b/ocaml/vhd-tool/src/impl.ml index 54058316625..6052e77eb52 100644 --- a/ocaml/vhd-tool/src/impl.ml +++ b/ocaml/vhd-tool/src/impl.ml @@ -787,9 +787,9 @@ let endpoint_of_string = function if he = [] then raise Not_found ; return (Sockaddr (List.hd he).Unix.ai_addr) | Some "unix", _ -> - return (Sockaddr (Lwt_unix.ADDR_UNIX (Uri.path uri'))) + return (Sockaddr (Lwt_unix.ADDR_UNIX (Uri.path_unencoded uri'))) | Some "file", _ -> - return (File (Uri.path uri')) + return (File (Uri.path_unencoded uri')) | Some "http", _ -> return (Http uri') | Some "https", _ -> diff --git a/ocaml/xapi-guard/lib/server_interface.ml b/ocaml/xapi-guard/lib/server_interface.ml index d58a934f5f2..c6f70769313 100644 --- a/ocaml/xapi-guard/lib/server_interface.ml +++ b/ocaml/xapi-guard/lib/server_interface.ml @@ -77,9 +77,8 @@ let serve_forever_lwt path callback = Lwt.return cleanup let serve_forever_lwt_callback rpc_fn path _ req body = - let uri = Cohttp.Request.uri req in - match (Cohttp.Request.meth req, Uri.path uri) with - | `POST, _ -> + match Cohttp.Request.meth req with + | `POST -> let* body = Cohttp_lwt.Body.to_string body in let* response = Xapi_guard.Dorpc.wrap_rpc err (fun () -> @@ -91,7 +90,7 @@ let serve_forever_lwt_callback rpc_fn path _ req body = in let body = response |> Xmlrpc.string_of_response in Cohttp_lwt_unix.Server.respond_string ~status:`OK ~body () - | _, _ -> + | _ -> let body = "Not allowed" |> Rpc.rpc_of_string @@ -142,7 +141,7 @@ let serve_forever_lwt_callback_vtpm ~cache mutex (read, persist) vm_uuid _ req *) Lwt_mutex.with_lock mutex @@ fun () -> (* TODO: some logging *) - match (Cohttp.Request.meth req, Uri.path uri) with + match (Cohttp.Request.meth req, Uri.path_unencoded uri) with | `GET, path when path <> "/" -> let key = Tpm.key_of_swtpm path in let* body = read (vm_uuid, timestamp, key) in diff --git a/ocaml/xapi-idl/lib/xcp_service.ml b/ocaml/xapi-idl/lib/xcp_service.ml index 69217d8328c..d6c3cae14db 100644 --- a/ocaml/xapi-idl/lib/xcp_service.ml +++ b/ocaml/xapi-idl/lib/xcp_service.ml @@ -501,8 +501,8 @@ let http_handler call_of_string string_of_response process s = | `Invalid x -> debug "Failed to read HTTP request. Got: '%s'" x | `Ok req -> ( - match (Cohttp.Request.meth req, Uri.path (Cohttp.Request.uri req)) with - | `POST, _ -> ( + match Cohttp.Request.meth req with + | `POST -> ( let headers = Cohttp.Request.headers req in match Cohttp.Header.get headers "content-length" with | None -> @@ -535,7 +535,7 @@ let http_handler call_of_string string_of_response process s = (fun t -> Response.write_body t response_txt) response oc ) - | _, _ -> + | _ -> let content_length = 0 in let headers = Cohttp.Header.of_list diff --git a/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml b/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml index 298099be057..018c133c8dd 100644 --- a/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml +++ b/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml @@ -333,7 +333,7 @@ let vg_of_uri uri = let uri' = Uri.of_string uri in match Uri.scheme uri' with | Some "vg" -> - let vg = Uri.path uri' in + let vg = Uri.path_unencoded uri' in if vg <> "" && vg.[0] = '/' then String.sub vg 1 (String.length vg - 1) else diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index 2c904af7a43..9a21f7c2313 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -977,7 +977,7 @@ let bind ~volume_script_dir = let uri = Uri.of_string datasource in match Uri.scheme uri with | Some "xeno+shm" -> ( - let uid = Uri.path uri in + let uid = Uri.path_unencoded uri in let uid = if String.length uid > 1 then String.sub uid ~pos:1 ~len:(String.length uid - 1) @@ -1024,7 +1024,7 @@ let bind ~volume_script_dir = let uri = Uri.of_string datasource in match Uri.scheme uri with | Some "xeno+shm" -> ( - let uid = Uri.path uri in + let uid = Uri.path_unencoded uri in let uid = if String.length uid > 1 then String.sub uid ~pos:1 ~len:(String.length uid - 1) diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index 9be987f028b..520d43e0061 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -135,7 +135,7 @@ let parse_url url = let ( let* ) = Option.bind in let* scheme = Uri.scheme uri in let* host = Uri.host uri in - let path = Uri.path_and_query uri in + let path = Uri.path_and_query uri |> Uri.pct_decode in Some (scheme, host, path) in match parse (Uri.of_string url) with diff --git a/ocaml/xen-api-client/lwt/xen_api_lwt_unix.ml b/ocaml/xen-api-client/lwt/xen_api_lwt_unix.ml index 863f32f0829..a69e9423087 100644 --- a/ocaml/xen-api-client/lwt/xen_api_lwt_unix.ml +++ b/ocaml/xen-api-client/lwt/xen_api_lwt_unix.ml @@ -66,7 +66,7 @@ module Lwt_unix_IO = struct let open_connection uri = ( match Uri.scheme uri with | Some "file" -> - return (Unix.PF_UNIX, Unix.ADDR_UNIX (Uri.path uri), false) + return (Unix.PF_UNIX, Unix.ADDR_UNIX (Uri.path_unencoded uri), false) | Some "http+unix" -> return (Unix.PF_UNIX, Unix.ADDR_UNIX (Uri.host_with_default uri), false) | Some "http" | Some "https" -> diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index c7fc910ea33..71ad563ed19 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -2629,7 +2629,7 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) let make_url snippet id_str = Uri.make ?scheme:(Uri.scheme url) ?host:(Uri.host url) ?port:(Uri.port url) - ~path:(Uri.path url ^ snippet ^ id_str) + ~path:(Uri.path_unencoded url ^ snippet ^ id_str) ~query:(Uri.query url) () in (* CA-78365: set the memory dynamic range to a single value to stop @@ -3630,7 +3630,7 @@ module VM = struct debug "traceparent: %s" (Option.value ~default:"(none)" traceparent) ; let id, final_id = (* The URI is /service/xenops/memory/id *) - let bits = Astring.String.cuts ~sep:"/" (Uri.path uri) in + let bits = Astring.String.cuts ~sep:"/" (Uri.path_unencoded uri) in let id = bits |> List.rev |> List.hd in let final_id = match List.assoc_opt "final_id" cookies with @@ -3673,7 +3673,7 @@ module VM = struct (fun () -> let vgpu_id = (* The URI is /service/xenops/migrate-vgpu/id *) - let path = Uri.path uri in + let path = Uri.path_unencoded uri in let bits = Astring.String.cut ~sep:"/" ~rev:true path in let vgpu_id_str = match bits with @@ -3736,7 +3736,7 @@ module VM = struct let dbg = List.assoc "dbg" cookies in Debug.with_thread_associated dbg (fun () -> - let vm = basename (Uri.path uri) in + let vm = basename (Uri.path_unencoded uri) in match context.transferred_fd with | Some fd -> debug "VM.receive_mem: passed fd %d" (Obj.magic fd) ; From a7b7a26bc1b1bba52ee1d6d82177fc2dca99f56c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:32 +0000 Subject: [PATCH 033/157] [maintenance] bump minimum dune language version to 3.7 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Some features of Dune are only available when a new language version is used (e.g. 'package' for 'library' stanzas would require bumping this to 2.8). Defaults also change, e.g. 3.0+ enables `executables_implicit_empty_intf` which can be beneficial for finding dead code in executables. But more importantly Dune versions <3.7 have a binary corruption bug with executable promotion that got fixed here: https://github.com/ocaml/dune/commit/f0c708c83abd1b20313f779aefcb65410110052f Require dune >= 3.7. The version bumps also comes with many more unused warnings enabled by default, turn these back into warnings and do not fail the build. (Once they are fixed we can remove the -warn-error list) No functional change. Signed-off-by: Edwin Török --- dune | 2 +- dune-project | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/dune b/dune index e2b4842adb5..9cf03f02dfc 100644 --- a/dune +++ b/dune @@ -3,7 +3,7 @@ (ocamlopt_flags (:standard -g -p -w -39)) (flags (:standard -w -39)) ) - (dev (flags (:standard -g -w -39))) + (dev (flags (:standard -g -w -39 -warn-error -69))) (release (flags (:standard -w -39-6@5)) (env-vars (ALCOTEST_COMPACT 1)) diff --git a/dune-project b/dune-project index 481ea148048..59624a34056 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,5 @@ -(lang dune 3.0) +(lang dune 3.7) + (formatting (enabled_for ocaml)) (using menhir 2.0) From 5353e3e5c58335dda9bb38ad074c51620cd88960 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 23 Jul 2024 09:22:58 +0100 Subject: [PATCH 034/157] [maintenance]: bump dune language version to 3.15 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is the version we currently use in xs-opam. Newer dune version may also come with more warnings enabled by default. Signed-off-by: Edwin Török --- dune-project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dune-project b/dune-project index 59624a34056..ad3b41392d1 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 3.7) +(lang dune 3.15) (formatting (enabled_for ocaml)) (using menhir 2.0) From d802d43adb93ea845ce8888a6822bb16d6380242 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:32 +0000 Subject: [PATCH 035/157] [maintenance] regenerate opam after dune version bump MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit No functional change. Signed-off-by: Edwin Török --- clock.opam | 2 +- forkexec.opam | 2 +- http-lib.opam | 2 +- message-switch-core.opam | 2 +- message-switch-unix.opam | 2 +- message-switch.opam | 1 + message-switch.opam.template | 1 + rrd-transport.opam | 2 +- rrdd-plugin.opam | 2 +- vhd-format-lwt.opam | 2 +- vhd-tool.opam | 2 +- wsproxy.opam | 2 +- xapi-forkexecd.opam | 2 +- xapi-networkd.opam | 2 +- xapi-rrd-transport-utils.opam | 2 +- xapi-rrdd.opam | 2 +- xapi-sdk.opam | 2 +- xapi-stdext-date.opam | 2 +- xapi-stdext-encodings.opam | 2 +- xapi-stdext-pervasives.opam | 2 +- xapi-stdext-std.opam | 2 +- xapi-stdext-threads.opam | 2 +- xapi-stdext-unix.opam | 2 +- xapi-stdext-zerocheck.opam | 2 +- xapi-tracing-export.opam | 2 +- xapi-tracing.opam | 2 +- xen-api-client.opam | 2 +- 27 files changed, 27 insertions(+), 25 deletions(-) diff --git a/clock.opam b/clock.opam index 44c24235c58..52cc8d0ef09 100644 --- a/clock.opam +++ b/clock.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.12"} "alcotest" {with-test} "astring" diff --git a/forkexec.opam b/forkexec.opam index 3aea97441c2..6d6d2504488 100644 --- a/forkexec.opam +++ b/forkexec.opam @@ -8,7 +8,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "base-threads" "fd-send-recv" {>= "2.0.0"} "ppx_deriving_rpc" diff --git a/http-lib.opam b/http-lib.opam index 77965984777..e8a5de4ddc9 100644 --- a/http-lib.opam +++ b/http-lib.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "astring" "base64" {>= "3.1.0"} diff --git a/message-switch-core.opam b/message-switch-core.opam index 2d671053b9b..2fd00d31457 100644 --- a/message-switch-core.opam +++ b/message-switch-core.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "astring" "cohttp" {>= "0.21.1"} "ppx_deriving_rpc" diff --git a/message-switch-unix.opam b/message-switch-unix.opam index cd086195cb2..c9379979e2d 100644 --- a/message-switch-unix.opam +++ b/message-switch-unix.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "base-threads" "cohttp" "message-switch-core" {= version} diff --git a/message-switch.opam b/message-switch.opam index 39cf5bea18a..b09cec4ca7c 100644 --- a/message-switch.opam +++ b/message-switch.opam @@ -31,6 +31,7 @@ depends: [ "ppx_sexp_conv" "sexplib" "shared-block-ring" {>= "2.3.0"} + "xapi-stdext-unix" ] synopsis: "A simple store-and-forward message switch" description: """ diff --git a/message-switch.opam.template b/message-switch.opam.template index 5322fe9f419..793c8aceaa5 100644 --- a/message-switch.opam.template +++ b/message-switch.opam.template @@ -29,6 +29,7 @@ depends: [ "ppx_sexp_conv" "sexplib" "shared-block-ring" {>= "2.3.0"} + "xapi-stdext-unix" ] synopsis: "A simple store-and-forward message switch" description: """ diff --git a/rrd-transport.opam b/rrd-transport.opam index 55ff4e7b0b2..07fe41dd8cc 100644 --- a/rrd-transport.opam +++ b/rrd-transport.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "astring" "cstruct" diff --git a/rrdd-plugin.opam b/rrdd-plugin.opam index 6bab281c970..5b113952b04 100644 --- a/rrdd-plugin.opam +++ b/rrdd-plugin.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" "astring" "rpclib" diff --git a/vhd-format-lwt.opam b/vhd-format-lwt.opam index 49acf611147..e89b1cfdc7c 100644 --- a/vhd-format-lwt.opam +++ b/vhd-format-lwt.opam @@ -16,7 +16,7 @@ tags: ["org:mirage" "org:xapi-project"] homepage: "https://github.com/mirage/ocaml-vhd" bug-reports: "https://github.com/mirage/ocaml-vhd/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.02.3" & < "5.0.0"} "alcotest" {with-test} "alcotest-lwt" {with-test} diff --git a/vhd-tool.opam b/vhd-tool.opam index 9549a608df3..f0135ab7a41 100644 --- a/vhd-tool.opam +++ b/vhd-tool.opam @@ -8,7 +8,7 @@ tags: ["org.mirage" "org:xapi-project"] homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest-lwt" {with-test} "cohttp-lwt" "conf-libssl" diff --git a/wsproxy.opam b/wsproxy.opam index 9e9def30a82..0d9e79c096c 100644 --- a/wsproxy.opam +++ b/wsproxy.opam @@ -7,7 +7,7 @@ license: "LGPL-2.0-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "base64" {>= "3.1.0"} "fmt" diff --git a/xapi-forkexecd.opam b/xapi-forkexecd.opam index 900419be134..6f2ccbffdb8 100644 --- a/xapi-forkexecd.opam +++ b/xapi-forkexecd.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "astring" "forkexec" {= version} "uuid" {= version} diff --git a/xapi-networkd.opam b/xapi-networkd.opam index 595478821f2..ef37bd16486 100644 --- a/xapi-networkd.opam +++ b/xapi-networkd.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "astring" "base-threads" diff --git a/xapi-rrd-transport-utils.opam b/xapi-rrd-transport-utils.opam index 261da91a4e3..754b956f157 100644 --- a/xapi-rrd-transport-utils.opam +++ b/xapi-rrd-transport-utils.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" "cmdliner" "rrd-transport" {= version} diff --git a/xapi-rrdd.opam b/xapi-rrdd.opam index 0782309fe06..8ec47c8322d 100644 --- a/xapi-rrdd.opam +++ b/xapi-rrdd.opam @@ -9,7 +9,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.02.0"} "dune-build-info" "alcotest" {with-test} diff --git a/xapi-sdk.opam b/xapi-sdk.opam index 93dbd1d640a..b09d4c60808 100644 --- a/xapi-sdk.opam +++ b/xapi-sdk.opam @@ -7,7 +7,7 @@ license: "BSD-2-Clause" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "astring" "mustache" diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index ee8aa096ab2..06021447900 100644 --- a/xapi-stdext-date.opam +++ b/xapi-stdext-date.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "clock" {= version} "ptime" "odoc" {with-doc} diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index c0f8c27c5e7..bed359bb9e0 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.13.0"} "alcotest" {>= "0.6.0" & with-test} "odoc" {with-doc} diff --git a/xapi-stdext-pervasives.opam b/xapi-stdext-pervasives.opam index 83f4f2da1da..bfab6d693b3 100644 --- a/xapi-stdext-pervasives.opam +++ b/xapi-stdext-pervasives.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.08"} "logs" "odoc" {with-doc} diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam index 4cee75aac36..753fcd696d1 100644 --- a/xapi-stdext-std.opam +++ b/xapi-stdext-std.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.08.0"} "alcotest" {with-test} "odoc" {with-doc} diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index 4adef00e43e..eba91836d0f 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "base-threads" "base-unix" "odoc" {with-doc} diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index e154fe829da..4daa2eb9326 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "ocaml" {>= "4.12.0"} "alcotest" {with-test} "base-unix" diff --git a/xapi-stdext-zerocheck.opam b/xapi-stdext-zerocheck.opam index 6b6dfc62f9b..d20671b901b 100644 --- a/xapi-stdext-zerocheck.opam +++ b/xapi-stdext-zerocheck.opam @@ -7,7 +7,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "odoc" {with-doc} ] build: [ diff --git a/xapi-tracing-export.opam b/xapi-tracing-export.opam index 4ec270f6328..fb00c67bc06 100644 --- a/xapi-tracing-export.opam +++ b/xapi-tracing-export.opam @@ -11,7 +11,7 @@ bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "ocaml" "cohttp-posix" - "dune" {>= "3.0"} + "dune" {>= "3.15"} "cohttp" "rpclib" "ppx_deriving_rpc" diff --git a/xapi-tracing.opam b/xapi-tracing.opam index f2dbbd2b132..a2ae1016cea 100644 --- a/xapi-tracing.opam +++ b/xapi-tracing.opam @@ -10,7 +10,7 @@ homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "ocaml" - "dune" {>= "3.0"} + "dune" {>= "3.15"} "alcotest" {with-test} "re" "uri" diff --git a/xen-api-client.opam b/xen-api-client.opam index 3c31159d66c..c9fa73d8cf6 100644 --- a/xen-api-client.opam +++ b/xen-api-client.opam @@ -15,7 +15,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ - "dune" {>= "3.0"} + "dune" {>= "3.15"} "dune-build-info" "alcotest" {with-test} "astring" From 197adc943d2c2881a7c89596870a88d273082f18 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:33 +0000 Subject: [PATCH 036/157] [maintenance]: do not build bytecode versions of internal libraries MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Only build 'best' (which may be bytecode if native is not available). Note that this does not prevent the use of 'dune utop': it will build bytecode libraries as needed, they are just not built by default. (And since they are internal libraries they wouldn't get installed anyway) Signed-off-by: Edwin Török --- ocaml/alerts/certificate/dune | 1 + ocaml/auth/dune | 1 + ocaml/gencert/dune | 1 + ocaml/license/dune | 1 + ocaml/nbd/lib/dune | 3 +++ ocaml/networkd/lib/dune | 1 + ocaml/networkd/test/dune | 1 + ocaml/sdk-gen/common/dune | 1 + ocaml/squeezed/lib/dune | 1 + ocaml/tapctl/dune | 1 + ocaml/vhd-tool/src/dune | 1 + ocaml/wsproxy/src/dune | 1 + ocaml/xapi-aux/dune | 1 + ocaml/xapi-guard/lib/dune | 3 ++- ocaml/xenopsd/xc/dune | 1 + ocaml/xs-trace/dune | 2 +- ocaml/xs-trace/test/dune | 2 +- ocaml/xxhash/lib/dune | 1 + ocaml/xxhash/stubs/dune | 1 + unixpwd/src/dune | 1 + 20 files changed, 23 insertions(+), 3 deletions(-) diff --git a/ocaml/alerts/certificate/dune b/ocaml/alerts/certificate/dune index d3743285e77..e3ef3de0aee 100644 --- a/ocaml/alerts/certificate/dune +++ b/ocaml/alerts/certificate/dune @@ -1,6 +1,7 @@ (library (name certificate_check) (modules certificate_check) + (modes best) (libraries astring xapi-expiry-alerts diff --git a/ocaml/auth/dune b/ocaml/auth/dune index f963fbb591b..d132a37b068 100644 --- a/ocaml/auth/dune +++ b/ocaml/auth/dune @@ -1,4 +1,5 @@ (library + (modes best) (foreign_stubs (language c) (names xa_auth xa_auth_stubs) diff --git a/ocaml/gencert/dune b/ocaml/gencert/dune index fedcfefc04e..f859078e89a 100644 --- a/ocaml/gencert/dune +++ b/ocaml/gencert/dune @@ -2,6 +2,7 @@ (name gencertlib) (wrapped true) (modules lib selfcert pem) + (modes best) (libraries angstrom astring diff --git a/ocaml/license/dune b/ocaml/license/dune index 28ce39eb80f..8981c7c0bef 100644 --- a/ocaml/license/dune +++ b/ocaml/license/dune @@ -1,4 +1,5 @@ (library + (modes best) (name daily_license_check) (modules daily_license_check) (libraries diff --git a/ocaml/nbd/lib/dune b/ocaml/nbd/lib/dune index b712f67370c..8bcbdc6dd78 100644 --- a/ocaml/nbd/lib/dune +++ b/ocaml/nbd/lib/dune @@ -1,10 +1,12 @@ (library (name consts) + (modes best) (modules consts) ) (library (name local_xapi_session) + (modes best) (modules local_xapi_session) (libraries consts @@ -19,6 +21,7 @@ (library (name vbd_store) + (modes best) (libraries lwt lwt_log diff --git a/ocaml/networkd/lib/dune b/ocaml/networkd/lib/dune index eb2f2de53cd..548d326a4b2 100644 --- a/ocaml/networkd/lib/dune +++ b/ocaml/networkd/lib/dune @@ -1,5 +1,6 @@ (library (name networklibs) + (modes best) (libraries astring forkexec diff --git a/ocaml/networkd/test/dune b/ocaml/networkd/test/dune index 92d3d968714..06c39333171 100644 --- a/ocaml/networkd/test/dune +++ b/ocaml/networkd/test/dune @@ -1,5 +1,6 @@ (executable (name network_test) + (modes exe) (libraries alcotest astring diff --git a/ocaml/sdk-gen/common/dune b/ocaml/sdk-gen/common/dune index 71ac6f30230..777d29b16ce 100644 --- a/ocaml/sdk-gen/common/dune +++ b/ocaml/sdk-gen/common/dune @@ -1,5 +1,6 @@ (library (name CommonFunctions) + (modes best) (wrapped false) (libraries astring diff --git a/ocaml/squeezed/lib/dune b/ocaml/squeezed/lib/dune index 20612fecef6..e5bd06deb89 100644 --- a/ocaml/squeezed/lib/dune +++ b/ocaml/squeezed/lib/dune @@ -1,5 +1,6 @@ (library (name squeeze) + (modes best) (flags (:standard -bin-annot)) (libraries re diff --git a/ocaml/tapctl/dune b/ocaml/tapctl/dune index 3c585047e79..903e35a63d4 100644 --- a/ocaml/tapctl/dune +++ b/ocaml/tapctl/dune @@ -1,5 +1,6 @@ (library (name tapctl) + (modes best) (wrapped false) (preprocess (pps ppx_deriving_rpc)) (libraries diff --git a/ocaml/vhd-tool/src/dune b/ocaml/vhd-tool/src/dune index dab81d82c24..02de3dbcce3 100644 --- a/ocaml/vhd-tool/src/dune +++ b/ocaml/vhd-tool/src/dune @@ -1,4 +1,5 @@ (library + (modes best) (foreign_stubs (language c) (names direct_copy_stubs) diff --git a/ocaml/wsproxy/src/dune b/ocaml/wsproxy/src/dune index 34989429d26..8513c2998c3 100644 --- a/ocaml/wsproxy/src/dune +++ b/ocaml/wsproxy/src/dune @@ -1,4 +1,5 @@ (library (name wslib) + (modes best) (libraries base64 lwt lwt.unix) ) diff --git a/ocaml/xapi-aux/dune b/ocaml/xapi-aux/dune index 29f72161907..f35495d6284 100644 --- a/ocaml/xapi-aux/dune +++ b/ocaml/xapi-aux/dune @@ -1,5 +1,6 @@ (library (name xapi_aux) + (modes best) (libraries astring cstruct diff --git a/ocaml/xapi-guard/lib/dune b/ocaml/xapi-guard/lib/dune index dd35baf40cb..000ca654c04 100644 --- a/ocaml/xapi-guard/lib/dune +++ b/ocaml/xapi-guard/lib/dune @@ -1,7 +1,8 @@ (library (name xapi_guard_server) (modules server_interface) - (libraries + (modes best) +(libraries cohttp cohttp-lwt cohttp-lwt-unix diff --git a/ocaml/xenopsd/xc/dune b/ocaml/xenopsd/xc/dune index 7fedcaa3207..8fbc258df32 100644 --- a/ocaml/xenopsd/xc/dune +++ b/ocaml/xenopsd/xc/dune @@ -1,5 +1,6 @@ (library (name xenopsd_xc) + (modes best) (modules :standard \ xenops_xc_main memory_breakdown diff --git a/ocaml/xs-trace/dune b/ocaml/xs-trace/dune index 7b4051306c7..0be1866b2d0 100644 --- a/ocaml/xs-trace/dune +++ b/ocaml/xs-trace/dune @@ -1,5 +1,5 @@ (executable - (modes byte exe) + (modes exe) (name xs_trace) (public_name xs-trace) (package xapi) diff --git a/ocaml/xs-trace/test/dune b/ocaml/xs-trace/test/dune index 2e140017a28..d794381a742 100644 --- a/ocaml/xs-trace/test/dune +++ b/ocaml/xs-trace/test/dune @@ -1,5 +1,5 @@ (executable - (modes byte exe) + (modes exe) (name test_xs_trace) (libraries unix)) diff --git a/ocaml/xxhash/lib/dune b/ocaml/xxhash/lib/dune index 70b43c59192..8b018491119 100644 --- a/ocaml/xxhash/lib/dune +++ b/ocaml/xxhash/lib/dune @@ -11,6 +11,7 @@ (language c) (names xxhash_stubs) ) + (modes best) (name xxhash) (wrapped false) (libraries diff --git a/ocaml/xxhash/stubs/dune b/ocaml/xxhash/stubs/dune index 575fcd1e00a..e9da18174f6 100644 --- a/ocaml/xxhash/stubs/dune +++ b/ocaml/xxhash/stubs/dune @@ -10,6 +10,7 @@ (library (name xxhash_bindings) + (modes best) (libraries ctypes ctypes.stubs diff --git a/unixpwd/src/dune b/unixpwd/src/dune index a699b846e5d..e853925e0a6 100644 --- a/unixpwd/src/dune +++ b/unixpwd/src/dune @@ -1,5 +1,6 @@ (library (name unixpwd) + (modes best) (libraries unixpwd_stubs ) From ac6b7b4755899313414d6716d4b6928ea6809a1c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 16:54:10 +0100 Subject: [PATCH 037/157] [maintenance]: add server.mli MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Speeds up the build, together with the previous commit. Now we no longer need to build bytecode version of server.ml. A similar approach might be useful for db_actions and client, but those would have to be generated automatically. ``` hyperfine --min-runs 3 'dune clean; dune build --cache=disabled' 'cd ../scm-prev; dune clean; dune build --cache=disabled' Benchmark 1: dune clean; dune build --cache=disabled Time (mean ± σ): 79.936 s ± 0.666 s [User: 343.353 s, System: 116.654 s] Range (min … max): 79.373 s … 80.671 s 3 runs Benchmark 2: cd ../scm-prev; dune clean; dune build --cache=disabled Time (mean ± σ): 91.555 s ± 0.613 s [User: 355.560 s, System: 118.064 s] Range (min … max): 91.083 s … 92.248 s 3 runs Summary dune clean; dune build --cache=disabled ran 1.15 ± 0.01 times faster than cd ../scm-prev; dune clean; dune build --cache=disabled ``` Signed-off-by: Edwin Török --- ocaml/xapi/server.mli | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 ocaml/xapi/server.mli diff --git a/ocaml/xapi/server.mli b/ocaml/xapi/server.mli new file mode 100644 index 00000000000..2f093e9adb6 --- /dev/null +++ b/ocaml/xapi/server.mli @@ -0,0 +1,7 @@ +module Make : functor + (_ : Custom_actions.CUSTOM_ACTIONS) + (_ : Custom_actions.CUSTOM_ACTIONS) + -> sig + val dispatch_call : + Http.Request.t -> Unix.file_descr -> Rpc.call -> Rpc.response +end From ed780881a5bcb70e8b2e5112f1251e18af8a628a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:34 +0000 Subject: [PATCH 038/157] [maintenance]: xapi-aux does not need to depend on xapi-types MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-aux/dune | 1 - 1 file changed, 1 deletion(-) diff --git a/ocaml/xapi-aux/dune b/ocaml/xapi-aux/dune index f35495d6284..86fbd8647c9 100644 --- a/ocaml/xapi-aux/dune +++ b/ocaml/xapi-aux/dune @@ -15,7 +15,6 @@ xapi-log xapi-stdext-threads xapi-stdext-unix - xapi-types xml-light2 ) (wrapped false) From f07b9d7d7a57b85797486f5c306db5c02d2dba32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:34 +0000 Subject: [PATCH 039/157] [maintenance]: preprocess only modules containing @@deriving MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Reduces the amount of work the build has to do if we don't need to preprocess everything, but only the few modules that actually using [@@deriving]. Signed-off-by: Edwin Török --- ocaml/database/dune | 7 +++++-- ocaml/forkexecd/lib/dune | 3 +-- ocaml/idl/dune | 2 +- ocaml/message-switch/core/dune | 2 +- ocaml/message-switch/switch/dune | 2 +- ocaml/message-switch/unix/dune | 2 +- ocaml/tests/dune | 1 - ocaml/vhd-tool/src/dune | 5 ++++- ocaml/xapi-guard/lib/dune | 2 +- ocaml/xapi-idl/lib/dune | 7 +++++-- ocaml/xapi-idl/lib_test/dune | 2 +- ocaml/xapi-storage/generator/lib/dune | 3 ++- ocaml/xapi-types/dune | 2 +- ocaml/xapi/dune | 8 +++++++- ocaml/xcp-rrdd/bin/rrdd/dune | 1 - ocaml/xcp-rrdd/test/rrdd/dune | 1 - ocaml/xen-api-client/lib/dune | 1 - ocaml/xenopsd/cli/dune | 2 +- ocaml/xenopsd/lib/dune | 5 ++++- ocaml/xenopsd/test/dune | 2 +- ocaml/xenopsd/xc/dune | 4 +++- 21 files changed, 40 insertions(+), 24 deletions(-) diff --git a/ocaml/database/dune b/ocaml/database/dune index 08108ad6c55..bdc5cea531a 100644 --- a/ocaml/database/dune +++ b/ocaml/database/dune @@ -16,7 +16,7 @@ xapi-stdext-encodings ) (wrapped false) - (preprocess (pps ppx_sexp_conv)) + (preprocess (per_module ((pps ppx_sexp_conv) Schema))) ) (library @@ -50,7 +50,10 @@ xml-light2 xmlm ) - (preprocess (pps ppx_deriving_rpc)) + (preprocess + (per_module + ((pps ppx_deriving_rpc) + Db_cache_types Db_filter_types Db_rpc_common_v2 Db_secret_string))) ) (executable diff --git a/ocaml/forkexecd/lib/dune b/ocaml/forkexecd/lib/dune index 160f444dd34..749f173b977 100644 --- a/ocaml/forkexecd/lib/dune +++ b/ocaml/forkexecd/lib/dune @@ -15,5 +15,4 @@ xapi-stdext-unix xapi-tracing ) - (preprocess - (pps ppx_deriving_rpc))) + (preprocess (per_module ((pps ppx_deriving_rpc) Fe)))) diff --git a/ocaml/idl/dune b/ocaml/idl/dune index 837c3b0013a..0a3aab54c24 100644 --- a/ocaml/idl/dune +++ b/ocaml/idl/dune @@ -21,7 +21,7 @@ xapi-stdext-unix ) (wrapped false) - (preprocess (pps ppx_deriving_rpc)) + (preprocess (per_module ((pps ppx_deriving_rpc) Datamodel_types))) ) (executable diff --git a/ocaml/message-switch/core/dune b/ocaml/message-switch/core/dune index 41cbf9e9f2d..d61746efe44 100644 --- a/ocaml/message-switch/core/dune +++ b/ocaml/message-switch/core/dune @@ -13,6 +13,6 @@ xapi-log xapi-stdext-threads ) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv)) + (preprocess (per_module ((pps ppx_deriving_rpc ppx_sexp_conv) Protocol))) ) diff --git a/ocaml/message-switch/switch/dune b/ocaml/message-switch/switch/dune index 756bb2d9097..e543584a896 100644 --- a/ocaml/message-switch/switch/dune +++ b/ocaml/message-switch/switch/dune @@ -28,7 +28,7 @@ sexplib0 uri ) - (preprocess (pps ppx_sexp_conv)) + (preprocess (per_module ((pps ppx_sexp_conv) Logging Q Switch_main))) ) (install diff --git a/ocaml/message-switch/unix/dune b/ocaml/message-switch/unix/dune index 3e088a12556..be953217f4e 100644 --- a/ocaml/message-switch/unix/dune +++ b/ocaml/message-switch/unix/dune @@ -13,6 +13,6 @@ threads.posix xapi-stdext-threads ) - (preprocess (pps ppx_deriving_rpc)) + (preprocess (per_module ((pps ppx_deriving_rpc) Protocol_unix_scheduler))) ) diff --git a/ocaml/tests/dune b/ocaml/tests/dune index d48056d3b70..9283fc9af16 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -52,7 +52,6 @@ xapi-xenopsd xml-light2 ) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv)) (deps (source_tree test_data) ) diff --git a/ocaml/vhd-tool/src/dune b/ocaml/vhd-tool/src/dune index 02de3dbcce3..8d278eefa07 100644 --- a/ocaml/vhd-tool/src/dune +++ b/ocaml/vhd-tool/src/dune @@ -39,6 +39,9 @@ xenstore_transport xenstore_transport.unix ) - (preprocess (pps ppx_deriving_rpc ppx_cstruct)) + (preprocess + (per_module + ((pps ppx_deriving_rpc) Nbd_input Image) + ((pps ppx_cstruct) Chunked))) ) diff --git a/ocaml/xapi-guard/lib/dune b/ocaml/xapi-guard/lib/dune index 000ca654c04..e4eebc4cd80 100644 --- a/ocaml/xapi-guard/lib/dune +++ b/ocaml/xapi-guard/lib/dune @@ -52,4 +52,4 @@ xapi-idl.guard.privileged xapi-idl.guard.varstored ) - (preprocess (pps ppx_deriving_rpc))) + (preprocess (per_module ((pps ppx_deriving_rpc) Types Varstored_interface)))) diff --git a/ocaml/xapi-idl/lib/dune b/ocaml/xapi-idl/lib/dune index c8feec1ff1a..29ea321bce3 100644 --- a/ocaml/xapi-idl/lib/dune +++ b/ocaml/xapi-idl/lib/dune @@ -38,7 +38,10 @@ xmlm ) (wrapped false) - (preprocess (pps ppx_sexp_conv ppx_deriving_rpc))) + (preprocess + (per_module + ((pps ppx_deriving_rpc) Xcp_channel Xcp_channel_protocol TypeCombinators) + ((pps ppx_sexp_conv ppx_deriving_rpc) Xcp_pci)))) (library (name xcp_updates) @@ -60,4 +63,4 @@ xapi-stdext-threads ) (wrapped false) - (preprocess (pps ppx_deriving_rpc))) + (preprocess (per_module ((pps ppx_deriving_rpc) Updates Scheduler)))) diff --git a/ocaml/xapi-idl/lib_test/dune b/ocaml/xapi-idl/lib_test/dune index 57c8c95e592..0806453c035 100644 --- a/ocaml/xapi-idl/lib_test/dune +++ b/ocaml/xapi-idl/lib_test/dune @@ -50,4 +50,4 @@ xapi-idl.xen.interface.types xapi-log ) - (preprocess (pps ppx_deriving_rpc))) + (preprocess (per_module ((pps ppx_deriving_rpc) Task_server_test Updates_test)))) diff --git a/ocaml/xapi-storage/generator/lib/dune b/ocaml/xapi-storage/generator/lib/dune index 85595a96131..e8a47976976 100644 --- a/ocaml/xapi-storage/generator/lib/dune +++ b/ocaml/xapi-storage/generator/lib/dune @@ -2,7 +2,8 @@ (name xapi_storage) (public_name xapi-storage) (modules apis common control data files plugin task) - (preprocess (pps ppx_deriving_rpc)) + (preprocess (per_module + ((pps ppx_deriving_rpc) Common Control Data Plugin Task))) (libraries result rpclib.core diff --git a/ocaml/xapi-types/dune b/ocaml/xapi-types/dune index da88000af95..12d1703ce3d 100644 --- a/ocaml/xapi-types/dune +++ b/ocaml/xapi-types/dune @@ -24,6 +24,6 @@ xapi-idl ) (wrapped false) - (preprocess (pps ppx_deriving_rpc)) + (preprocess (per_module ((pps ppx_deriving_rpc) API Event_types Features SecretString))) ) diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 22b37b509ac..301ea77ccbd 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -162,7 +162,13 @@ yojson zstd ) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv ppx_deriving.ord)) + (preprocess (per_module + ((pps ppx_sexp_conv) Cert_distrib) + ((pps ppx_deriving.ord) Xapi_observer_components) + ((pps ppx_deriving_rpc) + Config_file_sync Extauth_plugin_ADwinbind Importexport Sparse_dd_wrapper + Storage_migrate Storage_mux Storage_smapiv1_wrapper Stream_vdi + System_domains Xapi_psr Xapi_services Xapi_udhcpd))) ) (executable diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index 29142383a22..d1a38196462 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/dune +++ b/ocaml/xcp-rrdd/bin/rrdd/dune @@ -33,7 +33,6 @@ xmlm yojson ) - (preprocess (pps ppx_deriving_rpc)) ) (executable diff --git a/ocaml/xcp-rrdd/test/rrdd/dune b/ocaml/xcp-rrdd/test/rrdd/dune index 699ae424bfe..92c674df715 100644 --- a/ocaml/xcp-rrdd/test/rrdd/dune +++ b/ocaml/xcp-rrdd/test/rrdd/dune @@ -10,6 +10,5 @@ xapi-idl.rrd xapi-rrd ) - (preprocess (pps ppx_deriving_rpc)) ) diff --git a/ocaml/xen-api-client/lib/dune b/ocaml/xen-api-client/lib/dune index dd26361adef..bf0181ea3a3 100644 --- a/ocaml/xen-api-client/lib/dune +++ b/ocaml/xen-api-client/lib/dune @@ -2,7 +2,6 @@ (name xen_api_client) (public_name xen-api-client) (wrapped false) - (preprocess (pps ppx_deriving_rpc)) (libraries astring cohttp diff --git a/ocaml/xenopsd/cli/dune b/ocaml/xenopsd/cli/dune index b194b10323c..d8482fced6e 100644 --- a/ocaml/xenopsd/cli/dune +++ b/ocaml/xenopsd/cli/dune @@ -23,7 +23,7 @@ xapi-idl.xen.interface.types xapi-stdext-pervasives ) - (preprocess (pps ppx_deriving_rpc)) + (preprocess (per_module ((pps ppx_deriving_rpc) Common Xn_cfg_types))) ) (rule diff --git a/ocaml/xenopsd/lib/dune b/ocaml/xenopsd/lib/dune index 6f5bce8b12f..85377322942 100644 --- a/ocaml/xenopsd/lib/dune +++ b/ocaml/xenopsd/lib/dune @@ -47,6 +47,9 @@ xmlm ) (preprocess - (pps ppx_deriving_rpc ppx_sexp_conv) + (per_module + ((pps ppx_sexp_conv) Suspend_image) + ((pps ppx_deriving_rpc) Interface Xenops_hooks Xenops_migrate Xenops_server Xenops_server_plugin Xenops_server_simulator) + ) ) ) diff --git a/ocaml/xenopsd/test/dune b/ocaml/xenopsd/test/dune index 6c793a3c1bd..e795d7295bf 100644 --- a/ocaml/xenopsd/test/dune +++ b/ocaml/xenopsd/test/dune @@ -20,7 +20,7 @@ xenstore_transport.unix ) (preprocess - (pps ppx_deriving_rpc ppx_sexp_conv) + (per_module ((pps ppx_deriving_rpc) Test)) ) ) diff --git a/ocaml/xenopsd/xc/dune b/ocaml/xenopsd/xc/dune index 8fbc258df32..c1727b4493e 100644 --- a/ocaml/xenopsd/xc/dune +++ b/ocaml/xenopsd/xc/dune @@ -57,7 +57,9 @@ ) (preprocess - (pps ppx_deriving_rpc ppx_sexp_conv) + (per_module + ((pps ppx_deriving_rpc) Device Device_common Domain Xenops_server_xen) + ) ) (wrapped false) ) From d3869c15c7846fe738fe13ffd99b857e5d00761c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:34 +0000 Subject: [PATCH 040/157] [maintenance]: split server.ml into separate library MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/tests/common/dune | 1 + ocaml/tests/dune | 2 ++ ocaml/xapi/dune | 38 +++++++++++++++++++++++++++++++++++++- 3 files changed, 40 insertions(+), 1 deletion(-) diff --git a/ocaml/tests/common/dune b/ocaml/tests/common/dune index c578f5f9785..fff8623dee9 100644 --- a/ocaml/tests/common/dune +++ b/ocaml/tests/common/dune @@ -21,6 +21,7 @@ xapi-idl.network xapi-idl.xen.interface xapi_internal + xapi_internal_server xapi-inventory xapi-log xapi-test-utils diff --git a/ocaml/tests/dune b/ocaml/tests/dune index 9283fc9af16..81a977cfaa3 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -40,6 +40,7 @@ xapi-idl.xen.interface xapi-idl.xen.interface.types xapi_internal + xapi_internal_server xapi-log xapi-stdext-date xapi-stdext-std @@ -88,6 +89,7 @@ xapi-idl.storage.interface xapi-idl.xen xapi_internal + xapi_internal_server xapi-test-utils xapi-tracing xapi-types diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 301ea77ccbd..2d9d812a0d9 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -58,7 +58,7 @@ (name xapi_internal) (wrapped false) (modes best) - (modules (:standard \ xapi_main)) + (modules (:standard \ xapi_main server api_server xapi)) (libraries angstrom astring @@ -171,6 +171,41 @@ System_domains Xapi_psr Xapi_services Xapi_udhcpd))) ) +(library + (name xapi_internal_server) + (modes best) + (wrapped false) + (modules server api_server xapi) + (libraries + forkexec + http_lib + httpsvr + rpclib.core + rpclib.json + rpclib.xml + stunnel + threads.posix + xapi-backtrace + xapi-client + xapi-consts + xapi-datamodel + xapi-idl + xapi-inventory + xapi-log + xapi-stdext-date + xapi-stdext-encodings + xapi-stdext-pervasives + xapi-stdext-std + xapi-stdext-threads + xapi-stdext-unix + xapi-types + xapi_aux + xapi-consts.xapi_version + xapi_cli_server + xapi_database + xapi_internal) +) + (executable (modes exe) (name xapi_main) @@ -179,6 +214,7 @@ (modules xapi_main) (libraries xapi_internal + xapi_internal_server xapi-idl xapi-log xapi-stdext-unix From bc1a58c2f899a241696daf2389c23269ee1c8331 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:34 +0000 Subject: [PATCH 041/157] [maintenance]: remove API.API MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This signature is completely unused. We could instead generate a client.mli, but that is more complicated, currently the client.mli it'd generate wouldn't be polymorphic enough. Signed-off-by: Edwin Török --- ocaml/idl/ocaml_backend/gen_api.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/ocaml/idl/ocaml_backend/gen_api.ml b/ocaml/idl/ocaml_backend/gen_api.ml index 31011eec08d..564121ab819 100644 --- a/ocaml/idl/ocaml_backend/gen_api.ml +++ b/ocaml/idl/ocaml_backend/gen_api.ml @@ -412,7 +412,6 @@ let gen_client_types highapi = ; gen_record_type ~with_module:true highapi (toposort_types highapi all_types) ; gen_enum_helpers all_types - ; O.Signature.strings_of (Gen_client.gen_signature highapi) ] ) From 3f6228bd062fcc75e1575d3e104da446253cfe1e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:34 +0000 Subject: [PATCH 042/157] [maintenance]: remove dependency between most tests and server.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Server.ml takes a while to compile, but most unit tests don't actually need it. Reorganize Api_server into Api_server+Api_server_common, where the latter suffices for unit tests. 'dune runtest' times are improved: ``` hyperfine --min-runs 2 'dune clean; dune runtest --cache=disabled' 'cd ../scm-prev; dune clean; dune runtest --cache=disabled' Benchmark 1: dune clean; dune runtest --cache=disabled Time (mean ± σ): 103.491 s ± 1.596 s [User: 374.464 s, System: 125.957 s] Range (min … max): 102.363 s … 104.620 s 2 runs Benchmark 2: cd ../scm-prev; dune clean; dune runtest --cache=disabled Time (mean ± σ): 114.158 s ± 2.980 s [User: 380.638 s, System: 134.558 s] Range (min … max): 112.051 s … 116.266 s 2 runs Summary dune clean; dune runtest --cache=disabled ran 1.10 ± 0.03 times faster than cd ../scm-prev; dune clean; dune runtest --cache=disabled ``` Signed-off-by: Edwin Török --- ocaml/tests/common/dune | 1 - ocaml/tests/common/suite_init.ml | 2 +- ocaml/tests/common/test_common.ml | 21 -- ocaml/tests/dune | 25 ++- ocaml/tests/suite_alcotest.ml | 5 +- ocaml/tests/suite_alcotest_server.ml | 11 ++ ocaml/tests/test_client.ml | 24 ++- ocaml/tests/test_valid_ref_list.ml | 2 +- ocaml/tests/test_vdi_cbt.ml | 2 +- ocaml/tests/test_vm_check_operation_error.ml | 9 +- ocaml/tests/test_vm_group.ml | 4 +- ocaml/xapi/api_server.ml | 195 +------------------ ocaml/xapi/api_server_common.ml | 195 +++++++++++++++++++ ocaml/xapi/message_forwarding.ml | 30 +++ ocaml/xapi/xapi.ml | 31 +-- quality-gate.sh | 2 +- 16 files changed, 294 insertions(+), 265 deletions(-) create mode 100644 ocaml/tests/suite_alcotest_server.ml create mode 100644 ocaml/xapi/api_server_common.ml diff --git a/ocaml/tests/common/dune b/ocaml/tests/common/dune index fff8623dee9..c578f5f9785 100644 --- a/ocaml/tests/common/dune +++ b/ocaml/tests/common/dune @@ -21,7 +21,6 @@ xapi-idl.network xapi-idl.xen.interface xapi_internal - xapi_internal_server xapi-inventory xapi-log xapi-test-utils diff --git a/ocaml/tests/common/suite_init.ml b/ocaml/tests/common/suite_init.ml index e5c73554295..ee0317811b1 100644 --- a/ocaml/tests/common/suite_init.ml +++ b/ocaml/tests/common/suite_init.ml @@ -8,4 +8,4 @@ let harness_init () = Filename.concat Test_common.working_area "xapi-inventory" ; Xcp_client.use_switch := false ; Pool_role.set_pool_role_for_test () ; - Xapi.register_callback_fns () + Message_forwarding.register_callback_fns () diff --git a/ocaml/tests/common/test_common.ml b/ocaml/tests/common/test_common.ml index 90dfe287801..1c1685f693d 100644 --- a/ocaml/tests/common/test_common.ml +++ b/ocaml/tests/common/test_common.ml @@ -527,27 +527,6 @@ let make_session ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ()) ~client_certificate ; ref -(** Returns a [(rpc, session_id)] pair that can be passed to the - functions within the [Client] module to make XenAPI calls. The - calls can only succeed if they get forwarded to the local host - by the message forwarding layer. Forwarding to slaves does not - work in unit tests. *) -let make_client_params ~__context = - let req = Xmlrpc_client.xmlrpc ~version:"1.1" "/" in - let rpc = Api_server.Server.dispatch_call req Unix.stdout in - let session_id = - let session_id = Ref.make () in - let now = Xapi_stdext_date.Date.of_float (Unix.time ()) in - let (_ : _ API.Ref.t) = - make_session ~__context ~ref:session_id - ~this_host:(Helpers.get_localhost ~__context) - ~last_active:now ~is_local_superuser:true ~validation_time:now - ~auth_user_name:"root" ~originator:"test" () - in - session_id - in - (rpc, session_id) - let create_physical_pif ~__context ~host ?network ?(bridge = "xapi0") ?(managed = true) () = let network = diff --git a/ocaml/tests/dune b/ocaml/tests/dune index 81a977cfaa3..207853f7a5d 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -5,8 +5,9 @@ (modules (:standard \ test_daemon_manager test_vdi_cbt test_event test_clustering test_cluster_host test_cluster test_pusb test_network_sriov + test_client test_valid_ref_list suite_alcotest_server test_vm_placement test_vm_helpers test_repository test_repository_helpers - test_ref + test_ref test_vm_group test_livepatch test_rpm test_updateinfo test_storage_smapiv1_wrapper test_storage_quicktest test_observer test_pool_periodic_update_sync test_pkg_mgr)) (libraries @@ -30,7 +31,6 @@ threads.posix uuid xapi-backtrace - xapi-client xapi_cli_server xapi-consts xapi_database @@ -40,7 +40,6 @@ xapi-idl.xen.interface xapi-idl.xen.interface.types xapi_internal - xapi_internal_server xapi-log xapi-stdext-date xapi-stdext-std @@ -58,6 +57,25 @@ ) ) +(test + (name suite_alcotest_server) + (package xapi) + (modules suite_alcotest_server test_client test_valid_ref_list test_vm_group) + (libraries + alcotest + httpsvr + tests_common + xapi-client + http_lib + xapi-log + xapi-stdext-date + xapi-types + xapi_internal + xapi_internal_server + ) +) + + (tests (names test_vm_helpers test_vm_placement test_network_sriov test_vdi_cbt test_clustering test_pusb test_daemon_manager test_repository test_repository_helpers @@ -89,7 +107,6 @@ xapi-idl.storage.interface xapi-idl.xen xapi_internal - xapi_internal_server xapi-test-utils xapi-tracing xapi-types diff --git a/ocaml/tests/suite_alcotest.ml b/ocaml/tests/suite_alcotest.ml index be73d7cef06..c2e422c2379 100644 --- a/ocaml/tests/suite_alcotest.ml +++ b/ocaml/tests/suite_alcotest.ml @@ -5,8 +5,7 @@ let () = Debug.log_to_stdout () ; Alcotest.run "Base suite" ([ - ("Test_valid_ref_list", Test_valid_ref_list.test) - ; ("Test_sdn_controller", Test_sdn_controller.test) + ("Test_sdn_controller", Test_sdn_controller.test) ; ("Test_pci_helpers", Test_pci_helpers.test) ; ("Test_vdi_allowed_operations", Test_vdi_allowed_operations.test) ; ("Test_sr_allowed_operations", Test_sr_allowed_operations.test) @@ -27,7 +26,6 @@ let () = ; ( "Test_clustering_allowed_operations" , Test_clustering_allowed_operations.test ) - ; ("Test_client", Test_client.test) ; ("Test_ca91480", Test_ca91480.test) ; ("Test_pgpu", Test_pgpu.test) ; ("Test_gpu_group", Test_gpu_group.test) @@ -46,7 +44,6 @@ let () = ; ("Test_storage_migrate_state", Test_storage_migrate_state.test) ; ("Test_bios_strings", Test_bios_strings.test) ; ("Test_certificates", Test_certificates.test) - ; ("Test_vm_group", Test_vm_group.test) ] @ Test_guest_agent.tests @ Test_nm.tests diff --git a/ocaml/tests/suite_alcotest_server.ml b/ocaml/tests/suite_alcotest_server.ml new file mode 100644 index 00000000000..9b6f03b0c0e --- /dev/null +++ b/ocaml/tests/suite_alcotest_server.ml @@ -0,0 +1,11 @@ +let () = + Suite_init.harness_init () ; + (* Alcotest hides the standard output of successful tests, + so we will probably not exceed the 4MB limit in Travis *) + Debug.log_to_stdout () ; + Alcotest.run "Base suite" + [ + ("Test_valid_ref_list", Test_valid_ref_list.test) + ; ("Test_client", Test_client.test) + ; ("Test_vm_group", Test_vm_group.test) + ] diff --git a/ocaml/tests/test_client.ml b/ocaml/tests/test_client.ml index 0a5c64630ab..cdfa7690f79 100644 --- a/ocaml/tests/test_client.ml +++ b/ocaml/tests/test_client.ml @@ -3,9 +3,31 @@ these XenAPI calls go through the client, server.ml, message forwarding, and database layers. *) +(** Returns a [(rpc, session_id)] pair that can be passed to the + functions within the [Client] module to make XenAPI calls. The + calls can only succeed if they get forwarded to the local host + by the message forwarding layer. Forwarding to slaves does not + work in unit tests. *) +let make_client_params ~__context = + let req = Xmlrpc_client.xmlrpc ~version:"1.1" "/" in + let rpc = Api_server.Server.dispatch_call req Unix.stdout in + let session_id = + let session_id = Ref.make () in + let now = Xapi_stdext_date.Date.of_float (Unix.time ()) in + let (_ : _ API.Ref.t) = + Test_common.make_session ~__context ~ref:session_id + ~this_host:(Helpers.get_localhost ~__context) + ~last_active:now ~is_local_superuser:true ~validation_time:now + ~auth_user_name:"root" ~originator:"test" () + in + session_id + in + (rpc, session_id) + let setup_test () = + Xapi.register_callback_fns () ; let __context = Test_common.make_test_database () in - Test_common.make_client_params ~__context + make_client_params ~__context (* Here we should have a unit test for each different type of method, such as X.create, X.destroy, getters, and setters, to ensure that these are diff --git a/ocaml/tests/test_valid_ref_list.ml b/ocaml/tests/test_valid_ref_list.ml index 56cdaccbaa5..d7b5273bdc8 100644 --- a/ocaml/tests/test_valid_ref_list.ml +++ b/ocaml/tests/test_valid_ref_list.ml @@ -111,7 +111,7 @@ let test_iter = exceptions when we use the Client module *) let test_client = with_vm_list (fun __context l -> - let rpc, session_id = Test_common.make_client_params ~__context in + let rpc, session_id = Test_client.make_client_params ~__context in let f vm = Client.Client.VM.get_name_label ~rpc ~session_id ~self:vm in assert_equal ["a"; "d"] (Valid_ref_list.map f l) ) diff --git a/ocaml/tests/test_vdi_cbt.ml b/ocaml/tests/test_vdi_cbt.ml index 566fa18fbf5..3137e0485cb 100644 --- a/ocaml/tests/test_vdi_cbt.ml +++ b/ocaml/tests/test_vdi_cbt.ml @@ -475,7 +475,7 @@ let test_allowed_operations_updated_when_necessary () = List.mem `copy ops ) ; (* Call data_destroy through the the message forwarding layer *) - Api_server.Forwarder.VDI.data_destroy ~__context ~self ; + Api_server_common.Forwarder.VDI.data_destroy ~__context ~self ; assert_allowed_operations "does not contain `copy after VDI has been data-destroyed" (fun ops -> not @@ List.mem `copy ops diff --git a/ocaml/tests/test_vm_check_operation_error.ml b/ocaml/tests/test_vm_check_operation_error.ml index 567ac89f49f..5116ac55d1c 100644 --- a/ocaml/tests/test_vm_check_operation_error.ml +++ b/ocaml/tests/test_vm_check_operation_error.ml @@ -34,7 +34,8 @@ let test_vm_set_nvram_running () = with_test_vm (fun __context vm_ref -> Db.VM.set_power_state ~__context ~self:vm_ref ~value:`Halted ; let old_nvram = [("EFI-variables", "AAAA")] in - Api_server.Forwarder.VM.set_NVRAM ~__context ~self:vm_ref ~value:old_nvram ; + Api_server_common.Forwarder.VM.set_NVRAM ~__context ~self:vm_ref + ~value:old_nvram ; Db.VM.set_power_state ~__context ~self:vm_ref ~value:`Running ; Alcotest.check_raises "VM.set_NVRAM should fail when the VM is running" Api_errors.( @@ -42,7 +43,7 @@ let test_vm_set_nvram_running () = (vm_bad_power_state, [Ref.string_of vm_ref; "halted"; "running"]) ) (fun () -> - Api_server.Forwarder.VM.set_NVRAM ~__context ~self:vm_ref + Api_server_common.Forwarder.VM.set_NVRAM ~__context ~self:vm_ref ~value:[("EFI-variables", "BBBB")] ) ; let read_nvram = Db.VM.get_NVRAM ~__context ~self:vm_ref in @@ -50,8 +51,8 @@ let test_vm_set_nvram_running () = "NVRAM not updated" old_nvram read_nvram ; let new_vars = "CCCC" in let new_nvram = [("EFI-variables", new_vars)] in - Api_server.Forwarder.VM.set_NVRAM_EFI_variables ~__context ~self:vm_ref - ~value:new_vars ; + Api_server_common.Forwarder.VM.set_NVRAM_EFI_variables ~__context + ~self:vm_ref ~value:new_vars ; let read_nvram = Db.VM.get_NVRAM ~__context ~self:vm_ref in Alcotest.(check (list (pair string string))) "NVRAM updated" new_nvram read_nvram diff --git a/ocaml/tests/test_vm_group.ml b/ocaml/tests/test_vm_group.ml index 910711f9646..8e45cf050cc 100644 --- a/ocaml/tests/test_vm_group.ml +++ b/ocaml/tests/test_vm_group.ml @@ -16,7 +16,7 @@ module T = Test_common let test_associate_vm_with_vm_group () = let __context = T.make_test_database () in - let rpc, session_id = Test_common.make_client_params ~__context in + let rpc, session_id = Test_client.make_client_params ~__context in let vm1 = T.make_vm ~__context () in let vm2 = T.make_vm ~__context () in let vm3 = T.make_vm ~__context () in @@ -34,7 +34,7 @@ let test_associate_vm_with_vm_group () = let test_vm_can_only_belong_to_one_group () = let __context = T.make_test_database () in - let rpc, session_id = Test_common.make_client_params ~__context in + let rpc, session_id = Test_client.make_client_params ~__context in let vm = T.make_vm ~__context () in let vm_group1 = T.make_vm_group ~__context ~placement:`anti_affinity () in let vm_group2 = T.make_vm_group ~__context ~placement:`anti_affinity () in diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index c5870d8555f..ba95fbe03d9 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -1,197 +1,6 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -(** The main callback function. - - @group API Messaging -*) - -(** Actions module *) -module Actions = struct - (** The DebugVersion throws a NotImplemented exception for everything - by default. The ReleaseVersion is missing all the fields; - so server will not compile unless everything is overridden *) - - module Task = Xapi_task - module Session = Xapi_session - module Auth = Xapi_auth - module Subject = Xapi_subject - module Role = Xapi_role - module Event = Xapi_event - module Alert = Xapi_alert - - module VM = struct include Xapi_vm include Xapi_vm_migrate end - - module VM_metrics = struct end - - module VM_guest_metrics = struct end - - module VMPP = Xapi_vmpp - module VMSS = Xapi_vmss - module VM_appliance = Xapi_vm_appliance - module VM_group = Xapi_vm_group - module DR_task = Xapi_dr_task - - module LVHD = struct end - - module Host = Xapi_host - module Host_crashdump = Xapi_host_crashdump - module Pool = Xapi_pool - module Pool_update = Xapi_pool_update - module Pool_patch = Xapi_pool_patch - module Host_patch = Xapi_host_patch - - module Host_metrics = struct end - - module Host_cpu = struct end - - module Network = Xapi_network - module VIF = Xapi_vif - - module VIF_metrics = struct end - - module PIF = Xapi_pif - - module PIF_metrics = struct end - - module SR = Xapi_sr - module SM = Xapi_sm - - module VDI = struct - include Xapi_vdi - - let pool_migrate = Xapi_vm_migrate.vdi_pool_migrate - end - - module VBD = Xapi_vbd - - module VBD_metrics = struct end - - module Crashdump = Xapi_crashdump - module PBD = Xapi_pbd - - module Data_source = struct end - - module VTPM = Xapi_vtpm - - let not_implemented x = - raise (Api_errors.Server_error (Api_errors.not_implemented, [x])) - - module Console = struct - let create ~__context ~other_config:_ = not_implemented "Console.create" - - let destroy ~__context ~self:_ = not_implemented "Console.destroy" - end - - module Bond = Xapi_bond - module VLAN = Xapi_vlan - module User = Xapi_user - module Blob = Xapi_blob - module Message = Xapi_message - module Secret = Xapi_secret - module Tunnel = Xapi_tunnel - module PCI = Xapi_pci - module PGPU = Xapi_pgpu - module GPU_group = Xapi_gpu_group - module VGPU = Xapi_vgpu - module VGPU_type = Xapi_vgpu_type - module PVS_site = Xapi_pvs_site - module PVS_server = Xapi_pvs_server - module PVS_proxy = Xapi_pvs_proxy - module PVS_cache_storage = Xapi_pvs_cache_storage - - module Feature = struct end - - module SDN_controller = Xapi_sdn_controller - - module Vdi_nbd_server_info = struct end - - module Probe_result = struct end - - module Sr_stat = struct end - - module PUSB = Xapi_pusb - module USB_group = Xapi_usb_group - module VUSB = Xapi_vusb - module Network_sriov = Xapi_network_sriov - module Cluster = Xapi_cluster - module Cluster_host = Xapi_cluster_host - module Certificate = Certificates - module Diagnostics = Xapi_diagnostics - module Repository = Repository - module Observer = Xapi_observer -end - -(** Use the server functor to make an XML-RPC dispatcher. *) -module Forwarder = Message_forwarding.Forward (Actions) - +open Api_server_common module Server = Server.Make (Actions) (Forwarder) -(** Here are the functions to forward calls made on the unix domain socket on a slave to a master *) -module D = Debug.Make (struct - let name = "api_server" -end) - -(** Forward a call to the master *) -let forward req call is_json = - let open Xmlrpc_client in - let transport = - SSL - ( SSL.make ~use_stunnel_cache:true ~verify_cert:(Stunnel_client.pool ()) () - , Pool_role.get_master_address () - , !Constants.https_port - ) - in - let rpc = if is_json then JSONRPC_protocol.rpc else XMLRPC_protocol.rpc in - rpc ~srcstr:"xapi" ~dststr:"xapi" ~transport - ~http:{req with Http.Request.frame= true} - call - -(* Whitelist of functions that do *not* get forwarded to the master (e.g. session.login_with_password) *) -(* !!! Note, this only blocks synchronous calls. As is it happens, all the calls we want to block right now are only - synchronous. However, we'd probably want to change this is the list starts getting longer. *) -let whitelist = - List.map - (fun (obj, msg) -> Datamodel_utils.wire_name ~sync:true obj msg) - Datamodel.whitelist - -let emergency_call_list = - List.map - (fun (obj, msg) -> Datamodel_utils.wire_name ~sync:true obj msg) - Datamodel.emergency_calls - -let is_himn_req req = - match req.Http.Request.host with - | Some h -> ( - match Xapi_mgmt_iface.himn_addr () with - | Some himn -> - himn = h - | None -> - false - ) - | None -> - false - -(* The API does not use the error.code and only retains it for compliance with - the JSON-RPC v2.0 specs. We set this always to a non-zero value because - some JsonRpc clients consider error.code 0 as no error*) -let error_code_lit = 1L - -let json_of_error_object ?(data = None) code message = - let data_json = match data with Some d -> [("data", d)] | None -> [] in - Rpc.Dict - ([("code", Rpc.Int code); ("message", Rpc.String message)] @ data_json) - (* This bit is called directly by the fake_rpc callback *) let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call = (* We now have the body string, the xml and the call name, and can also tell *) @@ -274,8 +83,6 @@ let create_thumbprint_header req response = [(!Xapi_globs.cert_thumbprint_header_response, x)] ) -module Unixext = Xapi_stdext_unix.Unixext - (** HTML callback that dispatches an RPC and returns the response. *) let callback is_json req bio _ = let fd = Buf_io.fd_of bio in diff --git a/ocaml/xapi/api_server_common.ml b/ocaml/xapi/api_server_common.ml new file mode 100644 index 00000000000..1cd1758a078 --- /dev/null +++ b/ocaml/xapi/api_server_common.ml @@ -0,0 +1,195 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +(** The main callback function. + + @group API Messaging +*) + +(** Actions module *) +module Actions = struct + (** The DebugVersion throws a NotImplemented exception for everything + by default. The ReleaseVersion is missing all the fields; + so server will not compile unless everything is overridden *) + + module Task = Xapi_task + module Session = Xapi_session + module Auth = Xapi_auth + module Subject = Xapi_subject + module Role = Xapi_role + module Event = Xapi_event + module Alert = Xapi_alert + + module VM = struct include Xapi_vm include Xapi_vm_migrate end + + module VM_metrics = struct end + + module VM_guest_metrics = struct end + + module VMPP = Xapi_vmpp + module VMSS = Xapi_vmss + module VM_appliance = Xapi_vm_appliance + module VM_group = Xapi_vm_group + module DR_task = Xapi_dr_task + + module LVHD = struct end + + module Host = Xapi_host + module Host_crashdump = Xapi_host_crashdump + module Pool = Xapi_pool + module Pool_update = Xapi_pool_update + module Pool_patch = Xapi_pool_patch + module Host_patch = Xapi_host_patch + + module Host_metrics = struct end + + module Host_cpu = struct end + + module Network = Xapi_network + module VIF = Xapi_vif + + module VIF_metrics = struct end + + module PIF = Xapi_pif + + module PIF_metrics = struct end + + module SR = Xapi_sr + module SM = Xapi_sm + + module VDI = struct + include Xapi_vdi + + let pool_migrate = Xapi_vm_migrate.vdi_pool_migrate + end + + module VBD = Xapi_vbd + + module VBD_metrics = struct end + + module Crashdump = Xapi_crashdump + module PBD = Xapi_pbd + + module Data_source = struct end + + module VTPM = Xapi_vtpm + + let not_implemented x = + raise (Api_errors.Server_error (Api_errors.not_implemented, [x])) + + module Console = struct + let create ~__context ~other_config:_ = not_implemented "Console.create" + + let destroy ~__context ~self:_ = not_implemented "Console.destroy" + end + + module Bond = Xapi_bond + module VLAN = Xapi_vlan + module User = Xapi_user + module Blob = Xapi_blob + module Message = Xapi_message + module Secret = Xapi_secret + module Tunnel = Xapi_tunnel + module PCI = Xapi_pci + module PGPU = Xapi_pgpu + module GPU_group = Xapi_gpu_group + module VGPU = Xapi_vgpu + module VGPU_type = Xapi_vgpu_type + module PVS_site = Xapi_pvs_site + module PVS_server = Xapi_pvs_server + module PVS_proxy = Xapi_pvs_proxy + module PVS_cache_storage = Xapi_pvs_cache_storage + + module Feature = struct end + + module SDN_controller = Xapi_sdn_controller + + module Vdi_nbd_server_info = struct end + + module Probe_result = struct end + + module Sr_stat = struct end + + module PUSB = Xapi_pusb + module USB_group = Xapi_usb_group + module VUSB = Xapi_vusb + module Network_sriov = Xapi_network_sriov + module Cluster = Xapi_cluster + module Cluster_host = Xapi_cluster_host + module Certificate = Certificates + module Diagnostics = Xapi_diagnostics + module Repository = Repository + module Observer = Xapi_observer +end + +(** Use the server functor to make an XML-RPC dispatcher. *) +module Forwarder = Message_forwarding.Forward (Actions) + +(** Here are the functions to forward calls made on the unix domain socket on a slave to a master *) +module D = Debug.Make (struct + let name = "api_server" +end) + +(** Forward a call to the master *) +let forward req call is_json = + let open Xmlrpc_client in + let transport = + SSL + ( SSL.make ~use_stunnel_cache:true ~verify_cert:(Stunnel_client.pool ()) () + , Pool_role.get_master_address () + , !Constants.https_port + ) + in + let rpc = if is_json then JSONRPC_protocol.rpc else XMLRPC_protocol.rpc in + rpc ~srcstr:"xapi" ~dststr:"xapi" ~transport + ~http:{req with Http.Request.frame= true} + call + +(* Whitelist of functions that do *not* get forwarded to the master (e.g. session.login_with_password) *) +(* !!! Note, this only blocks synchronous calls. As is it happens, all the calls we want to block right now are only + synchronous. However, we'd probably want to change this is the list starts getting longer. *) +let whitelist = + List.map + (fun (obj, msg) -> Datamodel_utils.wire_name ~sync:true obj msg) + Datamodel.whitelist + +let emergency_call_list = + List.map + (fun (obj, msg) -> Datamodel_utils.wire_name ~sync:true obj msg) + Datamodel.emergency_calls + +let is_himn_req req = + match req.Http.Request.host with + | Some h -> ( + match Xapi_mgmt_iface.himn_addr () with + | Some himn -> + himn = h + | None -> + false + ) + | None -> + false + +(* The API does not use the error.code and only retains it for compliance with + the JSON-RPC v2.0 specs. We set this always to a non-zero value because + some JsonRpc clients consider error.code 0 as no error*) +let error_code_lit = 1L + +let json_of_error_object ?(data = None) code message = + let data_json = match data with Some d -> [("data", d)] | None -> [] in + Rpc.Dict + ([("code", Rpc.Int code); ("message", Rpc.String message)] @ data_json) + +(* debug(fmt "response = %s" response); *) + +module Unixext = Xapi_stdext_unix.Unixext diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index ded1739f211..e0a064e520d 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -6756,3 +6756,33 @@ functor Xapi_pool_helpers.call_fn_on_slaves_then_master ~__context fn end end + +(* for unit tests *) +let register_callback_fns () = + let set_stunnelpid _task_opt pid = + Locking_helpers.Thread_state.acquired + (Locking_helpers.Process ("stunnel", pid)) + in + let unset_stunnelpid _task_opt pid = + Locking_helpers.Thread_state.released + (Locking_helpers.Process ("stunnel", pid)) + in + let stunnel_destination_is_ok addr = + Server_helpers.exec_with_new_task "check_stunnel_destination" + (fun __context -> + let hosts = + Db.Host.get_refs_where ~__context + ~expr:(Eq (Field "address", Literal addr)) + in + match hosts with + | [host] -> ( + try check_live ~__context host ; true with _ -> false + ) + | _ -> + true + ) + in + Xmlrpc_client.Internal.set_stunnelpid_callback := Some set_stunnelpid ; + Xmlrpc_client.Internal.unset_stunnelpid_callback := Some unset_stunnelpid ; + Xmlrpc_client.Internal.destination_is_ok := Some stunnel_destination_is_ok ; + TaskHelper.init () diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml index 0b1c213e993..26659a55801 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -164,36 +164,7 @@ let register_callback_fns () = Api_server.callback1 false req sock xml in Xapi_cli.rpc_fun := Some fake_rpc ; - let set_stunnelpid _task_opt pid = - Locking_helpers.Thread_state.acquired - (Locking_helpers.Process ("stunnel", pid)) - in - let unset_stunnelpid _task_opt pid = - Locking_helpers.Thread_state.released - (Locking_helpers.Process ("stunnel", pid)) - in - let stunnel_destination_is_ok addr = - Server_helpers.exec_with_new_task "check_stunnel_destination" - (fun __context -> - let hosts = - Db.Host.get_refs_where ~__context - ~expr:(Eq (Field "address", Literal addr)) - in - match hosts with - | [host] -> ( - try - Message_forwarding.check_live ~__context host ; - true - with _ -> false - ) - | _ -> - true - ) - in - Xmlrpc_client.Internal.set_stunnelpid_callback := Some set_stunnelpid ; - Xmlrpc_client.Internal.unset_stunnelpid_callback := Some unset_stunnelpid ; - Xmlrpc_client.Internal.destination_is_ok := Some stunnel_destination_is_ok ; - TaskHelper.init () + Message_forwarding.register_callback_fns () let noevents = ref false diff --git a/quality-gate.sh b/quality-gate.sh index be4e470fc94..f9c644467f5 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=512 + N=513 # do not count ml files from the tests in ocaml/{tests/perftest/quicktest} MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) From f823835946b9daa310033e71bad412c1fb3cfaf6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 22:37:02 +0100 Subject: [PATCH 043/157] [maintenance]: remove unneeded dependencies MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `sexpr` is now fully thread safe without having to use locks, doesn't need to depend on threadext. `gen_api_main` can use the external `uuidm` module directly, without waiting for internal one to be built. `dune-build-info` is only needed by xapi_version. `xapi-stdext-unix` is not needed in `xapi-idl` The sexplib ppx runtime also doesn't need to be linked in some libraries that do not use it anymore, and where it is used it'll be automatically linked. Signed-off-by: Edwin Török --- dune-project | 4 ++-- ocaml/alerts/certificate/dune | 2 +- ocaml/alerts/dune | 2 -- ocaml/database/dune | 11 +++-------- ocaml/db_process/dune | 2 +- ocaml/doc/dune | 4 +--- ocaml/events/dune | 1 - ocaml/gencert/dune | 2 -- ocaml/idl/autogen/dune | 2 +- ocaml/idl/dune | 7 +------ ocaml/idl/json_backend/dune | 3 +-- ocaml/idl/ocaml_backend/dune | 5 +---- ocaml/idl/ocaml_backend/gen_rbac.ml | 2 +- ocaml/libs/clock/dune | 1 - ocaml/libs/http-lib/dune | 6 +++--- ocaml/libs/log/dune | 1 - ocaml/libs/sexpr/dune | 2 -- ocaml/license/dune | 1 - ocaml/mpathalert/dune | 3 +-- ocaml/nbd/src/dune | 2 +- ocaml/networkd/bin/dune | 2 +- ocaml/networkd/bin_db/dune | 2 +- ocaml/networkd/test/dune | 2 +- ocaml/perftest/dune | 2 +- ocaml/quicktest/dune | 2 +- ocaml/rrd2csv/src/dune | 2 +- ocaml/sdk-gen/c/dune | 2 +- ocaml/sdk-gen/csharp/dune | 4 ++-- ocaml/sdk-gen/java/dune | 2 +- ocaml/sdk-gen/powershell/dune | 2 +- ocaml/squeezed/src/dune | 2 +- ocaml/tests/alerts/dune | 2 +- ocaml/tests/dune | 2 +- ocaml/util/dune | 2 +- ocaml/vhd-tool/cli/dune | 2 +- ocaml/vncproxy/dune | 2 +- ocaml/xapi-guard/src/dune | 2 +- ocaml/xapi-guard/test/dune | 2 +- ocaml/xapi-idl/guard/privileged/dune | 2 +- ocaml/xapi-idl/guard/varstored/dune | 2 +- ocaml/xapi-idl/lib/dune | 2 -- ocaml/xapi-idl/network/dune | 2 +- ocaml/xapi-idl/rrd/dune | 2 +- ocaml/xapi-idl/storage/dune | 4 ++-- ocaml/xapi-idl/v6/dune | 2 +- ocaml/xapi-storage-cli/dune | 2 +- ocaml/xapi-storage-script/dune | 2 +- ocaml/xcp-rrdd/bin/rrdd/dune | 4 ++-- ocaml/xcp-rrdd/bin/rrddump/dune | 2 +- ocaml/xcp-rrdd/bin/rrdp-dcmi/dune | 2 +- ocaml/xcp-rrdd/bin/rrdp-dummy/dune | 2 +- ocaml/xcp-rrdd/bin/rrdp-iostat/dune | 2 +- ocaml/xcp-rrdd/bin/rrdp-squeezed/dune | 2 +- ocaml/xcp-rrdd/bin/rrdp-xenpm/dune | 2 +- ocaml/xcp-rrdd/bin/transport-rw/dune | 2 +- ocaml/xcp-rrdd/test/rrdd/dune | 2 +- ocaml/xcp-rrdd/test/transport/dune | 2 +- ocaml/xe-cli/dune | 2 +- ocaml/xen-api-client/async_examples/dune | 6 ++---- ocaml/xen-api-client/lib_test/dune | 2 +- ocaml/xen-api-client/lwt_examples/dune | 6 +++--- ocaml/xenforeign/dune | 2 +- ocaml/xenopsd/cli/dune | 2 +- ocaml/xenopsd/dbgring/dune | 2 +- ocaml/xenopsd/list_domains/dune | 2 +- ocaml/xenopsd/simulator/dune | 2 +- ocaml/xenopsd/test/dune | 2 +- ocaml/xenopsd/xc/dune | 8 ++++---- ocaml/xsh/dune | 2 +- xapi-rrdd.opam | 1 - xen-api-client.opam | 1 - 71 files changed, 75 insertions(+), 108 deletions(-) diff --git a/dune-project b/dune-project index ad3b41392d1..3c6620b2c6c 100644 --- a/dune-project +++ b/dune-project @@ -67,7 +67,7 @@ (synopsis "Xen-API client library for remotely-controlling a xapi host") (authors "David Scott" "Anil Madhavapeddy" "Jerome Maloberti" "John Else" "Jon Ludlam" "Thomas Sanders" "Mike McClurg") (depends - dune-build-info + (alcotest :with-test) astring (cohttp (>= "0.22.0")) @@ -188,7 +188,7 @@ (description "This daemon monitors 'datasources' i.e. time-varying values such as performance counters and records the samples in RRD archives. These archives can be used to examine historical performance trends.") (depends (ocaml (>= "4.02.0")) - dune-build-info + (alcotest :with-test) astring (gzip (= :version)) diff --git a/ocaml/alerts/certificate/dune b/ocaml/alerts/certificate/dune index e3ef3de0aee..137b23d265e 100644 --- a/ocaml/alerts/certificate/dune +++ b/ocaml/alerts/certificate/dune @@ -20,7 +20,7 @@ (modules certificate_check_main) (libraries certificate_check - dune-build-info + http_lib xapi-client xapi-types diff --git a/ocaml/alerts/dune b/ocaml/alerts/dune index 4e6205891e7..9396600b2b5 100644 --- a/ocaml/alerts/dune +++ b/ocaml/alerts/dune @@ -2,9 +2,7 @@ (name expiry_alert) (public_name xapi-expiry-alerts) (libraries - astring xapi-client - xapi-consts xapi-types xapi-stdext-date ) diff --git a/ocaml/database/dune b/ocaml/database/dune index bdc5cea531a..14ac44931bd 100644 --- a/ocaml/database/dune +++ b/ocaml/database/dune @@ -9,8 +9,6 @@ db_names db_exn schema string_marshall_helper string_unmarshall_helper test_schemas) (libraries - ppx_sexp_conv.runtime-lib - sexplib0 sexpr xapi-log xapi-stdext-encodings @@ -63,7 +61,7 @@ (package xapi) (modules block_device_io) (libraries - dune-build-info + xapi_database xapi-log xapi-stdext-pervasives @@ -77,7 +75,7 @@ (modes exe) (modules database_server_main) (libraries - dune-build-info + http_lib httpsvr threads.posix @@ -93,10 +91,8 @@ (package xapi) (modules db_cache_test unit_test_marshall) (libraries - alcotest - dune-build-info + alcotest http_lib - ppx_sexp_conv.runtime-lib rpclib.xml sexplib sexplib0 @@ -115,7 +111,6 @@ ) (libraries alcotest - dune-build-info xapi_database xml-light2 ) diff --git a/ocaml/db_process/dune b/ocaml/db_process/dune index 238f24263d8..bbe92d2b944 100644 --- a/ocaml/db_process/dune +++ b/ocaml/db_process/dune @@ -4,7 +4,7 @@ (public_name xapi-db-process) (package xapi) (libraries - dune-build-info + unix xapi-inventory xapi_database diff --git a/ocaml/doc/dune b/ocaml/doc/dune index 360f0a1a5d7..ee0f921d032 100644 --- a/ocaml/doc/dune +++ b/ocaml/doc/dune @@ -1,9 +1,7 @@ (executable (modes exe) (name jsapi) - (libraries - dune-build-info - gzip + (libraries mustache rpclib.core rpclib.json diff --git a/ocaml/events/dune b/ocaml/events/dune index 0a816adc6b2..bb2b0420399 100644 --- a/ocaml/events/dune +++ b/ocaml/events/dune @@ -4,7 +4,6 @@ (public_name event_listen) (package xapi) (libraries - dune-build-info http_lib xapi-client xapi-types diff --git a/ocaml/gencert/dune b/ocaml/gencert/dune index f859078e89a..f83ed49eb51 100644 --- a/ocaml/gencert/dune +++ b/ocaml/gencert/dune @@ -32,7 +32,6 @@ (modules gencert) (libraries astring - dune-build-info gencertlib x509 xapi-inventory @@ -49,7 +48,6 @@ (libraries alcotest cstruct - dune-build-info fmt gencertlib mirage-crypto diff --git a/ocaml/idl/autogen/dune b/ocaml/idl/autogen/dune index 483a0dbdef8..a423ff4a937 100644 --- a/ocaml/idl/autogen/dune +++ b/ocaml/idl/autogen/dune @@ -3,4 +3,4 @@ (deps (source_tree .) ) -) \ No newline at end of file +) diff --git a/ocaml/idl/dune b/ocaml/idl/dune index 0a3aab54c24..430938311f8 100644 --- a/ocaml/idl/dune +++ b/ocaml/idl/dune @@ -8,7 +8,6 @@ datamodel_diagnostics datamodel_repository datamodel_lifecycle datamodel_vtpm datamodel_observer datamodel_vm_group) (libraries - ppx_sexp_conv.runtime-lib rpclib.core sexplib0 sexpr @@ -18,7 +17,6 @@ xapi-schema xapi-stdext-date xapi-stdext-std - xapi-stdext-unix ) (wrapped false) (preprocess (per_module ((pps ppx_deriving_rpc) Datamodel_types))) @@ -29,7 +27,6 @@ (name datamodel_main) (modules datamodel_main dot_backend dtd_backend markdown_backend) (libraries - dune-build-info mustache xapi-datamodel xapi-stdext-std @@ -53,7 +50,6 @@ (modes exe) (modules schematest) (libraries - dune-build-info rpclib.core rpclib.json xapi_datamodel @@ -67,8 +63,7 @@ (public_name gen_lifecycle) (package xapi-datamodel) (modules gen_lifecycle) - (libraries - dune-build-info + (libraries xapi-datamodel xapi-consts.xapi_version ) diff --git a/ocaml/idl/json_backend/dune b/ocaml/idl/json_backend/dune index 804453c59c1..c03bead0cd8 100644 --- a/ocaml/idl/json_backend/dune +++ b/ocaml/idl/json_backend/dune @@ -1,8 +1,7 @@ (executable (modes exe) (name gen_json) - (libraries - dune-build-info + (libraries fmt xapi-datamodel xapi-consts diff --git a/ocaml/idl/ocaml_backend/dune b/ocaml/idl/ocaml_backend/dune index e373fe33d09..e69b5398959 100644 --- a/ocaml/idl/ocaml_backend/dune +++ b/ocaml/idl/ocaml_backend/dune @@ -3,13 +3,10 @@ (name gen_api_main) (libraries astring - dune-build-info - sexpr - uuid + uuidm xapi-consts xapi-datamodel xapi-log - xapi-stdext-pervasives xapi-stdext-std ) ) diff --git a/ocaml/idl/ocaml_backend/gen_rbac.ml b/ocaml/idl/ocaml_backend/gen_rbac.ml index 5f34ace5a46..64f8f4200ef 100644 --- a/ocaml/idl/ocaml_backend/gen_rbac.ml +++ b/ocaml/idl/ocaml_backend/gen_rbac.ml @@ -57,7 +57,7 @@ let writer_csv static_permissions_roles = let hash2uuid str = let h = Digest.string str in - Option.map Uuidx.to_string (Uuidx.of_bytes h) + Option.map Uuidm.to_string (Uuidm.of_bytes h) let replace_char str c1 c2 = let buf = Bytes.of_string str in diff --git a/ocaml/libs/clock/dune b/ocaml/libs/clock/dune index 3276c2c08ff..3c2ab5c67d6 100644 --- a/ocaml/libs/clock/dune +++ b/ocaml/libs/clock/dune @@ -3,7 +3,6 @@ (public_name clock) (modules date timer) (libraries - astring fmt (re_export mtime) mtime.clock.os diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index ee510d7fc42..1deae570337 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -60,7 +60,7 @@ (modules http_test radix_tree_test) (libraries alcotest - dune-build-info + fmt http_lib ) @@ -97,7 +97,7 @@ (name test_client) (modules test_client) (libraries - dune-build-info + http_lib safe-resources stunnel @@ -112,7 +112,7 @@ (name test_server) (modules test_server) (libraries - dune-build-info + http_lib httpsvr safe-resources diff --git a/ocaml/libs/log/dune b/ocaml/libs/log/dune index fdfd739d082..42e5f664119 100644 --- a/ocaml/libs/log/dune +++ b/ocaml/libs/log/dune @@ -11,7 +11,6 @@ logs threads.posix xapi-backtrace - xapi-stdext-pervasives ) (wrapped false) ) diff --git a/ocaml/libs/sexpr/dune b/ocaml/libs/sexpr/dune index 8f1c2a0e0ef..77653c2abcc 100644 --- a/ocaml/libs/sexpr/dune +++ b/ocaml/libs/sexpr/dune @@ -9,8 +9,6 @@ (modules (:standard \ sexprpp)) (libraries astring - threads.posix - xapi-stdext-threads ) ) diff --git a/ocaml/license/dune b/ocaml/license/dune index 8981c7c0bef..e2ee71b2b3f 100644 --- a/ocaml/license/dune +++ b/ocaml/license/dune @@ -19,7 +19,6 @@ (modules daily_license_check_main) (libraries daily_license_check - dune-build-info http_lib xapi-client xapi-types diff --git a/ocaml/mpathalert/dune b/ocaml/mpathalert/dune index 569e98b8b35..2a46ae7e524 100644 --- a/ocaml/mpathalert/dune +++ b/ocaml/mpathalert/dune @@ -3,8 +3,7 @@ (name mpathalert) (public_name mpathalert) (package xapi) - (libraries - dune-build-info + (libraries http_lib threads.posix uuid diff --git a/ocaml/nbd/src/dune b/ocaml/nbd/src/dune index 9f242944676..076e6884786 100644 --- a/ocaml/nbd/src/dune +++ b/ocaml/nbd/src/dune @@ -4,7 +4,7 @@ (libraries cmdliner consts - dune-build-info + local_xapi_session lwt lwt.unix diff --git a/ocaml/networkd/bin/dune b/ocaml/networkd/bin/dune index 7f154a0db5c..2b50b1e4159 100644 --- a/ocaml/networkd/bin/dune +++ b/ocaml/networkd/bin/dune @@ -16,7 +16,7 @@ (modes exe) (libraries astring - dune-build-info + forkexec http_lib integers diff --git a/ocaml/networkd/bin_db/dune b/ocaml/networkd/bin_db/dune index f36c68215de..b105b554b53 100644 --- a/ocaml/networkd/bin_db/dune +++ b/ocaml/networkd/bin_db/dune @@ -4,7 +4,7 @@ (package xapi-networkd) (modes exe) (libraries - dune-build-info + networklibs xapi-idl.network) ) diff --git a/ocaml/networkd/test/dune b/ocaml/networkd/test/dune index 06c39333171..951eda074a0 100644 --- a/ocaml/networkd/test/dune +++ b/ocaml/networkd/test/dune @@ -4,7 +4,7 @@ (libraries alcotest astring - dune-build-info + fmt networklibs rpclib.core diff --git a/ocaml/perftest/dune b/ocaml/perftest/dune index 137511118b8..eb5bb586d5c 100644 --- a/ocaml/perftest/dune +++ b/ocaml/perftest/dune @@ -4,7 +4,7 @@ (public_name perftest) (package xapi) (libraries - dune-build-info + http_lib rpclib.core threads.posix diff --git a/ocaml/quicktest/dune b/ocaml/quicktest/dune index b5d02cc9496..31219a94d94 100644 --- a/ocaml/quicktest/dune +++ b/ocaml/quicktest/dune @@ -6,7 +6,7 @@ (libraries alcotest astring - dune-build-info + ezxenstore ezxenstore.watch fmt diff --git a/ocaml/rrd2csv/src/dune b/ocaml/rrd2csv/src/dune index 6c891c32a94..ce263d70a01 100644 --- a/ocaml/rrd2csv/src/dune +++ b/ocaml/rrd2csv/src/dune @@ -4,7 +4,7 @@ (public_name rrd2csv) (package rrd2csv) (libraries - dune-build-info + http_lib threads.posix xapi-idl.rrd diff --git a/ocaml/sdk-gen/c/dune b/ocaml/sdk-gen/c/dune index ec5812bda74..79cb32b80c6 100644 --- a/ocaml/sdk-gen/c/dune +++ b/ocaml/sdk-gen/c/dune @@ -4,7 +4,7 @@ (libraries astring CommonFunctions - dune-build-info + mustache xapi-datamodel ) diff --git a/ocaml/sdk-gen/csharp/dune b/ocaml/sdk-gen/csharp/dune index 417dca4d4b1..e7112b1aae9 100644 --- a/ocaml/sdk-gen/csharp/dune +++ b/ocaml/sdk-gen/csharp/dune @@ -5,7 +5,7 @@ (libraries astring CommonFunctions - dune-build-info + mustache xapi-consts xapi-datamodel @@ -18,7 +18,7 @@ (modules Friendly_error_names) (libraries CommonFunctions - dune-build-info + mustache xapi-datamodel xmllight2 diff --git a/ocaml/sdk-gen/java/dune b/ocaml/sdk-gen/java/dune index 2588d3ba785..498b3a7bc09 100644 --- a/ocaml/sdk-gen/java/dune +++ b/ocaml/sdk-gen/java/dune @@ -4,7 +4,7 @@ (libraries astring CommonFunctions - dune-build-info + mustache str xapi-datamodel diff --git a/ocaml/sdk-gen/powershell/dune b/ocaml/sdk-gen/powershell/dune index b0f1fe83a4b..39b2f99b75f 100644 --- a/ocaml/sdk-gen/powershell/dune +++ b/ocaml/sdk-gen/powershell/dune @@ -4,7 +4,7 @@ (libraries astring CommonFunctions - dune-build-info + mustache xapi-datamodel ) diff --git a/ocaml/squeezed/src/dune b/ocaml/squeezed/src/dune index c5d6683ad92..4db102ad8a0 100644 --- a/ocaml/squeezed/src/dune +++ b/ocaml/squeezed/src/dune @@ -10,7 +10,7 @@ xapi-stdext-unix xapi_version astring - dune-build-info + rpclib.core squeeze threads.posix diff --git a/ocaml/tests/alerts/dune b/ocaml/tests/alerts/dune index 613f4077eaa..d7f29a5fa76 100644 --- a/ocaml/tests/alerts/dune +++ b/ocaml/tests/alerts/dune @@ -5,7 +5,7 @@ alcotest certificate_check daily_license_check - dune-build-info + expiry_alert fmt xapi-consts diff --git a/ocaml/tests/dune b/ocaml/tests/dune index 207853f7a5d..7cc177ba586 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -15,7 +15,7 @@ angstrom astring cstruct - dune-build-info + fmt http_lib httpsvr diff --git a/ocaml/util/dune b/ocaml/util/dune index 2aeb1e2e5a2..7a21f9bb24b 100644 --- a/ocaml/util/dune +++ b/ocaml/util/dune @@ -11,8 +11,8 @@ ; we don't want it inlined (flags (:standard -opaque)) (libraries - xapi-inventory dune-build-info + xapi-inventory ) (wrapped false) ) diff --git a/ocaml/vhd-tool/cli/dune b/ocaml/vhd-tool/cli/dune index 63f017a92d4..cb85ba1a1dc 100644 --- a/ocaml/vhd-tool/cli/dune +++ b/ocaml/vhd-tool/cli/dune @@ -5,7 +5,7 @@ (public_names vhd-tool sparse_dd get_vhd_vsize) (libraries astring - dune-build-info + local_lib cmdliner cstruct diff --git a/ocaml/vncproxy/dune b/ocaml/vncproxy/dune index b384086d377..5e6e1d768d8 100644 --- a/ocaml/vncproxy/dune +++ b/ocaml/vncproxy/dune @@ -4,7 +4,7 @@ (public_name vncproxy) (package xapi) (libraries - dune-build-info + http_lib stunnel xapi-client diff --git a/ocaml/xapi-guard/src/dune b/ocaml/xapi-guard/src/dune index ac7a6665c1a..7c48635b73b 100644 --- a/ocaml/xapi-guard/src/dune +++ b/ocaml/xapi-guard/src/dune @@ -4,7 +4,7 @@ (libraries astring cmdliner - dune-build-info + lwt lwt.unix message-switch-lwt diff --git a/ocaml/xapi-guard/test/dune b/ocaml/xapi-guard/test/dune index 9d44fdefbac..5c98ec22658 100644 --- a/ocaml/xapi-guard/test/dune +++ b/ocaml/xapi-guard/test/dune @@ -5,7 +5,7 @@ (libraries alcotest alcotest-lwt - dune-build-info + fmt lwt rpclib.core diff --git a/ocaml/xapi-idl/guard/privileged/dune b/ocaml/xapi-idl/guard/privileged/dune index eff7682e710..cdb888692d1 100644 --- a/ocaml/xapi-idl/guard/privileged/dune +++ b/ocaml/xapi-idl/guard/privileged/dune @@ -18,7 +18,7 @@ (package varstored-guard) (libraries cmdliner - dune-build-info + rpclib.cmdliner rpclib.core rpclib.markdown diff --git a/ocaml/xapi-idl/guard/varstored/dune b/ocaml/xapi-idl/guard/varstored/dune index a54af22988a..abded2e1c17 100644 --- a/ocaml/xapi-idl/guard/varstored/dune +++ b/ocaml/xapi-idl/guard/varstored/dune @@ -17,7 +17,7 @@ (modules varstored_cli) (libraries cmdliner - dune-build-info + rpclib.cmdliner rpclib.core rpclib.markdown diff --git a/ocaml/xapi-idl/lib/dune b/ocaml/xapi-idl/lib/dune index 29ea321bce3..ab2f7ab6a0c 100644 --- a/ocaml/xapi-idl/lib/dune +++ b/ocaml/xapi-idl/lib/dune @@ -7,14 +7,12 @@ cmdliner cohttp cohttp-posix - (re_export dune-build-info) fd-send-recv logs message-switch-core message-switch-unix mtime mtime.clock.os - ppx_sexp_conv.runtime-lib re rpclib.core rpclib.json diff --git a/ocaml/xapi-idl/network/dune b/ocaml/xapi-idl/network/dune index eb321c114e3..a9a4869945d 100644 --- a/ocaml/xapi-idl/network/dune +++ b/ocaml/xapi-idl/network/dune @@ -21,7 +21,7 @@ (modules network_cli) (libraries cmdliner - dune-build-info + rpclib.cmdliner rpclib.core rpclib.markdown diff --git a/ocaml/xapi-idl/rrd/dune b/ocaml/xapi-idl/rrd/dune index 7a407a77e9d..9462c9341e6 100644 --- a/ocaml/xapi-idl/rrd/dune +++ b/ocaml/xapi-idl/rrd/dune @@ -50,7 +50,7 @@ (modes exe) (libraries cmdliner - dune-build-info + rpclib.cmdliner rpclib.core rpclib.markdown diff --git a/ocaml/xapi-idl/storage/dune b/ocaml/xapi-idl/storage/dune index 500a6f5bbfd..05f146429bc 100644 --- a/ocaml/xapi-idl/storage/dune +++ b/ocaml/xapi-idl/storage/dune @@ -54,7 +54,7 @@ (libraries alcotest cmdliner - dune-build-info + xapi-idl xapi-idl.storage xapi-idl.storage.interface @@ -67,7 +67,7 @@ (modules suite vdi_automaton_test) (libraries alcotest - dune-build-info + xapi-idl.storage.interface xapi-idl.storage.interface.types ) diff --git a/ocaml/xapi-idl/v6/dune b/ocaml/xapi-idl/v6/dune index 059bf6fc181..79751c08794 100644 --- a/ocaml/xapi-idl/v6/dune +++ b/ocaml/xapi-idl/v6/dune @@ -19,7 +19,7 @@ (modules v6_cli) (libraries cmdliner - dune-build-info + rpclib.cmdliner rpclib.core rpclib.markdown diff --git a/ocaml/xapi-storage-cli/dune b/ocaml/xapi-storage-cli/dune index d64138c29df..624f2f727e1 100644 --- a/ocaml/xapi-storage-cli/dune +++ b/ocaml/xapi-storage-cli/dune @@ -1,7 +1,7 @@ (executable (name main) (libraries - dune-build-info + xapi-idl xapi-idl.storage xapi-idl.storage.interface diff --git a/ocaml/xapi-storage-script/dune b/ocaml/xapi-storage-script/dune index c137849c72e..e27762a2963 100644 --- a/ocaml/xapi-storage-script/dune +++ b/ocaml/xapi-storage-script/dune @@ -10,7 +10,7 @@ core core_unix core_unix.time_unix - dune-build-info + message-switch-async message-switch-unix result diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index d1a38196462..e01e010a77f 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/dune +++ b/ocaml/xcp-rrdd/bin/rrdd/dune @@ -5,7 +5,7 @@ (modules (:standard \ xcp_rrdd)) (libraries astring - dune-build-info + ezxenstore gzip http_lib @@ -43,7 +43,7 @@ (modules xcp_rrdd) (libraries astring - dune-build-info + ezxenstore.core ezxenstore.watch forkexec diff --git a/ocaml/xcp-rrdd/bin/rrddump/dune b/ocaml/xcp-rrdd/bin/rrddump/dune index 9af30f6fabc..0e79375137d 100644 --- a/ocaml/xcp-rrdd/bin/rrddump/dune +++ b/ocaml/xcp-rrdd/bin/rrddump/dune @@ -3,7 +3,7 @@ (name rrddump) (public_name rrddump) (libraries - dune-build-info + rrd-transport xapi-rrd xapi-rrd.unix diff --git a/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune b/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune index 0f438a65861..6e422954c79 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune @@ -4,7 +4,7 @@ (package rrdd-plugins) (public_name xcp-rrdd-dcmi) (libraries - dune-build-info + rrdd-plugin rrdd-plugins.libs xapi-idl.rrd diff --git a/ocaml/xcp-rrdd/bin/rrdp-dummy/dune b/ocaml/xcp-rrdd/bin/rrdp-dummy/dune index 6441afe0f61..c3ff89a1c35 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-dummy/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-dummy/dune @@ -3,7 +3,7 @@ (public_name rrdp_dummy) (package xapi-rrdd-plugin) (libraries - dune-build-info + rrdd-plugin xapi-idl.rrd xapi-rrd diff --git a/ocaml/xcp-rrdd/bin/rrdp-iostat/dune b/ocaml/xcp-rrdd/bin/rrdp-iostat/dune index 4c6dd005206..7933a9a3fdc 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-iostat/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-iostat/dune @@ -6,7 +6,7 @@ (libraries astring cstruct - dune-build-info + ezxenstore.core inotify mtime diff --git a/ocaml/xcp-rrdd/bin/rrdp-squeezed/dune b/ocaml/xcp-rrdd/bin/rrdp-squeezed/dune index 69a0f05cf98..955b2bdecb9 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-squeezed/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-squeezed/dune @@ -4,7 +4,7 @@ (package rrdd-plugins) (public_name xcp-rrdd-squeezed) (libraries - dune-build-info + rrdd-plugin rrdd-plugins.libs xapi-stdext-std diff --git a/ocaml/xcp-rrdd/bin/rrdp-xenpm/dune b/ocaml/xcp-rrdd/bin/rrdp-xenpm/dune index 8e71461e3fb..f28b84ef511 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-xenpm/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-xenpm/dune @@ -4,7 +4,7 @@ (package rrdd-plugins) (public_name xcp-rrdd-xenpm) (libraries - dune-build-info + rrdd-plugin rrdd-plugins.libs str diff --git a/ocaml/xcp-rrdd/bin/transport-rw/dune b/ocaml/xcp-rrdd/bin/transport-rw/dune index 9630a477ac4..1b933823051 100644 --- a/ocaml/xcp-rrdd/bin/transport-rw/dune +++ b/ocaml/xcp-rrdd/bin/transport-rw/dune @@ -5,7 +5,7 @@ (package xapi-rrd-transport-utils) (libraries cmdliner - dune-build-info + rrd-transport threads.posix xapi-idl.rrd diff --git a/ocaml/xcp-rrdd/test/rrdd/dune b/ocaml/xcp-rrdd/test/rrdd/dune index 92c674df715..bf654c0e66f 100644 --- a/ocaml/xcp-rrdd/test/rrdd/dune +++ b/ocaml/xcp-rrdd/test/rrdd/dune @@ -4,7 +4,7 @@ (package xapi-rrdd) (libraries alcotest - dune-build-info + fmt rrdd_libs_internal xapi-idl.rrd diff --git a/ocaml/xcp-rrdd/test/transport/dune b/ocaml/xcp-rrdd/test/transport/dune index 333b4db49ce..4efd2bc042d 100644 --- a/ocaml/xcp-rrdd/test/transport/dune +++ b/ocaml/xcp-rrdd/test/transport/dune @@ -3,7 +3,7 @@ (package rrd-transport) (libraries alcotest - dune-build-info + fmt rrd-transport xapi-idl.rrd diff --git a/ocaml/xe-cli/dune b/ocaml/xe-cli/dune index f72cacbbda4..5362781b31a 100644 --- a/ocaml/xe-cli/dune +++ b/ocaml/xe-cli/dune @@ -5,7 +5,7 @@ (package xe) (libraries astring - dune-build-info + fpath safe-resources stunnel diff --git a/ocaml/xen-api-client/async_examples/dune b/ocaml/xen-api-client/async_examples/dune index 7cfce054d69..7d39e42c902 100644 --- a/ocaml/xen-api-client/async_examples/dune +++ b/ocaml/xen-api-client/async_examples/dune @@ -9,7 +9,7 @@ base.caml core core_kernel - dune-build-info + xapi-consts xapi-types xen-api-client @@ -27,9 +27,7 @@ base base.caml core - core_kernel - dune-build-info - ppx_sexp_conv.runtime-lib + core_kernel rpclib.json sexplib0 xapi-consts diff --git a/ocaml/xen-api-client/lib_test/dune b/ocaml/xen-api-client/lib_test/dune index 12e1921130c..cc868d261b6 100644 --- a/ocaml/xen-api-client/lib_test/dune +++ b/ocaml/xen-api-client/lib_test/dune @@ -2,7 +2,7 @@ (name xen_api_test) (package xen-api-client) (libraries - dune-build-info + alcotest rpclib.xml uri diff --git a/ocaml/xen-api-client/lwt_examples/dune b/ocaml/xen-api-client/lwt_examples/dune index ba5fe7c95e2..56d95a3e6d9 100644 --- a/ocaml/xen-api-client/lwt_examples/dune +++ b/ocaml/xen-api-client/lwt_examples/dune @@ -3,7 +3,7 @@ (name list_vms) (modules list_vms) (libraries - dune-build-info + lwt lwt.unix uri @@ -20,7 +20,7 @@ (modules upload_disk) (libraries cstruct - dune-build-info + lwt lwt.unix uri @@ -40,7 +40,7 @@ cohttp-lwt cohttp-lwt-unix conduit-lwt-unix - dune-build-info + lwt lwt.unix ssl diff --git a/ocaml/xenforeign/dune b/ocaml/xenforeign/dune index 8e6b3118042..d120d9669cd 100644 --- a/ocaml/xenforeign/dune +++ b/ocaml/xenforeign/dune @@ -1,4 +1,4 @@ (executable (name main) - (libraries bigarray-compat cstruct dune-build-info xenctrl xenopsd_xc hex) + (libraries bigarray-compat cstruct xenctrl xenopsd_xc hex) ) diff --git a/ocaml/xenopsd/cli/dune b/ocaml/xenopsd/cli/dune index d8482fced6e..0b2e0f0c2cf 100644 --- a/ocaml/xenopsd/cli/dune +++ b/ocaml/xenopsd/cli/dune @@ -8,7 +8,7 @@ (libraries astring cmdliner - dune-build-info + re result rpclib.core diff --git a/ocaml/xenopsd/dbgring/dune b/ocaml/xenopsd/dbgring/dune index 0f79c13e2f0..3d95198039f 100644 --- a/ocaml/xenopsd/dbgring/dune +++ b/ocaml/xenopsd/dbgring/dune @@ -3,7 +3,7 @@ (public_name dbgring) (package xapi-xenopsd-xc) (libraries - dune-build-info + xapi-xenopsd xenctrl xenmmap diff --git a/ocaml/xenopsd/list_domains/dune b/ocaml/xenopsd/list_domains/dune index 2856c531e38..be8407cb32d 100644 --- a/ocaml/xenopsd/list_domains/dune +++ b/ocaml/xenopsd/list_domains/dune @@ -2,5 +2,5 @@ (name list_domains) (public_name list_domains) (package xapi-xenopsd-xc) - (libraries dune-build-info xenctrl xapi-idl.memory ezxenstore.watch uuid) + (libraries xenctrl xapi-idl.memory ezxenstore.watch uuid) ) diff --git a/ocaml/xenopsd/simulator/dune b/ocaml/xenopsd/simulator/dune index 8fc0d86f669..740b6d9b9e0 100644 --- a/ocaml/xenopsd/simulator/dune +++ b/ocaml/xenopsd/simulator/dune @@ -3,7 +3,7 @@ (public_name xenopsd-simulator) (package xapi-xenopsd-simulator) (libraries - dune-build-info + xapi-idl.xen.interface xapi-xenopsd ) diff --git a/ocaml/xenopsd/test/dune b/ocaml/xenopsd/test/dune index e795d7295bf..a71ad643db9 100644 --- a/ocaml/xenopsd/test/dune +++ b/ocaml/xenopsd/test/dune @@ -5,7 +5,7 @@ (libraries alcotest cpuid - dune-build-info + fmt result rpclib.core diff --git a/ocaml/xenopsd/xc/dune b/ocaml/xenopsd/xc/dune index c1727b4493e..4a79452dbbe 100644 --- a/ocaml/xenopsd/xc/dune +++ b/ocaml/xenopsd/xc/dune @@ -71,7 +71,7 @@ (modules xenops_xc_main) (libraries - dune-build-info + ezxenstore.core uuid xapi-idl @@ -92,7 +92,7 @@ (libraries astring cmdliner - dune-build-info + ezxenstore.core uuid xapi-idl.memory @@ -109,7 +109,7 @@ (modes exe) (modules memory_summary) (libraries - dune-build-info + xapi-stdext-date xapi-stdext-unix xapi-xenopsd @@ -134,7 +134,7 @@ (modules cancel_utils_test) (libraries cmdliner - dune-build-info + ezxenstore.core threads.posix xapi-idl.xen.interface diff --git a/ocaml/xsh/dune b/ocaml/xsh/dune index 13fc1e74c46..121c95186e6 100644 --- a/ocaml/xsh/dune +++ b/ocaml/xsh/dune @@ -4,7 +4,7 @@ (public_name xsh) (package xapi) (libraries - dune-build-info + stunnel safe-resources xapi-consts diff --git a/xapi-rrdd.opam b/xapi-rrdd.opam index 8ec47c8322d..745af249f4b 100644 --- a/xapi-rrdd.opam +++ b/xapi-rrdd.opam @@ -11,7 +11,6 @@ bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "dune" {>= "3.15"} "ocaml" {>= "4.02.0"} - "dune-build-info" "alcotest" {with-test} "astring" "gzip" {= version} diff --git a/xen-api-client.opam b/xen-api-client.opam index c9fa73d8cf6..75773851324 100644 --- a/xen-api-client.opam +++ b/xen-api-client.opam @@ -16,7 +16,6 @@ homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "dune" {>= "3.15"} - "dune-build-info" "alcotest" {with-test} "astring" "cohttp" {>= "0.22.0"} From ebbc4c6b486f05ea18289dd27865851ad3b4644d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 22:59:43 +0100 Subject: [PATCH 044/157] [maintenance]: break dependency of gen_api_main on xapi_version MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Xapi_version depends on Build_info which can change on every commit. It is better to remove it from the dependencies of gen_api_main, especially that gen_api_main is on the critical path for discovering more dependencies. The 'xapi_user_agent' constant got moved to Xapi_version. Signed-off-by: Edwin Török --- ocaml/util/xapi_version.ml | 6 ++++++ ocaml/util/xapi_version.mli | 2 ++ ocaml/xapi-cli-server/cli_operations.ml | 2 +- ocaml/xapi-cli-server/dune | 1 + ocaml/xapi-consts/constants.ml | 8 -------- ocaml/xapi-consts/dune | 4 ---- ocaml/xapi/create_misc.ml | 3 ++- ocaml/xapi/dune | 1 + ocaml/xapi/export.ml | 4 ++-- ocaml/xapi/importexport.ml | 8 ++++---- ocaml/xapi/system_status.ml | 2 +- ocaml/xapi/xapi_http.ml | 4 ++-- ocaml/xapi/xapi_pool.ml | 4 ++-- 13 files changed, 24 insertions(+), 25 deletions(-) diff --git a/ocaml/util/xapi_version.ml b/ocaml/util/xapi_version.ml index 90e71077898..4b36a646e61 100644 --- a/ocaml/util/xapi_version.ml +++ b/ocaml/util/xapi_version.ml @@ -46,3 +46,9 @@ let compare_version version_a version_b = let maj_b, min_b, _ = parse_xapi_version version_b in let ( ) a b = if a = 0 then b else a in Int.compare maj_a maj_b Int.compare min_a min_b 0 + +let xapi_user_agent = + "xapi/" + ^ string_of_int xapi_version_major + ^ "." + ^ string_of_int xapi_version_minor diff --git a/ocaml/util/xapi_version.mli b/ocaml/util/xapi_version.mli index 77d6e5ef022..97bdbe8837a 100644 --- a/ocaml/util/xapi_version.mli +++ b/ocaml/util/xapi_version.mli @@ -25,3 +25,5 @@ val xapi_version_major : int val xapi_version_minor : int val compare_version : string -> string -> int + +val xapi_user_agent : string diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 5940803f59e..433e7a3625b 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -4578,7 +4578,7 @@ let vm_migrate printer rpc session_id params = let pwd = List.assoc "remote-password" params in let remote_session = Client.Session.login_with_password ~rpc:remote_rpc ~uname ~pwd - ~version:"1.3" ~originator:Constants.xapi_user_agent + ~version:"1.3" ~originator:Xapi_version.xapi_user_agent in let remote f = f ~rpc:remote_rpc ~session_id:remote_session in finally diff --git a/ocaml/xapi-cli-server/dune b/ocaml/xapi-cli-server/dune index 8f583541481..ff3efb6c7b0 100644 --- a/ocaml/xapi-cli-server/dune +++ b/ocaml/xapi-cli-server/dune @@ -18,6 +18,7 @@ threads.posix xapi-backtrace xapi-consts + xapi_version xapi_database xapi-datamodel xapi-log diff --git a/ocaml/xapi-consts/constants.ml b/ocaml/xapi-consts/constants.ml index 2e38e24bdfa..356c6ac6914 100644 --- a/ocaml/xapi-consts/constants.ml +++ b/ocaml/xapi-consts/constants.ml @@ -378,14 +378,6 @@ let http_limit_max_rpc_size = 300 * 1024 (* 300K *) let http_limit_max_cli_size = 200 * 1024 (* 200K *) -(* xapi version *) -let version_major = Xapi_version.xapi_version_major - -let version_minor = Xapi_version.xapi_version_minor - -let xapi_user_agent = - "xapi/" ^ string_of_int version_major ^ "." ^ string_of_int version_minor - (* Path to the pool configuration file. *) let pool_config_file = ref (Filename.concat "/etc/xensource" "pool.conf") diff --git a/ocaml/xapi-consts/dune b/ocaml/xapi-consts/dune index f5c35c96ed5..1c37b347206 100644 --- a/ocaml/xapi-consts/dune +++ b/ocaml/xapi-consts/dune @@ -2,8 +2,4 @@ (name xapi_consts) (public_name xapi-consts) (wrapped false) - (libraries - xapi_version - ) ) - diff --git a/ocaml/xapi/create_misc.ml b/ocaml/xapi/create_misc.ml index 1b6e26ab84d..beb94f4751c 100644 --- a/ocaml/xapi/create_misc.ml +++ b/ocaml/xapi/create_misc.ml @@ -435,7 +435,8 @@ let create_root_user ~__context = Db.User.create ~__context ~ref ~fullname ~short_name ~uuid ~other_config:[] let get_xapi_verstring () = - Printf.sprintf "%d.%d" Constants.version_major Constants.version_minor + Printf.sprintf "%d.%d" Xapi_version.xapi_version_major + Xapi_version.xapi_version_minor (** Create assoc list of Supplemental-Pack information. * The package information is taking from the [XS-REPOSITORY] XML file in the package diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 2d9d812a0d9..d979250bda5 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -154,6 +154,7 @@ xapi-stdext-zerocheck xapi-tracing xapi-tracing-export + xapi_version xapi-xenopsd xenstore_transport.unix xml-light2 diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 6cb156d21ca..24589827bc8 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -829,7 +829,7 @@ let metadata_handler (req : Request.t) s _ = Http.http_200_ok ~keep_alive:false ~version:"1.0" () @ [ Http.Hdr.task_id ^ ": " ^ task_id - ; "Server: " ^ Constants.xapi_user_agent + ; "Server: " ^ Xapi_version.xapi_user_agent ; content_type ; "Content-Length: " ^ string_of_int content_length ; "Content-Disposition: attachment; filename=\"export.xva\"" @@ -944,7 +944,7 @@ let handler (req : Request.t) s _ = Http.http_200_ok ~keep_alive:false ~version:"1.0" () @ [ Http.Hdr.task_id ^ ": " ^ task_id - ; "Server: " ^ Constants.xapi_user_agent + ; "Server: " ^ Xapi_version.xapi_user_agent ; content_type ; "Content-Disposition: attachment; filename=\"export.xva\"" ] diff --git a/ocaml/xapi/importexport.ml b/ocaml/xapi/importexport.ml index 869aac2a5f0..b6f784dc55c 100644 --- a/ocaml/xapi/importexport.ml +++ b/ocaml/xapi/importexport.ml @@ -41,8 +41,8 @@ let rpc_of_version x = ; (_product_version, Rpc.String x.product_version) ; (_product_brand, Rpc.String x.product_brand) ; (_build_number, Rpc.String x.build_number) - ; (_xapi_major, Rpc.Int (Int64.of_int Constants.version_major)) - ; (_xapi_minor, Rpc.Int (Int64.of_int Constants.version_minor)) + ; (_xapi_major, Rpc.Int (Int64.of_int Xapi_version.xapi_version_major)) + ; (_xapi_minor, Rpc.Int (Int64.of_int Xapi_version.xapi_version_minor)) ; (_export_vsn, Rpc.Int (Int64.of_int Xapi_globs.export_vsn)) ] @@ -112,8 +112,8 @@ let this_version __context = ; product_version= Xapi_version.product_version () ; product_brand= Xapi_version.product_brand () ; build_number= Xapi_version.build_number () - ; xapi_vsn_major= Constants.version_major - ; xapi_vsn_minor= Constants.version_minor + ; xapi_vsn_major= Xapi_version.xapi_version_major + ; xapi_vsn_minor= Xapi_version.xapi_version_minor ; export_vsn= Xapi_globs.export_vsn } diff --git a/ocaml/xapi/system_status.ml b/ocaml/xapi/system_status.ml index 1c564d541e8..bcbd0298d9c 100644 --- a/ocaml/xapi/system_status.ml +++ b/ocaml/xapi/system_status.ml @@ -52,7 +52,7 @@ let send_via_fd __context s entries output = let headers = Http.http_200_ok ~keep_alive:false ~version:"1.0" () @ [ - "Server: " ^ Constants.xapi_user_agent + "Server: " ^ Xapi_version.xapi_user_agent ; Http.Hdr.content_type ^ ": " ^ content_type ; "Content-Disposition: attachment; filename=\"system_status.tgz\"" ] diff --git a/ocaml/xapi/xapi_http.ml b/ocaml/xapi/xapi_http.ml index 13738ff292a..694520a5609 100644 --- a/ocaml/xapi/xapi_http.ml +++ b/ocaml/xapi/xapi_http.ml @@ -90,7 +90,7 @@ let create_session_for_client_cert req s = (* Has been authenticated. Performing RBAC check only ... *) Xapi_session.login_with_password ~__context ~uname:"" ~pwd:"" ~version:Datamodel_common.api_version_string - ~originator:Constants.xapi_user_agent + ~originator:Xapi_version.xapi_user_agent | Some `root | None -> raise (Http.Unauthorised "") @@ -300,7 +300,7 @@ let server = let server = Http_svr.Server.empty () in server -let http_request = Http.Request.make ~user_agent:Constants.xapi_user_agent +let http_request = Http.Request.make ~user_agent:Xapi_version.xapi_user_agent let bind inetaddr = let description = diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index c14d2acf806..f0cd7c49bfc 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -1427,7 +1427,7 @@ let join_common ~__context ~master_address ~master_username ~master_password Client.Session.login_with_password ~rpc:unverified_rpc ~uname:master_username ~pwd:master_password ~version:Datamodel_common.api_version_string - ~originator:Constants.xapi_user_agent + ~originator:Xapi_version.xapi_user_agent with Http_client.Http_request_rejected _ | Http_client.Http_error _ -> raise (Api_errors.Server_error @@ -1466,7 +1466,7 @@ let join_common ~__context ~master_address ~master_username ~master_password try Client.Session.login_with_password ~rpc ~uname:master_username ~pwd:master_password ~version:Datamodel_common.api_version_string - ~originator:Constants.xapi_user_agent + ~originator:Xapi_version.xapi_user_agent with Http_client.Http_request_rejected _ | Http_client.Http_error _ -> raise (Api_errors.Server_error From c8e828e725a5ee869c7d353c1885213016d75878 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 23:07:44 +0100 Subject: [PATCH 045/157] [maintenance]: xapi-types should not depend on xapi-idl MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-types/dune | 1 - 1 file changed, 1 deletion(-) diff --git a/ocaml/xapi-types/dune b/ocaml/xapi-types/dune index 12d1703ce3d..3fb8e0711b1 100644 --- a/ocaml/xapi-types/dune +++ b/ocaml/xapi-types/dune @@ -21,7 +21,6 @@ xapi-consts xapi-stdext-date xapi-stdext-unix - xapi-idl ) (wrapped false) (preprocess (per_module ((pps ppx_deriving_rpc) API Event_types Features SecretString))) From 9c85ed7dd86fc5bea2e83bf79a3cb23df5d810a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 23:28:49 +0100 Subject: [PATCH 046/157] [maintenance]: use bytecode for gen_api_main MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It'll be slower, but it can run a lot earlier in the build process. Compiling the datamodels takes time, but compiling them for bytecode is faster. Signed-off-by: Edwin Török --- ocaml/idl/ocaml_backend/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/idl/ocaml_backend/dune b/ocaml/idl/ocaml_backend/dune index e69b5398959..f6c4173d363 100644 --- a/ocaml/idl/ocaml_backend/dune +++ b/ocaml/idl/ocaml_backend/dune @@ -1,5 +1,5 @@ (executable - (modes exe) + (modes byte) (name gen_api_main) (libraries astring From bf350976df7eb99d1fddaa457273bfe8011a46fb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 23:54:46 +0100 Subject: [PATCH 047/157] [maintenance]: further split xapi_internal_server MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Introduce a _minimal library, so we can start compiling server.ml earlier. Build time reduced from 80s to: ``` Benchmark 1: dune clean; dune build --cache=disabled Time (mean ± σ): 67.081 s ± 0.190 s [User: 326.847 s, System: 103.668 s Range (min … max): 66.946 s … 67.215 s 2 runs ``` Signed-off-by: Edwin Török --- ocaml/xapi/dune | 55 +++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 53 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index d979250bda5..1dd7d06911a 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -54,11 +54,50 @@ (package xapi) ) +(library + (name xapi_internal_minimal) + (modules context custom_actions xapi_globs server_helpers session_check rbac rbac_audit db_actions taskHelper eventgen locking_helpers exnHelper rbac_static xapi_role xapi_extensions db) + (wrapped false) + (libraries + http_lib + httpsvr + ipaddr + xapi-types + xapi_database + mtime + tracing + uuid + rpclib.core + threads.posix + fmt + clock + astring + stunnel + sexplib0 + sexplib + sexpr + forkexec + xapi-idl + xapi_aux + xapi-stdext-std + xapi-stdext-date + xapi-stdext-pervasives + xapi-backtrace + xapi-datamodel + xapi-consts + xapi_version + xapi-stdext-threads + xapi-stdext-unix + rpclib.xml + xapi-log) +) + (library (name xapi_internal) (wrapped false) (modes best) - (modules (:standard \ xapi_main server api_server xapi)) + (modules (:standard \ + xapi_main server api_server xapi custom_actions context xapi_globs server_helpers session_check rbac rbac_audit rbac_static db_actions taskHelper eventgen locking_helpers exnHelper xapi_role xapi_extensions db)) (libraries angstrom astring @@ -140,6 +179,7 @@ xapi-idl.memory xapi-idl.gpumon xapi-idl.updates + (re_export xapi_internal_minimal) xapi-inventory xapi-log xapi-open-uri @@ -172,11 +212,19 @@ System_domains Xapi_psr Xapi_services Xapi_udhcpd))) ) +(library + (name xapi_internal_server_only) + (modes best) + (modules server) + (libraries xapi_internal_minimal http_lib rpclib.core xapi-types xapi-log xapi-stdext-encodings xapi-consts xapi-backtrace xapi-stdext-date rpclib.json) + (wrapped false) +) + (library (name xapi_internal_server) (modes best) (wrapped false) - (modules server api_server xapi) + (modules api_server xapi) (libraries forkexec http_lib @@ -190,8 +238,10 @@ xapi-client xapi-consts xapi-datamodel + xapi_internal_minimal xapi-idl xapi-inventory + (re_export xapi_internal_server_only) xapi-log xapi-stdext-date xapi-stdext-encodings @@ -216,6 +266,7 @@ (libraries xapi_internal xapi_internal_server + xapi_internal_minimal xapi-idl xapi-log xapi-stdext-unix From 62ff5e74065c810d79cc5c6db751b6121646d5bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:35 +0000 Subject: [PATCH 048/157] [maintenance]: reduce basic-rpc-test time MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Remove most sleeps, and reduce test duration from 5 seconds to 1. (If we do want to run a performance test we can increase these again) Run just a basic test for 0.1 seconds instead of a performance test for 5s by default. (can still be tweaked by overriding SECS) Signed-off-by: Edwin Török --- .../core_test/basic-rpc-test.sh | 46 ++++++++++--------- 1 file changed, 25 insertions(+), 21 deletions(-) diff --git a/ocaml/message-switch/core_test/basic-rpc-test.sh b/ocaml/message-switch/core_test/basic-rpc-test.sh index 877790370a2..ce0aea92be3 100755 --- a/ocaml/message-switch/core_test/basic-rpc-test.sh +++ b/ocaml/message-switch/core_test/basic-rpc-test.sh @@ -3,38 +3,42 @@ set -e SPATH=${TMPDIR:-/tmp}/sock_s SWITCHPATH=${TMPDIR:-/tmp}/switch_s +SECS=0.1 - -rm -rf ${SWITCHPATH} && mkdir -p ${SWITCHPATH} +rm -rf "${SWITCHPATH}" && mkdir -p "${SWITCHPATH}" echo Test message switch serial processing echo Checking the switch can start late -./server_unix_main.exe -path $SPATH & -sleep 1 -../switch/switch_main.exe --path $SPATH --statedir ${SWITCHPATH} & -./client_unix_main.exe -path $SPATH -secs 5 -sleep 2 +./server_unix_main.exe -path "${SPATH}" & +SERVER=$! +sleep "${SECS}" +../switch/switch_main.exe --path "${SPATH}" --statedir "${SWITCHPATH}" & +./client_unix_main.exe -path "${SPATH}" -secs "${SECS}" +wait "${SERVER}" echo Performance test of Unix to Unix -./server_unix_main.exe -path $SPATH & -./client_unix_main.exe -path $SPATH -secs 5 -sleep 2 +./server_unix_main.exe -path "${SPATH}" & +SERVER=$! +./client_unix_main.exe -path "${SPATH}" -secs "${SECS}" +wait "${SERVER}" echo Performance test of Lwt to Lwt -lwt/server_main.exe -path $SPATH & -lwt/client_main.exe -path $SPATH -secs 5 -sleep 2 +lwt/server_main.exe -path "${SPATH}" & +SERVER=$! +lwt/client_main.exe -path "${SPATH}" -secs "${SECS}" +wait "${SERVER}" echo Performance test of Async to Lwt -lwt/server_main.exe -path $SPATH & -async/client_async_main.exe -path $SPATH -secs 5 -sleep 2 +lwt/server_main.exe -path "${SPATH}" & +SERVER=$! +async/client_async_main.exe -path "${SPATH}" -secs "${SECS}" +wait "${SERVER}" echo Performance test of Async to Async -async/server_async_main.exe -path $SPATH & -async/client_async_main.exe -path $SPATH -secs 5 -sleep 2 +async/server_async_main.exe -path "${SPATH}" & +SERVER=$! +async/client_async_main.exe -path "${SPATH}" -secs "${SECS}" +wait "${SERVER}" -../cli/main.exe shutdown --path $SPATH -sleep 2 +../cli/main.exe shutdown --path "${SPATH}" From 7530d5e1ca8d5742990e45c61a01f2ebdbb779a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 20 Mar 2023 18:29:35 +0000 Subject: [PATCH 049/157] [maintenance]: try to reconnect to message-switch every 0.5s MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Instead of every 5s. Speeds up testing, and may speed up startup somewhat. And a connection try once every 0.5s won't create a lot of load on the system. (If needed we could implement some form of exponential backoff here). ``` Benchmark 1: dune clean; dune runtest --cache=disabled Time (mean ± σ): 97.642 s ± 0.933 s [User: 354.132 s, System: 113.436 s] Range (min … max): 96.982 s … 98.302 s 2 runsi ``` Signed-off-by: Edwin Török --- ocaml/message-switch/async/protocol_async.ml | 2 +- ocaml/message-switch/core_test/basic-rpc-test.sh | 2 +- ocaml/message-switch/lwt/protocol_lwt.ml | 2 +- ocaml/message-switch/unix/protocol_unix.ml | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/ocaml/message-switch/async/protocol_async.ml b/ocaml/message-switch/async/protocol_async.ml index 5898d22f77f..2bc34621563 100644 --- a/ocaml/message-switch/async/protocol_async.ml +++ b/ocaml/message-switch/async/protocol_async.ml @@ -72,7 +72,7 @@ module M = struct | Ok (_, reader, writer) -> return (reader, writer) in - retry 1. + retry 0.5 let disconnect (_, writer) = Writer.close writer diff --git a/ocaml/message-switch/core_test/basic-rpc-test.sh b/ocaml/message-switch/core_test/basic-rpc-test.sh index ce0aea92be3..bc281c65f45 100755 --- a/ocaml/message-switch/core_test/basic-rpc-test.sh +++ b/ocaml/message-switch/core_test/basic-rpc-test.sh @@ -3,7 +3,7 @@ set -e SPATH=${TMPDIR:-/tmp}/sock_s SWITCHPATH=${TMPDIR:-/tmp}/switch_s -SECS=0.1 +SECS=${SECS:-0.1} rm -rf "${SWITCHPATH}" && mkdir -p "${SWITCHPATH}" diff --git a/ocaml/message-switch/lwt/protocol_lwt.ml b/ocaml/message-switch/lwt/protocol_lwt.ml index 26c9c874d55..af9ce1ce5c6 100644 --- a/ocaml/message-switch/lwt/protocol_lwt.ml +++ b/ocaml/message-switch/lwt/protocol_lwt.ml @@ -47,7 +47,7 @@ module M = struct (function | Unix.Unix_error ((Unix.ECONNREFUSED | Unix.ECONNABORTED | Unix.ENOENT), _, _) -> - Lwt_unix.sleep 5. >>= fun () -> connect' () + Lwt_unix.sleep 0.5 >>= fun () -> connect' () | e -> Lwt_unix.close fd >>= fun () -> fail e ) diff --git a/ocaml/message-switch/unix/protocol_unix.ml b/ocaml/message-switch/unix/protocol_unix.ml index a9b4984e4f4..7e4432a28f2 100644 --- a/ocaml/message-switch/unix/protocol_unix.ml +++ b/ocaml/message-switch/unix/protocol_unix.ml @@ -100,7 +100,7 @@ module IO = struct | Unix.Unix_error ((Unix.ECONNREFUSED | Unix.ENOENT), _cmd, _) -> Unix.close fd ; (* wait for the server to start *) - Thread.delay 5. + Thread.delay 0.5 | e -> Unix.close fd ; raise e done ; From a6406eaab37e0d4fd2aafa814677a0ba56959e6f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 24 Jul 2024 09:39:41 +0100 Subject: [PATCH 050/157] [maintenance]: add back the 5s message-switch test as a stresstest MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/message-switch/core_test/dune | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/ocaml/message-switch/core_test/dune b/ocaml/message-switch/core_test/dune index 449f2fae5c5..cda5c5125aa 100644 --- a/ocaml/message-switch/core_test/dune +++ b/ocaml/message-switch/core_test/dune @@ -57,6 +57,24 @@ (package message-switch) ) +(rule + (alias stresstest) + (deps + client_unix_main.exe + server_unix_main.exe + async/client_async_main.exe + async/server_async_main.exe + lwt/client_main.exe + lwt/server_main.exe + lwt/link_test_main.exe + ../switch/switch_main.exe + ../cli/main.exe + ) + (action (setenv SECS 5 (run ./basic-rpc-test.sh))) + (package message-switch) +) + + (rule (alias runtest) (deps From e5fa761d7516c58bb5b1324a9956182c64b41a80 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 24 Jul 2024 11:31:18 +0100 Subject: [PATCH 051/157] maintenance: delete unused fields These are errors in dune 3.15 and don't seem to be problematic Signed-off-by: Pau Ruiz Safont --- ocaml/database/master_connection.ml | 2 +- ocaml/idl/datamodel_values.ml | 2 +- ocaml/libs/http-lib/buf_io.ml | 7 +------ ocaml/libs/http-lib/xmlrpc_client.ml | 2 +- ocaml/libs/stunnel/stunnel_cache.ml | 20 +++++-------------- ocaml/libs/stunnel/stunnel_cache.mli | 3 +-- ocaml/libs/vhd/vhd_format/f.ml | 4 ---- ocaml/libs/vhd/vhd_format_lwt/block.ml | 5 ++--- ocaml/libs/vhd/vhd_format_lwt/iO.ml | 4 ++-- .../lib/xapi-stdext-threads/threadext.ml | 8 ++------ .../lib/xapi-stdext-unix/unixext.ml | 2 +- ocaml/libs/xml-light2/xml.ml | 6 +++--- ocaml/message-switch/switch/logging.ml | 9 +-------- ocaml/rrd2csv/src/rrd2csv.ml | 12 +++-------- ocaml/xapi-idl/lib/scheduler.ml | 4 ++-- ocaml/xapi-idl/lib/task_server.ml | 4 +--- ocaml/xapi/vgpuops.ml | 4 ---- ocaml/xapi/xapi_dr_task.ml | 9 +-------- ocaml/xapi/xapi_event.ml | 18 ++++++----------- ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml | 9 ++++----- ocaml/xen-api-client/lib_test/xen_api_test.ml | 10 +++++----- ocaml/xsh/xsh.ml | 2 +- 22 files changed, 44 insertions(+), 102 deletions(-) diff --git a/ocaml/database/master_connection.ml b/ocaml/database/master_connection.ml index 2547ae53182..346773303e8 100644 --- a/ocaml/database/master_connection.ml +++ b/ocaml/database/master_connection.ml @@ -71,7 +71,7 @@ let force_connection_reset () = host and port are fixed values. *) let rec purge_stunnels verify_cert = match - Stunnel_cache.with_remove ~host ~port verify_cert @@ fun st -> + Stunnel_cache.with_remove ~host ~port @@ fun st -> try Stunnel.disconnect ~wait:false ~force:true st with _ -> () with | None -> diff --git a/ocaml/idl/datamodel_values.ml b/ocaml/idl/datamodel_values.ml index a13330f971d..1b463d4b2e7 100644 --- a/ocaml/idl/datamodel_values.ml +++ b/ocaml/idl/datamodel_values.ml @@ -80,7 +80,7 @@ let to_ocaml_string v = in aux (to_rpc v) -let rec to_db v = +let to_db v = let open Schema.Value in match v with | VString s -> diff --git a/ocaml/libs/http-lib/buf_io.ml b/ocaml/libs/http-lib/buf_io.ml index 6a6397a614c..7073cf76a05 100644 --- a/ocaml/libs/http-lib/buf_io.ml +++ b/ocaml/libs/http-lib/buf_io.ml @@ -13,12 +13,7 @@ *) (* Buffered IO with timeouts *) -type t = { - fd: Unix.file_descr - ; mutable buf: bytes - ; mutable cur: int - ; mutable max: int -} +type t = {fd: Unix.file_descr; buf: bytes; mutable cur: int; mutable max: int} type err = | (* Line input is > 1024 chars *) diff --git a/ocaml/libs/http-lib/xmlrpc_client.ml b/ocaml/libs/http-lib/xmlrpc_client.ml index bdfc63621df..a93bda5e888 100644 --- a/ocaml/libs/http-lib/xmlrpc_client.ml +++ b/ocaml/libs/http-lib/xmlrpc_client.ml @@ -189,7 +189,7 @@ let with_reusable_stunnel ?use_fork_exec_helper ?write_to_log ?verify_cert host (* 1. First check if there is a suitable stunnel in the cache. *) let rec loop () = match - Stunnel_cache.with_remove ~host ~port verify_cert @@ fun x -> + Stunnel_cache.with_remove ~host ~port @@ fun x -> if check_reusable x.Stunnel.fd (Stunnel.getpid x.Stunnel.pid) then Ok (f x) else ( diff --git a/ocaml/libs/stunnel/stunnel_cache.ml b/ocaml/libs/stunnel/stunnel_cache.ml index 36d986b89c3..d69fbf10091 100644 --- a/ocaml/libs/stunnel/stunnel_cache.ml +++ b/ocaml/libs/stunnel/stunnel_cache.ml @@ -37,11 +37,7 @@ let ignore_log fmt = Printf.ksprintf (fun _ -> ()) fmt (* Use and overlay the definition from D. *) let debug = if debug_enabled then debug else ignore_log -type endpoint = { - host: string - ; port: int - ; verified: Stunnel.verification_config option -} +type endpoint = {host: string; port: int} (* Need to limit the absolute number of stunnels as well as the maximum age *) let max_stunnel = 70 @@ -187,13 +183,7 @@ let add (x : Stunnel.t) = incr counter ; Hashtbl.add !times idx now ; Tbl.move_into !stunnels idx x ; - let ep = - { - host= x.Stunnel.host - ; port= x.Stunnel.port - ; verified= x.Stunnel.verified - } - in + let ep = {host= x.Stunnel.host; port= x.Stunnel.port} in let existing = Option.value (Hashtbl.find_opt !index ep) ~default:[] in Hashtbl.replace !index ep (idx :: existing) ; debug "Adding stunnel id %s (idle %.2f) to the cache" (id_of_stunnel x) 0. ; @@ -203,8 +193,8 @@ let add (x : Stunnel.t) = (** Returns an Stunnel.t for this endpoint (oldest first), raising Not_found if none can be found. First performs a garbage-collection, which discards expired stunnels if needed. *) -let with_remove ~host ~port verified f = - let ep = {host; port; verified} in +let with_remove ~host ~port f = + let ep = {host; port} in let get_id () = with_lock m (fun () -> unlocked_gc () ; @@ -253,7 +243,7 @@ let flush () = let with_connect ?use_fork_exec_helper ?write_to_log ~verify_cert ~host ~port f = - match with_remove ~host ~port verify_cert f with + match with_remove ~host ~port f with | Some r -> r | None -> diff --git a/ocaml/libs/stunnel/stunnel_cache.mli b/ocaml/libs/stunnel/stunnel_cache.mli index 00f4ce9df62..9a2923dfcbf 100644 --- a/ocaml/libs/stunnel/stunnel_cache.mli +++ b/ocaml/libs/stunnel/stunnel_cache.mli @@ -28,7 +28,7 @@ val with_connect : -> (Stunnel.t -> 'b) -> 'b (** Connects via stunnel (optionally via an external 'fork/exec helper') to - a host and port. If there is a suitable stunnel in the cache then this + a host and port. If there is a suitable stunnel in the cache then this will be used, otherwise we make a fresh one. *) val add : Stunnel.t -> unit @@ -37,7 +37,6 @@ val add : Stunnel.t -> unit val with_remove : host:string (** host *) -> port:int (** port *) - -> Stunnel.verification_config option -> (Stunnel.t -> 'b) -> 'b option (** Given a host and port call a function with a cached stunnel, or return None. *) diff --git a/ocaml/libs/vhd/vhd_format/f.ml b/ocaml/libs/vhd/vhd_format/f.ml index a361a4fde3a..6109c8aa713 100644 --- a/ocaml/libs/vhd/vhd_format/f.ml +++ b/ocaml/libs/vhd/vhd_format/f.ml @@ -1607,8 +1607,6 @@ module Vhd = struct module Field = struct (** Dynamically-typed field-level access *) - type 'a f = {name: string; get: 'a t -> string} - let _features = "features" let _data_offset = "data-offset" @@ -1770,8 +1768,6 @@ module Vhd = struct opt (fun (t, _) -> Int32.to_string t.Batmap_header.checksum) t.batmap else None - - type 'a t = 'a f end end diff --git a/ocaml/libs/vhd/vhd_format_lwt/block.ml b/ocaml/libs/vhd/vhd_format_lwt/block.ml index 1ab35d33585..b4574e14e28 100644 --- a/ocaml/libs/vhd/vhd_format_lwt/block.ml +++ b/ocaml/libs/vhd/vhd_format_lwt/block.ml @@ -25,7 +25,7 @@ let pp_write_error = Mirage_block.pp_write_error type info = Mirage_block.info -type t = {mutable vhd: IO.fd Vhd_format.F.Vhd.t option; info: info; id: string} +type t = {mutable vhd: IO.fd Vhd_format.F.Vhd.t option; info: info} let connect path = Lwt_unix.LargeFile.stat path >>= fun _ -> @@ -38,8 +38,7 @@ let connect path = let sector_size = 512 in let size_sectors = Int64.div vhd.Vhd.footer.Footer.current_size 512L in let info = Mirage_block.{read_write; sector_size; size_sectors} in - let id = path in - return {vhd= Some vhd; info; id} + return {vhd= Some vhd; info} let disconnect t = match t.vhd with diff --git a/ocaml/libs/vhd/vhd_format_lwt/iO.ml b/ocaml/libs/vhd/vhd_format_lwt/iO.ml index 0940e6c56c3..d2768374795 100644 --- a/ocaml/libs/vhd/vhd_format_lwt/iO.ml +++ b/ocaml/libs/vhd/vhd_format_lwt/iO.ml @@ -46,13 +46,13 @@ let complete name offset op fd buffer = module Fd = struct open Lwt - type fd = {fd: Lwt_unix.file_descr; filename: string; lock: Lwt_mutex.t} + type fd = {fd: Lwt_unix.file_descr; lock: Lwt_mutex.t} let openfile filename rw = let unix_fd = File.openfile filename rw 0o644 in let fd = Lwt_unix.of_unix_file_descr unix_fd in let lock = Lwt_mutex.create () in - return {fd; filename; lock} + return {fd; lock} let fsync {fd; _} = let fd' = Lwt_unix.unix_file_descr fd in diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml index ef30cfb5ba4..b255239dd4d 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml @@ -49,15 +49,13 @@ module Delay = struct (* Concrete type is the ends of a pipe *) type t = { (* A pipe is used to wake up a thread blocked in wait: *) - mutable pipe_out: Unix.file_descr option - ; mutable pipe_in: Unix.file_descr option + mutable pipe_in: Unix.file_descr option ; (* Indicates that a signal arrived before a wait: *) mutable signalled: bool ; m: M.t } - let make () = - {pipe_out= None; pipe_in= None; signalled= false; m= M.create ()} + let make () = {pipe_in= None; signalled= false; m= M.create ()} exception Pre_signalled @@ -80,7 +78,6 @@ module Delay = struct let pipe_out, pipe_in = Unix.pipe () in (* these will be unconditionally closed on exit *) to_close := [pipe_out; pipe_in] ; - x.pipe_out <- Some pipe_out ; x.pipe_in <- Some pipe_in ; x.signalled <- false ; pipe_out @@ -99,7 +96,6 @@ module Delay = struct ) (fun () -> Mutex.execute x.m (fun () -> - x.pipe_out <- None ; x.pipe_in <- None ; List.iter close' !to_close ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml index ae2c92dc87b..5141e888fe8 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -303,7 +303,7 @@ let open_connection_unix_fd filename = module CBuf = struct (** A circular buffer constructed from a string *) type t = { - mutable buffer: bytes + buffer: bytes ; mutable len: int (** bytes of valid data in [buffer] *) ; mutable start: int (** index of first valid byte in [buffer] *) ; mutable r_closed: bool (** true if no more data can be read due to EOF *) diff --git a/ocaml/libs/xml-light2/xml.ml b/ocaml/libs/xml-light2/xml.ml index 9b58f2f6cf0..38c38f1ff84 100644 --- a/ocaml/libs/xml-light2/xml.ml +++ b/ocaml/libs/xml-light2/xml.ml @@ -22,7 +22,7 @@ type xml = | Element of (string * (string * string) list * xml list) | PCData of string -type error_pos = {eline: int; eline_start: int; emin: int; emax: int} +type error_pos = {eline: int} type error = string * error_pos @@ -69,8 +69,8 @@ let _parse i = let parse i = try _parse i - with Xmlm.Error ((line, col), msg) -> - let pos = {eline= line; eline_start= line; emin= col; emax= col} in + with Xmlm.Error ((line, _), msg) -> + let pos = {eline= line} in let err = Xmlm.error_message msg in raise (Error (err, pos)) diff --git a/ocaml/message-switch/switch/logging.ml b/ocaml/message-switch/switch/logging.ml index 37101ac88fe..5eab8d89fa2 100644 --- a/ocaml/message-switch/switch/logging.ml +++ b/ocaml/message-switch/switch/logging.ml @@ -20,7 +20,6 @@ type logger = { stream: string Lwt_stream.t ; push: string -> unit ; elements: int ref - ; max_elements: int ; dropped_elements: int ref } @@ -35,13 +34,7 @@ let create max_elements = stream_push (Some line) ; incr !elements ) in - { - stream - ; push - ; elements= !elements - ; max_elements - ; dropped_elements= !dropped_elements - } + {stream; push; elements= !elements; dropped_elements= !dropped_elements} let get (logger : logger) = let return_lines all = diff --git a/ocaml/rrd2csv/src/rrd2csv.ml b/ocaml/rrd2csv/src/rrd2csv.ml index 13fdef256c4..0448c4e067f 100644 --- a/ocaml/rrd2csv/src/rrd2csv.ml +++ b/ocaml/rrd2csv/src/rrd2csv.ml @@ -143,10 +143,9 @@ module Ds_selector = struct ; owner: Rrd.ds_owner option ; uuid: string ; metric: string - ; enabled: bool } - let empty = {cf= None; owner= None; uuid= ""; metric= ""; enabled= true} + let empty = {cf= None; owner= None; uuid= ""; metric= ""} let of_string str = let open Rrd in @@ -154,7 +153,6 @@ module Ds_selector = struct match splitted with | [cf; owner; uuid; metric] -> { - empty with cf= (try Some (cf_type_of_string cf) with _ -> None) ; owner= ( match owner with @@ -351,9 +349,7 @@ module Xport = struct (* Xport.t structure *) type meta = { - time_start: int64 - ; time_step: int64 - ; time_end: int64 + time_step: int64 ; entries: Ds_selector.t list (* XXX: remove when merging *) (* entries: Ds_selector.t list; *) @@ -411,9 +407,7 @@ module Xport = struct let process_meta (elts : xml_tree list) = let kvs = kvs elts in { - time_start= Int64.of_string (List.assoc "start" kvs) - ; time_step= Int64.of_string (List.assoc "step" kvs) - ; time_end= Int64.of_string (List.assoc "end" kvs) + time_step= Int64.of_string (List.assoc "step" kvs) ; entries= process_legend (find_elt "legend" elts) } in diff --git a/ocaml/xapi-idl/lib/scheduler.ml b/ocaml/xapi-idl/lib/scheduler.ml index d4d5c7c5cca..e46a0fdbd29 100644 --- a/ocaml/xapi-idl/lib/scheduler.ml +++ b/ocaml/xapi-idl/lib/scheduler.ml @@ -41,7 +41,7 @@ module HandleMap = Map.Make (struct c end) -type item = {id: int; name: string; fn: unit -> unit} +type item = {name: string; fn: unit -> unit} type t = { mutable schedule: item HandleMap.t @@ -88,7 +88,7 @@ let one_shot_f s dt (name : string) f = with_lock s.m (fun () -> let id = s.next_id in s.next_id <- s.next_id + 1 ; - let item = {id; name; fn= f} in + let item = {name; fn= f} in let handle = (time, id) in s.schedule <- HandleMap.add handle item s.schedule ; PipeDelay.signal s.delay ; diff --git a/ocaml/xapi-idl/lib/task_server.ml b/ocaml/xapi-idl/lib/task_server.ml index 32c29e0f976..0053015387d 100644 --- a/ocaml/xapi-idl/lib/task_server.ml +++ b/ocaml/xapi-idl/lib/task_server.ml @@ -101,14 +101,12 @@ functor task_map: task_handle SMap.t ref ; mutable test_cancel_trigger: (string * int) option ; m: Mutex.t - ; c: Condition.t } let empty () = let task_map = ref SMap.empty in let m = Mutex.create () in - let c = Condition.create () in - {task_map; test_cancel_trigger= None; m; c} + {task_map; test_cancel_trigger= None; m} (* [next_task_id ()] returns a fresh task id *) let next_task_id = diff --git a/ocaml/xapi/vgpuops.ml b/ocaml/xapi/vgpuops.ml index c55c46df226..284916182ce 100644 --- a/ocaml/xapi/vgpuops.ml +++ b/ocaml/xapi/vgpuops.ml @@ -20,8 +20,6 @@ open Xapi_stdext_std.Xstringext type vgpu_t = { vgpu_ref: API.ref_VGPU ; gpu_group_ref: API.ref_GPU_group - ; devid: int - ; other_config: (string * string) list ; type_ref: API.ref_VGPU_type ; requires_passthrough: [`PF | `VF] option } @@ -31,8 +29,6 @@ let vgpu_of_ref ~__context vgpu = { vgpu_ref= vgpu ; gpu_group_ref= vgpu_r.API.vGPU_GPU_group - ; devid= int_of_string vgpu_r.API.vGPU_device - ; other_config= vgpu_r.API.vGPU_other_config ; type_ref= vgpu_r.API.vGPU_type ; requires_passthrough= Xapi_vgpu.requires_passthrough ~__context ~self:vgpu } diff --git a/ocaml/xapi/xapi_dr_task.ml b/ocaml/xapi/xapi_dr_task.ml index 631c7ee4916..6766775a5f1 100644 --- a/ocaml/xapi/xapi_dr_task.ml +++ b/ocaml/xapi/xapi_dr_task.ml @@ -26,12 +26,7 @@ let make_task ~__context = ref (* A type to represent an SR record parsed from an sr_probe result. *) -type sr_probe_sr = { - uuid: string - ; name_label: string - ; name_description: string - ; metadata_detected: bool -} +type sr_probe_sr = {uuid: string; name_label: string; name_description: string} (* Attempt to parse a key/value pair from XML. *) let parse_kv = function @@ -53,8 +48,6 @@ let parse_sr_probe xml = uuid= List.assoc "UUID" all ; name_label= List.assoc "name_label" all ; name_description= List.assoc "name_description" all - ; metadata_detected= - List.assoc "pool_metadata_detected" all = "true" } | _ -> failwith "Malformed or missing " diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index b56e4199779..8c7432106ab 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -117,17 +117,12 @@ module Next = struct let highest_forgotten_id = ref (-1L) type subscription = { - mutable last_id: int64 - ; (* last event ID to sent to this client *) - mutable subs: Subscription.t list - ; (* list of all the subscriptions *) - m: Mutex.t - ; (* protects access to the mutable fields in this record *) - session: API.ref_session - ; (* session which owns this subscription *) - mutable session_invalid: bool - ; (* set to true if the associated session has been deleted *) - mutable timeout: float (* Timeout *) + mutable last_id: int64 (** last event ID to sent to this client *) + ; mutable subs: Subscription.t list (** all the subscriptions *) + ; m: Mutex.t (** protects access to the mutable fields in this record *) + ; session: API.ref_session (** session which owns this subscription *) + ; mutable session_invalid: bool + (** set to true if the associated session has been deleted *) } (* For Event.next, the single subscription associated with a session *) @@ -235,7 +230,6 @@ module Next = struct ; m= Mutex.create () ; session ; session_invalid= false - ; timeout= 0.0 } in Hashtbl.replace subscriptions session subscription ; diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml index f3f56003dad..9662af66611 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml @@ -457,8 +457,8 @@ let query_host_ds (ds_name : string) : float = ) (** Dump all latest data of host dss to file in json format so that any client - can read even if it's non-privileged user, such as NRPE. - Especially, nan, infinity and neg_infinity will be converted to strings + can read even if it's non-privileged user, such as NRPE. + Especially, nan, infinity and neg_infinity will be converted to strings "NaN", "infinity" and "-infinity", the client needs to handle by itself. *) let convert_value x = @@ -651,8 +651,7 @@ module Plugin = struct - Can the code for backwards compatibility be expunged? *) type plugin = { - info: P.info - ; reader: Rrd_reader.reader + reader: Rrd_reader.reader ; mutable skip_init: int (** initial value for skip after read err *) ; mutable skip: int (** number of cycles to skip b/f next read *) } @@ -748,7 +747,7 @@ module Plugin = struct let reader = P.make_reader ~uid ~info ~protocol:(choose_protocol protocol) in - Hashtbl.add registered uid {info; reader; skip_init= 1; skip= 0} + Hashtbl.add registered uid {reader; skip_init= 1; skip= 0} ) ; next_reading uid diff --git a/ocaml/xen-api-client/lib_test/xen_api_test.ml b/ocaml/xen-api-client/lib_test/xen_api_test.ml index b8729de197c..14208242465 100644 --- a/ocaml/xen-api-client/lib_test/xen_api_test.ml +++ b/ocaml/xen-api-client/lib_test/xen_api_test.ml @@ -46,13 +46,13 @@ module Fake_IO = struct let flush _oc = return () - type connection = {address: Uri.t; ic: ic; oc: ic} + type connection = {ic: ic; oc: ic} let connections = ref [] - let open_connection address = + let open_connection _ = let ic = Queue.create () and oc = Queue.create () in - let c = {address; ic; oc} in + let c = {ic; oc} in connections := c :: !connections ; return (Ok (ic, oc)) @@ -111,7 +111,7 @@ let test_login_success () = let module Fake_IO = struct include Fake_IO - let open_connection address = + let open_connection _ = let ic = Queue.create () and oc = Queue.create () in Queue.push "HTTP/1.1 200 OK\r\n" ic ; Queue.push @@ -119,7 +119,7 @@ let test_login_success () = ic ; Queue.push "\r\n" ic ; Queue.push result ic ; - let c = {address; ic; oc} in + let c = {ic; oc} in connections := c :: !connections ; return (Ok (ic, oc)) end in diff --git a/ocaml/xsh/xsh.ml b/ocaml/xsh/xsh.ml index 982ff6c346f..51de04f257a 100644 --- a/ocaml/xsh/xsh.ml +++ b/ocaml/xsh/xsh.ml @@ -19,7 +19,7 @@ open D type endpoint = { fdin: Unix.file_descr ; fdout: Unix.file_descr - ; mutable buffer: bytes + ; buffer: bytes ; mutable buffer_len: int } From 9fd09c87f908441039e1f25ccef5461fe3670758 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 24 Jul 2024 17:42:48 +0100 Subject: [PATCH 052/157] datamodel_lifecycle: automated bump Signed-off-by: Pau Ruiz Safont --- ocaml/idl/datamodel_lifecycle.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index 089986a5625..bfb6ce0cf2c 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -28,9 +28,9 @@ let prototyped_of_field = function | "Repository", "gpgkey_path" -> Some "22.12.0" | "Certificate", "fingerprint_sha1" -> - Some "24.19.1-next" + Some "24.20.0" | "Certificate", "fingerprint_sha256" -> - Some "24.19.1-next" + Some "24.20.0" | "Cluster_host", "last_update_live" -> Some "24.3.0" | "Cluster_host", "live" -> From cd16298c3b2cc1ffbd9b6265f2ba9783c8a96732 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 25 Jul 2024 10:10:39 +0100 Subject: [PATCH 053/157] maintenance: restore dune utop Signed-off-by: Pau Ruiz Safont --- ocaml/sdk-gen/go/dune | 1 + ocaml/xapi/dune | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/ocaml/sdk-gen/go/dune b/ocaml/sdk-gen/go/dune index 7303bc0c438..6d99103516a 100644 --- a/ocaml/sdk-gen/go/dune +++ b/ocaml/sdk-gen/go/dune @@ -14,6 +14,7 @@ (library (name gen_go_helper) (modules gen_go_helper) + (modes best) (libraries CommonFunctions astring diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 1dd7d06911a..564022ec6bb 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -57,6 +57,7 @@ (library (name xapi_internal_minimal) (modules context custom_actions xapi_globs server_helpers session_check rbac rbac_audit db_actions taskHelper eventgen locking_helpers exnHelper rbac_static xapi_role xapi_extensions db) + (modes best) (wrapped false) (libraries http_lib @@ -65,7 +66,7 @@ xapi-types xapi_database mtime - tracing + tracing uuid rpclib.core threads.posix From e2c0ac646aac0507579ad141ec2bb6c09b21a59c Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 5 Jul 2024 14:36:42 +0100 Subject: [PATCH 054/157] xapi: update mirage-crypto version Also make dune generate the opam metadata Signed-off-by: Pau Ruiz Safont --- dune-project | 62 ++++++++++++++++++++++ ocaml/gencert/dune | 2 + ocaml/gencert/lib.ml | 2 +- ocaml/gencert/selfcert.ml | 2 +- ocaml/gencert/test_lib.ml | 2 +- ocaml/xapi/certificates.ml | 2 +- ocaml/xapi/dune | 1 + xapi.opam | 102 ++++++++++++++++++++----------------- xapi.opam.template | 79 ---------------------------- 9 files changed, 123 insertions(+), 131 deletions(-) diff --git a/dune-project b/dune-project index 3c6620b2c6c..780c227a986 100644 --- a/dune-project +++ b/dune-project @@ -301,6 +301,68 @@ (package (name xapi) + (synopsis "The toolstack daemon which implements the XenAPI") + (description "This daemon exposes the XenAPI and is used by clients such as 'xe' and 'XenCenter' to manage clusters of Xen-enabled hosts.") + (depends + alcotest ; needed for the quicktest binary + angstrom + base-threads + base64 + cdrom + conf-pam + (crowbar :with-test) + ctypes + ctypes-foreign + domain-name + (ezxenstore (= :version)) + (fmt :with-test) + hex + (http-lib (and :with-test (= :version))) ; the public library is only used for testing + ipaddr + mirage-crypto + mirage-crypto-pk + (mirage-crypto-rng (>= "0.11.0")) + (message-switch-unix (= :version)) + mtime + opentelemetry-client-ocurl + pci + (pciutil (= :version)) + ppx_deriving_rpc + ppx_sexp_conv + ppx_deriving + psq + rpclib + (rrdd-plugin (= :version)) + rresult + sexpr + sha + (stunnel (= :version)) + tar + tar-unix + (uuid (= :version)) + x509 + (xapi-client (= :version)) + (xapi-cli-protocol (= :version)) + (xapi-consts (= :version)) + (xapi-datamodel (= :version)) + (xapi-expiry-alerts (= :version)) + (xapi-idl (= :version)) + (xapi-inventory (= :version)) + (xapi-log (= :version)) + (xapi-stdext-date (= :version)) + (xapi-stdext-pervasives (= :version)) + (xapi-stdext-std (= :version)) + (xapi-stdext-threads (= :version)) + (xapi-stdext-unix (= :version)) + (xapi-stdext-zerocheck (= :version)) + (xapi-test-utils :with-test) + (xapi-tracing (= :version)) + (xapi-types (= :version)) + (xapi-xenopsd (= :version)) + (xml-light2 (= :version)) + yojson + (zstd (= :version)) + ) ) (package diff --git a/ocaml/gencert/dune b/ocaml/gencert/dune index f83ed49eb51..ef7875abd29 100644 --- a/ocaml/gencert/dune +++ b/ocaml/gencert/dune @@ -10,6 +10,7 @@ forkexec mirage-crypto mirage-crypto-pk + mirage-crypto-rng mirage-crypto-rng.unix ptime ptime.clock.os @@ -52,6 +53,7 @@ gencertlib mirage-crypto mirage-crypto-pk + mirage-crypto-rng mirage-crypto-rng.unix ptime result diff --git a/ocaml/gencert/lib.ml b/ocaml/gencert/lib.ml index 7eb41411102..d4903924276 100644 --- a/ocaml/gencert/lib.ml +++ b/ocaml/gencert/lib.ml @@ -19,7 +19,7 @@ open Rresult type t_certificate = Leaf | Chain -let () = Mirage_crypto_rng_unix.initialize () +let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) let validate_private_key pkcs8_private_key = let ensure_rsa_key_length = function diff --git a/ocaml/gencert/selfcert.ml b/ocaml/gencert/selfcert.ml index 02749493f95..7b961a74ff6 100644 --- a/ocaml/gencert/selfcert.ml +++ b/ocaml/gencert/selfcert.ml @@ -43,7 +43,7 @@ let valid_from' date = (** initialize the random number generator at program startup when this module is loaded. *) -let () = Mirage_crypto_rng_unix.initialize () +let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) (** [write_cert] writes a PKCS12 file to [path]. The typical file extension would be ".pem". It attempts to do that atomically by diff --git a/ocaml/gencert/test_lib.ml b/ocaml/gencert/test_lib.ml index fddee2ad41c..f3a54517ad4 100644 --- a/ocaml/gencert/test_lib.ml +++ b/ocaml/gencert/test_lib.ml @@ -8,7 +8,7 @@ open Rresult.R.Infix let ( let* ) = Rresult.R.bind (* Initialize RNG for testing certificates *) -let () = Mirage_crypto_rng_unix.initialize () +let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) let time_of_rfc3339 date = match Ptime.of_rfc3339 date with diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index effb154877e..23e8999edc0 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -19,7 +19,7 @@ module D = Debug.Make (struct let name = "certificates" end) open D -let () = Mirage_crypto_rng_unix.initialize () +let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) (* Certificate locations: * a) stunnel external = /etc/xensource/xapi-ssl.pem diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 1dd7d06911a..8494f761817 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -121,6 +121,7 @@ message-switch-core message-switch-unix mirage-crypto + mirage-crypto-rng mirage-crypto-rng.unix mtime mtime.clock.os diff --git a/xapi.opam b/xapi.opam index 387ba542fe6..6f67cf1c1f3 100644 --- a/xapi.opam +++ b/xapi.opam @@ -1,20 +1,18 @@ # This file is generated by dune, edit dune-project instead -license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" +synopsis: "The toolstack daemon which implements the XenAPI" +description: + "This daemon exposes the XenAPI and is used by clients such as 'xe' and 'XenCenter' to manage clusters of Xen-enabled hosts." +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -build: [ - ["dune" "build" "-p" name "-j" jobs ] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] depends: [ - "ocaml" - "dune" - "alcotest" # needed to generate the quicktest binary + "dune" {>= "3.15"} + "alcotest" "angstrom" + "base-threads" "base64" "cdrom" "conf-pam" @@ -22,56 +20,71 @@ depends: [ "ctypes" "ctypes-foreign" "domain-name" - "ezxenstore" + "ezxenstore" {= version} "fmt" {with-test} "hex" - "http-lib" {with-test} # the public library is only used for testing + "http-lib" {with-test & = version} "ipaddr" - "mirage-crypto" {with-test} + "mirage-crypto" "mirage-crypto-pk" - "mirage-crypto-rng" {with-test} - "message-switch-unix" + "mirage-crypto-rng" {>= "0.11.0"} + "message-switch-unix" {= version} "mtime" "opentelemetry-client-ocurl" "pci" - "pciutil" + "pciutil" {= version} "ppx_deriving_rpc" "ppx_sexp_conv" "ppx_deriving" "psq" "rpclib" - "rrdd-plugin" + "rrdd-plugin" {= version} "rresult" "sexpr" "sha" - "stunnel" + "stunnel" {= version} "tar" "tar-unix" - "base-threads" - "base-unix" - "uuid" + "uuid" {= version} "x509" - "xapi-client" - "xapi-cli-protocol" - "xapi-consts" - "xapi-datamodel" - "xapi-expiry-alerts" - "xapi-stdext-date" - "xapi-stdext-pervasives" - "xapi-stdext-std" - "xapi-stdext-threads" - "xapi-stdext-unix" - "xapi-stdext-zerocheck" + "xapi-client" {= version} + "xapi-cli-protocol" {= version} + "xapi-consts" {= version} + "xapi-datamodel" {= version} + "xapi-expiry-alerts" {= version} + "xapi-idl" {= version} + "xapi-inventory" {= version} + "xapi-log" {= version} + "xapi-stdext-date" {= version} + "xapi-stdext-pervasives" {= version} + "xapi-stdext-std" {= version} + "xapi-stdext-threads" {= version} + "xapi-stdext-unix" {= version} + "xapi-stdext-zerocheck" {= version} "xapi-test-utils" {with-test} - "xapi-tracing" - "xapi-types" - "xapi-xenopsd" - "xapi-idl" - "xapi-inventory" - "xml-light2" + "xapi-tracing" {= version} + "xapi-types" {= version} + "xapi-xenopsd" {= version} + "xml-light2" {= version} "yojson" - "zstd" + "zstd" {= version} + "odoc" {with-doc} ] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" depexts: [ ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "debian"} ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "ubuntu"} @@ -79,10 +92,3 @@ depexts: [ ["hwdata" "xxhash-devel" "xxhash-libs"] {os-distribution = "fedora"} ["hwdata" "xxhash-dev" "xxhash"] {os-distribution = "alpine"} ] -synopsis: "The xapi toolstack daemon which implements the XenAPI" -description: """ -This daemon exposes the XenAPI and is used by clients such as 'xe' -and 'XenCenter' to manage clusters of Xen-enabled hosts.""" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} diff --git a/xapi.opam.template b/xapi.opam.template index 49f3902f66a..3dea8527e92 100644 --- a/xapi.opam.template +++ b/xapi.opam.template @@ -1,75 +1,3 @@ -opam-version: "2.0" -maintainer: "xen-api@lists.xen.org" -authors: [ "xen-api@lists.xen.org" ] -homepage: "https://github.com/xapi-project/xen-api" -bug-reports: "https://github.com/xapi-project/xen-api/issues" -dev-repo: "git+https://github.com/xapi-project/xen-api.git" -build: [ - ["dune" "build" "-p" name "-j" jobs ] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -depends: [ - "ocaml" - "dune" - "alcotest" # needed to generate the quicktest binary - "angstrom" - "base64" - "cdrom" - "conf-pam" - "crowbar" {with-test} - "ctypes" - "ctypes-foreign" - "domain-name" - "ezxenstore" - "fmt" {with-test} - "hex" - "http-lib" {with-test} # the public library is only used for testing - "ipaddr" - "mirage-crypto" {with-test} - "mirage-crypto-pk" - "mirage-crypto-rng" {with-test} - "message-switch-unix" - "mtime" - "opentelemetry-client-ocurl" - "pci" - "pciutil" - "ppx_deriving_rpc" - "ppx_sexp_conv" - "ppx_deriving" - "psq" - "rpclib" - "rrdd-plugin" - "rresult" - "sexpr" - "sha" - "stunnel" - "tar" - "tar-unix" - "base-threads" - "base-unix" - "uuid" - "x509" - "xapi-client" - "xapi-cli-protocol" - "xapi-consts" - "xapi-datamodel" - "xapi-expiry-alerts" - "xapi-stdext-date" - "xapi-stdext-pervasives" - "xapi-stdext-std" - "xapi-stdext-threads" - "xapi-stdext-unix" - "xapi-stdext-zerocheck" - "xapi-test-utils" {with-test} - "xapi-tracing" - "xapi-types" - "xapi-xenopsd" - "xapi-idl" - "xapi-inventory" - "xml-light2" - "yojson" - "zstd" -] depexts: [ ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "debian"} ["hwdata" "libxxhash-dev" "libxxhash0"] {os-distribution = "ubuntu"} @@ -77,10 +5,3 @@ depexts: [ ["hwdata" "xxhash-devel" "xxhash-libs"] {os-distribution = "fedora"} ["hwdata" "xxhash-dev" "xxhash"] {os-distribution = "alpine"} ] -synopsis: "The xapi toolstack daemon which implements the XenAPI" -description: """ -This daemon exposes the XenAPI and is used by clients such as 'xe' -and 'XenCenter' to manage clusters of Xen-enabled hosts.""" -url { - src: "https://github.com/xapi-project/xen-api/archive/master.tar.gz" -} From 34ee1ef5f5fb6296db84aafb217763fde40441d7 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 23 Jul 2024 15:52:43 +0100 Subject: [PATCH 055/157] mirage-rng: Initialize it only in tests and selfcert Only tests need it to generate crypto keys, but it's needed to create the serial when signing certificates. Signed-off-by: Pau Ruiz Safont --- dune-project | 2 -- ocaml/gencert/lib.ml | 2 -- ocaml/gencert/selfcert.ml | 6 +++--- ocaml/xapi/certificates.ml | 2 -- ocaml/xapi/dune | 2 -- 5 files changed, 3 insertions(+), 11 deletions(-) diff --git a/dune-project b/dune-project index 780c227a986..0e47e350ba1 100644 --- a/dune-project +++ b/dune-project @@ -67,7 +67,6 @@ (synopsis "Xen-API client library for remotely-controlling a xapi host") (authors "David Scott" "Anil Madhavapeddy" "Jerome Maloberti" "John Else" "Jon Ludlam" "Thomas Sanders" "Mike McClurg") (depends - (alcotest :with-test) astring (cohttp (>= "0.22.0")) @@ -188,7 +187,6 @@ (description "This daemon monitors 'datasources' i.e. time-varying values such as performance counters and records the samples in RRD archives. These archives can be used to examine historical performance trends.") (depends (ocaml (>= "4.02.0")) - (alcotest :with-test) astring (gzip (= :version)) diff --git a/ocaml/gencert/lib.ml b/ocaml/gencert/lib.ml index d4903924276..970954a5371 100644 --- a/ocaml/gencert/lib.ml +++ b/ocaml/gencert/lib.ml @@ -19,8 +19,6 @@ open Rresult type t_certificate = Leaf | Chain -let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) - let validate_private_key pkcs8_private_key = let ensure_rsa_key_length = function | `RSA priv -> diff --git a/ocaml/gencert/selfcert.ml b/ocaml/gencert/selfcert.ml index 7b961a74ff6..3b022bcb19f 100644 --- a/ocaml/gencert/selfcert.ml +++ b/ocaml/gencert/selfcert.ml @@ -41,8 +41,8 @@ let valid_from' date = | None, false -> Ptime_clock.now () -(** initialize the random number generator at program startup when this -module is loaded. *) +(* Needed to initialize the rng to create random serial codes when signing + certificates *) let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) (** [write_cert] writes a PKCS12 file to [path]. The typical file @@ -158,7 +158,7 @@ let host ~name ~dns_names ~ips ?valid_from ~valid_for_days pemfile cert_gid = in R.failwith_error_msg res -let serial_stamp () = Unix.gettimeofday () |> string_of_float +let serial_stamp () = Ptime_clock.now () |> Ptime.to_float_s |> string_of_float let xapi_pool ?valid_from ~valid_for_days ~uuid pemfile cert_gid = let valid_from = valid_from' valid_from in diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 23e8999edc0..fe66194cb0e 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -19,8 +19,6 @@ module D = Debug.Make (struct let name = "certificates" end) open D -let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) - (* Certificate locations: * a) stunnel external = /etc/xensource/xapi-ssl.pem * b) stunnel SNI (internal) = /etc/xensource/xapi-pool-tls.pem diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 8494f761817..371718d3ed8 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -121,8 +121,6 @@ message-switch-core message-switch-unix mirage-crypto - mirage-crypto-rng - mirage-crypto-rng.unix mtime mtime.clock.os pam From f4b9bcf6bbaef8d591e2a4f9cda422f3fa86aab8 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 26 Jul 2024 09:16:34 +0100 Subject: [PATCH 056/157] clock: use external qcheck-alcotest Signed-off-by: Pau Ruiz Safont --- clock.opam | 2 + dune-project | 2 + ocaml/libs/clock/dune | 12 +++++- ocaml/libs/clock/test_timer.ml | 76 ---------------------------------- quality-gate.sh | 2 +- 5 files changed, 16 insertions(+), 78 deletions(-) diff --git a/clock.opam b/clock.opam index 52cc8d0ef09..45b4fd162c2 100644 --- a/clock.opam +++ b/clock.opam @@ -13,6 +13,8 @@ depends: [ "astring" "mtime" "ptime" + "qcheck-core" {with-test} + "qcheck-alcotest" {with-test} "odoc" {with-doc} ] build: [ diff --git a/dune-project b/dune-project index 0e47e350ba1..20a8079ca44 100644 --- a/dune-project +++ b/dune-project @@ -29,6 +29,8 @@ astring mtime ptime + (qcheck-core :with-test) + (qcheck-alcotest :with-test) ) ) diff --git a/ocaml/libs/clock/dune b/ocaml/libs/clock/dune index 3c2ab5c67d6..ebc174c9f2e 100644 --- a/ocaml/libs/clock/dune +++ b/ocaml/libs/clock/dune @@ -15,5 +15,15 @@ (names test_date test_timer) (package clock) (modules test_date test_timer) - (libraries alcotest clock fmt mtime mtime.clock.os ptime qcheck-core qcheck-core.runner) + (libraries + alcotest + clock + fmt + mtime + mtime.clock.os + ptime + qcheck-alcotest + qcheck-core + qcheck-core.runner + ) ) diff --git a/ocaml/libs/clock/test_timer.ml b/ocaml/libs/clock/test_timer.ml index 2d5e20d7d8a..fca152ee96d 100644 --- a/ocaml/libs/clock/test_timer.ml +++ b/ocaml/libs/clock/test_timer.ml @@ -2,82 +2,6 @@ module Timer = Clock.Timer module Gen = QCheck2.Gen module Test = QCheck2.Test -module QCheck_alcotest = struct - (* SPDX: BSD-2-Clause - From github.com/c-cube/qcheck - *) - - module Q = QCheck2 - module T = QCheck2.Test - module Raw = QCheck_base_runner.Raw - - let seed_ = - lazy - (let s = - try int_of_string @@ Sys.getenv "QCHECK_SEED" - with _ -> Random.self_init () ; Random.int 1_000_000_000 - in - Printf.printf "qcheck random seed: %d\n%!" s ; - s - ) - - let default_rand () = - (* random seed, for repeatability of tests *) - Random.State.make [|Lazy.force seed_|] - - let verbose_ = - lazy - ( match Sys.getenv "QCHECK_VERBOSE" with - | "1" | "true" -> - true - | _ -> - false - | exception Not_found -> - false - ) - - let long_ = - lazy - ( match Sys.getenv "QCHECK_LONG" with - | "1" | "true" -> - true - | _ -> - false - | exception Not_found -> - false - ) - - let to_alcotest ?(colors = false) ?(verbose = Lazy.force verbose_) - ?(long = Lazy.force long_) ?(debug_shrink = None) ?debug_shrink_list - ?(rand = default_rand ()) (t : T.t) = - let (T.Test cell) = t in - let handler name cell r = - match (r, debug_shrink) with - | QCheck2.Test.Shrunk (step, x), Some out -> - let go = - match debug_shrink_list with - | None -> - true - | Some test_list -> - List.mem name test_list - in - if not go then - () - else - QCheck_base_runner.debug_shrinking_choices ~colors ~out ~name cell - ~step x - | _ -> - () - in - let print = Raw.print_std in - let name = T.get_name cell in - let run () = - let call = Raw.callback ~colors ~verbose ~print_res:true ~print in - T.check_cell_exn ~long ~call ~handler ~rand cell - in - ((name, `Slow, run) : unit Alcotest.test_case) -end - let spans = Gen.oneofa ([|1; 100; 300|] |> Array.map (fun v -> Mtime.Span.(v * ms))) diff --git a/quality-gate.sh b/quality-gate.sh index f9c644467f5..8f761718627 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -95,7 +95,7 @@ ocamlyacc () { unixgetenv () { - N=1 + N=0 UNIXGETENV=$(git grep -P -r -o --count 'getenv(?!_opt)' -- **/*.ml | wc -l) if [ "$UNIXGETENV" -eq "$N" ]; then echo "OK found $UNIXGETENV usages of exception-raising Unix.getenv in OCaml files." From eb58c7dabac9ca61ade57a508555184dd37e9ed7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 25 Jul 2024 18:22:22 +0100 Subject: [PATCH 057/157] CP-50448: move quickcheck tests into internal libraries MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We want to run these from 'quicktest', so make them available as libraries, and add a _run.ml that would run them separately, just as before. (running separately in the CI is better, because it can be parallelize) No functional change. Signed-off-by: Edwin Török --- ocaml/libs/clock/dune | 16 ++++++++++------ ocaml/libs/clock/test_timer.ml | 4 +--- ocaml/libs/clock/test_timer.mli | 3 +++ ocaml/libs/clock/test_timer_run.ml | 4 ++++ ocaml/libs/clock/test_timer_run.mli | 0 ocaml/libs/http-lib/bufio_test.ml | 4 +++- ocaml/libs/http-lib/bufio_test.mli | 1 + ocaml/libs/http-lib/bufio_test_run.ml | 1 + ocaml/libs/http-lib/bufio_test_run.mli | 0 ocaml/libs/http-lib/dune | 19 ++++++++++++++----- .../lib/xapi-stdext-unix/test/dune | 12 +++++++++--- .../lib/xapi-stdext-unix/test/unixext_test.ml | 3 +-- .../xapi-stdext-unix/test/unixext_test.mli | 1 + .../xapi-stdext-unix/test/unixext_test_run.ml | 1 + .../test/unixext_test_run.mli | 0 15 files changed, 49 insertions(+), 20 deletions(-) create mode 100644 ocaml/libs/clock/test_timer_run.ml create mode 100644 ocaml/libs/clock/test_timer_run.mli create mode 100644 ocaml/libs/http-lib/bufio_test_run.ml create mode 100644 ocaml/libs/http-lib/bufio_test_run.mli create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.ml create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.mli diff --git a/ocaml/libs/clock/dune b/ocaml/libs/clock/dune index ebc174c9f2e..67fbef3208f 100644 --- a/ocaml/libs/clock/dune +++ b/ocaml/libs/clock/dune @@ -11,19 +11,23 @@ ) ) -(tests - (names test_date test_timer) +(library + (name test_timer) (package clock) - (modules test_date test_timer) + (modules test_timer) (libraries alcotest clock fmt - mtime mtime.clock.os - ptime qcheck-alcotest qcheck-core - qcheck-core.runner ) ) + +(tests + (names test_date test_timer_run) + (package clock) + (modules test_date test_timer_run) + (libraries alcotest clock fmt mtime mtime.clock.os ptime qcheck-core qcheck-alcotest test_timer) +) diff --git a/ocaml/libs/clock/test_timer.ml b/ocaml/libs/clock/test_timer.ml index fca152ee96d..3729826cfa3 100644 --- a/ocaml/libs/clock/test_timer.ml +++ b/ocaml/libs/clock/test_timer.ml @@ -60,8 +60,6 @@ let test_timer_remaining = Mtime.Span.pp duration Timer.pp timer ; true -let tests_timer = List.map QCheck_alcotest.to_alcotest [test_timer_remaining] - let combinations = let pair x y = (x, y) in let rec loop acc = function @@ -154,4 +152,4 @@ let test_conversion_from_s = let tests_span = List.concat [test_conversion_to_s; test_conversion_from_s; test_span_compare] -let () = Alcotest.run "Timer" [("Timer", tests_timer); ("Span", tests_span)] +let tests = [test_timer_remaining] diff --git a/ocaml/libs/clock/test_timer.mli b/ocaml/libs/clock/test_timer.mli index e69de29bb2d..510dfaf2bdc 100644 --- a/ocaml/libs/clock/test_timer.mli +++ b/ocaml/libs/clock/test_timer.mli @@ -0,0 +1,3 @@ +val tests_span : unit Alcotest.V1.test_case list + +val tests : QCheck2.Test.t list diff --git a/ocaml/libs/clock/test_timer_run.ml b/ocaml/libs/clock/test_timer_run.ml new file mode 100644 index 00000000000..0bf62436fe6 --- /dev/null +++ b/ocaml/libs/clock/test_timer_run.ml @@ -0,0 +1,4 @@ +let tests_timer = List.map QCheck_alcotest.to_alcotest Test_timer.tests + +let () = + Alcotest.run "Timer" [("Timer", tests_timer); ("Span", Test_timer.tests_span)] diff --git a/ocaml/libs/clock/test_timer_run.mli b/ocaml/libs/clock/test_timer_run.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/http-lib/bufio_test.ml b/ocaml/libs/http-lib/bufio_test.ml index 7937adc73ea..81aac2ad879 100644 --- a/ocaml/libs/http-lib/bufio_test.ml +++ b/ocaml/libs/http-lib/bufio_test.ml @@ -98,7 +98,9 @@ let test_buf_io = in true +let tests = [test_buf_io] + let () = (* avoid SIGPIPE *) let (_ : Sys.signal_behavior) = Sys.signal Sys.sigpipe Sys.Signal_ignore in - QCheck_base_runner.run_tests_main [test_buf_io] + () diff --git a/ocaml/libs/http-lib/bufio_test.mli b/ocaml/libs/http-lib/bufio_test.mli index e69de29bb2d..a10acd45016 100644 --- a/ocaml/libs/http-lib/bufio_test.mli +++ b/ocaml/libs/http-lib/bufio_test.mli @@ -0,0 +1 @@ +val tests : QCheck2.Test.t list diff --git a/ocaml/libs/http-lib/bufio_test_run.ml b/ocaml/libs/http-lib/bufio_test_run.ml new file mode 100644 index 00000000000..a7a1cacab7e --- /dev/null +++ b/ocaml/libs/http-lib/bufio_test_run.ml @@ -0,0 +1 @@ +let () = QCheck_base_runner.run_tests_main Bufio_test.tests diff --git a/ocaml/libs/http-lib/bufio_test_run.mli b/ocaml/libs/http-lib/bufio_test_run.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index 1deae570337..5cc1f8292e0 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -3,7 +3,7 @@ (public_name http-lib) (modes best) (wrapped false) - (modules (:standard \ http_svr http_proxy server_io http_test radix_tree_test test_client test_server bufio_test)) + (modules (:standard \ http_svr http_proxy server_io http_test radix_tree_test test_client test_server bufio_test bufio_test_run)) (preprocess (per_module ((pps ppx_deriving_rpc) Http))) (libraries astring @@ -67,9 +67,21 @@ ) (test - (name bufio_test) + (name bufio_test_run) (package http-lib) (modes (best exe)) + (modules bufio_test_run) + (libraries + qcheck-core.runner + bufio_test + ) + ; use fixed seed to avoid causing random failures in CI and package builds + (action (run %{test} -v -bt --seed 42)) +) + +(library + (name bufio_test) + (modes best) (modules bufio_test) (libraries fmt @@ -79,11 +91,8 @@ rresult http_lib qcheck-core - qcheck-core.runner xapi_fd_test ) - ; use fixed seed to avoid causing random failures in CI and package builds - (action (run %{test} -v -bt --seed 42)) ) (rule diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune index 407d025a8a8..350db0ee85c 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune @@ -1,8 +1,14 @@ -(test +(library (name unixext_test) - (package xapi-stdext-unix) (modules unixext_test) - (libraries xapi_stdext_unix qcheck-core mtime.clock.os qcheck-core.runner fmt xapi_fd_test mtime threads.posix rresult) + (libraries xapi_stdext_unix qcheck-core mtime.clock.os fmt xapi_fd_test mtime threads.posix rresult) +) + +(test + (name unixext_test_run) + (package xapi-stdext-unix) + (modules unixext_test_run) + (libraries unixext_test qcheck-core.runner) ; use fixed seed to avoid causing random failures in CI and package builds (action (run %{test} -v -bt --seed 42)) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml index e0f2726f303..656dcc1fe56 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml @@ -192,5 +192,4 @@ let tests = [test_proxy; test_time_limited_write; test_time_limited_read] let () = (* avoid SIGPIPE *) let (_ : Sys.signal_behavior) = Sys.signal Sys.sigpipe Sys.Signal_ignore in - Xapi_stdext_unix.Unixext.test_open 1024 ; - QCheck_base_runner.run_tests_main tests + Xapi_stdext_unix.Unixext.test_open 1024 diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli index e69de29bb2d..a10acd45016 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli @@ -0,0 +1 @@ +val tests : QCheck2.Test.t list diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.ml new file mode 100644 index 00000000000..74c7a62241b --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.ml @@ -0,0 +1 @@ +let () = QCheck_base_runner.run_tests_main Unixext_test.tests diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test_run.mli new file mode 100644 index 00000000000..e69de29bb2d From efcb7af9d9d2abd38281f5ae542857965c24c87b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 25 Jul 2024 18:23:24 +0100 Subject: [PATCH 058/157] CP-50448: run the QuickCheck tests in QuickTest MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Quicktest runs in Dom0, and the existing quickcheck tests run in the CI. Some of these test as much the OCaml code, as its interaction with the system (e.g. behaviour of system calls). So it is better to run these tests both in the CI and in Dom0. We run these in long mode, to explore more randomly generated scenarios. The seed can be controlled with QCHECK_SEED environment variable. Similar to @stresstest it uses a random seed, instead of a fixed seed. Signed-off-by: Edwin Török --- ocaml/quicktest/dune | 4 +++- ocaml/quicktest/quicktest.ml | 10 ++++++++++ ocaml/quicktest/quicktest_args.ml | 3 +++ 3 files changed, 16 insertions(+), 1 deletion(-) diff --git a/ocaml/quicktest/dune b/ocaml/quicktest/dune index 31219a94d94..c4044a7ebb7 100644 --- a/ocaml/quicktest/dune +++ b/ocaml/quicktest/dune @@ -6,7 +6,6 @@ (libraries alcotest astring - ezxenstore ezxenstore.watch fmt @@ -14,11 +13,14 @@ http_lib mtime mtime.clock.os + qcheck-alcotest result rresult rpclib.core rrdd_libs stunnel + bufio_test + test_timer threads.posix unix uuid diff --git a/ocaml/quicktest/quicktest.ml b/ocaml/quicktest/quicktest.ml index e09f4a92fbb..09c7f89c7c9 100644 --- a/ocaml/quicktest/quicktest.ml +++ b/ocaml/quicktest/quicktest.ml @@ -14,6 +14,11 @@ (** The main entry point of the quicktest executable *) +let qchecks = + [("bufio", Bufio_test.tests); ("Timer", Test_timer.tests)] + |> List.map @@ fun (name, test) -> + (name, List.map QCheck_alcotest.(to_alcotest ~long:true) test) + let () = Quicktest_args.parse () ; Qt_filter.wrap (fun () -> @@ -43,6 +48,11 @@ let () = [("http", Quicktest_http.tests)] else [] + @ + if not !Quicktest_args.skip_stress then + qchecks + else + [] in (* Only list tests if asked, without running them *) if !Quicktest_args.list_tests then diff --git a/ocaml/quicktest/quicktest_args.ml b/ocaml/quicktest/quicktest_args.ml index d9659ba9105..cc05b27b667 100644 --- a/ocaml/quicktest/quicktest_args.ml +++ b/ocaml/quicktest/quicktest_args.ml @@ -45,6 +45,8 @@ let set_alcotest_args l = alcotest_args := Array.of_list l let skip_xapi = ref false +let skip_stress = ref false + (** Parse the legacy quicktest command line args. This is used instead of invoking Alcotest directly, for backwards-compatibility with clients who run the quicktest binary. *) @@ -67,6 +69,7 @@ let parse () = -default-sr" ) ; ("-skip-xapi", Arg.Set skip_xapi, "SKIP tests that require XAPI") + ; ("-skip-stress", Arg.Set skip_stress, "SKIP randomized stress tests") ; ("--", Arg.Rest_all set_alcotest_args, "Supply alcotest arguments") ; ( "-run-only" , Arg.String (fun x -> run_only := Some x) From 0623d8d19364a8762133efaa2a70c504d979445e Mon Sep 17 00:00:00 2001 From: Steven Woods Date: Mon, 22 Jul 2024 12:19:57 +0100 Subject: [PATCH 059/157] Catch system exit in observer.py to close gracefully Signed-off-by: Steven Woods --- python3/packages/observer.py | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/python3/packages/observer.py b/python3/packages/observer.py index b6a0db7f6d1..13c01179a44 100644 --- a/python3/packages/observer.py +++ b/python3/packages/observer.py @@ -373,7 +373,7 @@ def _patch_module(module_name): # are not overridden and will be the defined no-op functions. span, patch_module = _init_tracing(observer_configs, observer_config_dir) - # If tracing is now operational, explicity set "OTEL_SDK_DISABLED" to "false". + # If tracing is now operational, explicitly set "OTEL_SDK_DISABLED" to "false". # In our case, different from the standard, we want the tracing disabled by # default, so if the env variable is not set the noop implementation is used. os.environ["OTEL_SDK_DISABLED"] = "false" @@ -420,6 +420,13 @@ def run(file): print(e, file=sys.stderr) # Print the exception message print(traceback.format_exc(), file=sys.stderr) # Print the traceback return 139 # This is what the default SIGSEGV handler on Linux returns + except SystemExit as e: # catch SystemExit so we can close gracefully + _exit_code = e.code if e.code is not None else 0 + debug("Script exited with code %i", _exit_code) + # Print the traceback if _exit_code is non-zero + if _exit_code: + print(traceback.format_exc(), file=sys.stderr) + return _exit_code return run(argv0) From 7dfcd28d4febfa123e7d5f0758f59ebfce39b393 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Wed, 24 Jul 2024 10:23:36 +0800 Subject: [PATCH 060/157] CP-49214: Upload and sync bundle file Upload a bundle file and unpack it with module Tar_ext. After that, sync the bundle repository. Signed-off-by: Bengang Yuan --- ocaml/idl/datamodel.ml | 1 + ocaml/idl/datamodel_errors.ml | 13 +++ ocaml/xapi-cli-server/cli_frontend.ml | 11 +++ ocaml/xapi-cli-server/cli_operations.ml | 30 +++++++ ocaml/xapi-cli-server/cli_util.ml | 19 +++++ ocaml/xapi-consts/api_errors.ml | 12 +++ ocaml/xapi-consts/constants.ml | 2 + ocaml/xapi/repository.ml | 11 ++- ocaml/xapi/tar_ext.ml | 2 +- ocaml/xapi/xapi.ml | 1 + ocaml/xapi/xapi_globs.ml | 3 + ocaml/xapi/xapi_pool.ml | 108 +++++++++++++++++++++--- ocaml/xapi/xapi_pool.mli | 2 + 13 files changed, 199 insertions(+), 16 deletions(-) diff --git a/ocaml/idl/datamodel.ml b/ocaml/idl/datamodel.ml index eca871fa6d5..580ca92ddbb 100644 --- a/ocaml/idl/datamodel.ml +++ b/ocaml/idl/datamodel.ml @@ -8432,6 +8432,7 @@ let http_actions = , [] ) ) + ; ("put_bundle", (Put, Constants.put_bundle_uri, true, [], _R_POOL_OP, [])) ] (* these public http actions will NOT be checked by RBAC *) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 04d56597ea8..4fb61ebbd24 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1895,6 +1895,19 @@ let _ = ~doc:"The GPG public key file name in the repository is invalid." () ; error Api_errors.repository_already_exists ["ref"] ~doc:"The repository already exists." () ; + error Api_errors.bundle_repository_already_exists ["ref"] + ~doc:"The bundle repository already exists." () ; + error Api_errors.bundle_unpack_failed ["error"] + ~doc:"Failed to unpack bundle file." () ; + error Api_errors.bundle_repo_not_enabled [] + ~doc:"Cannot sync bundle as the bundle repository is not enabled." () ; + error Api_errors.can_not_sync_updates [] + ~doc:"Cannot sync updates as the bundle repository is enabled." () ; + error Api_errors.bundle_repo_should_be_single_enabled [] + ~doc: + "If the bundle repository is enabled, it should be the only one enabled \ + repository of the pool." + () ; error Api_errors.repository_is_in_use [] ~doc:"The repository is in use." () ; error Api_errors.repository_cleanup_failed [] ~doc:"Failed to clean up local repository on coordinator." () ; diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index e735d4793ca..89b7718044b 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -3091,6 +3091,17 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [] } ) + ; ( "pool-sync-bundle" + , { + reqd= ["filename"] + ; optn= [] + ; help= + "Upload and unpack a bundle file, after that, sync the bundle \ + repository." + ; implementation= With_fd Cli_operations.pool_sync_bundle + ; flags= [] + } + ) ; ( "host-ha-xapi-healthcheck" , { reqd= [] diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 4c0c8f07811..1e049f034b2 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -6769,6 +6769,36 @@ let pool_get_guest_secureboot_readiness printer rpc session_id params = (Record_util.pool_guest_secureboot_readiness_to_string result) ) +let pool_sync_bundle fd _printer rpc session_id params = + let filename_opt = List.assoc_opt "filename" params in + match filename_opt with + | Some filename -> + let make_command task_id = + let master = get_master ~rpc ~session_id in + let master_address = + Client.Host.get_address ~rpc ~session_id ~self:master + in + let uri = + Uri.( + make ~scheme:"http" ~host:master_address + ~path:Constants.put_bundle_uri + ~query: + [ + ("session_id", [Ref.string_of session_id]) + ; ("task_id", [Ref.string_of task_id]) + ] + () + |> to_string + ) + in + debug "%s: requesting HttpPut('%s','%s')" __FUNCTION__ filename uri ; + HttpPut (filename, uri) + in + ignore + (track_http_operation fd rpc session_id make_command "upload bundle") + | None -> + failwith "Required parameter not found: filename" + let host_restore fd _printer rpc session_id params = let filename = List.assoc "file-name" params in let op _ host = diff --git a/ocaml/xapi-cli-server/cli_util.ml b/ocaml/xapi-cli-server/cli_util.ml index 51fa3357d7b..48fd9392ef5 100644 --- a/ocaml/xapi-cli-server/cli_util.ml +++ b/ocaml/xapi-cli-server/cli_util.ml @@ -26,6 +26,14 @@ open Client let finally = Xapi_stdext_pervasives.Pervasiveext.finally +let internal_error fmt = + Printf.ksprintf + (fun str -> + error "%s" str ; + raise Api_errors.(Server_error (internal_error, [str])) + ) + fmt + let log_exn_continue msg f x = try f x with e -> debug "Ignoring exception: %s while %s" (Printexc.to_string e) msg @@ -334,3 +342,14 @@ let error_of_exn e = let string_of_exn exn = let e, l = error_of_exn exn in Printf.sprintf "%s: [ %s ]" e (String.concat "; " l) + +let get_pool ~rpc ~session_id = + match Client.Pool.get_all ~rpc ~session_id with + | [] -> + internal_error "Remote host does not belong to a pool." + | pool :: _ -> + pool + +let get_master ~rpc ~session_id = + let pool = get_pool ~rpc ~session_id in + Client.Pool.get_master ~rpc ~session_id ~self:pool diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 3998068378a..9d11674e7a0 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1311,6 +1311,18 @@ let invalid_gpgkey_path = add_error "INVALID_GPGKEY_PATH" let repository_already_exists = add_error "REPOSITORY_ALREADY_EXISTS" +let bundle_repository_already_exists = + add_error "BUNDLE_REPOSITORY_ALREADY_EXISTS" + +let bundle_unpack_failed = add_error "BUNDLE_UNPACK_FAILED" + +let bundle_repo_not_enabled = add_error "BUNDLE_REPO_NOT_ENABLED" + +let can_not_sync_updates = add_error "CAN_NOT_SYNC_UPDATES" + +let bundle_repo_should_be_single_enabled = + add_error "BUNDLE_REPO_SHOULD_BE_SINGLE_ENABLED" + let repository_is_in_use = add_error "REPOSITORY_IS_IN_USE" let repository_cleanup_failed = add_error "REPOSITORY_CLEANUP_FAILED" diff --git a/ocaml/xapi-consts/constants.ml b/ocaml/xapi-consts/constants.ml index 356c6ac6914..2c7fc49e179 100644 --- a/ocaml/xapi-consts/constants.ml +++ b/ocaml/xapi-consts/constants.ml @@ -159,6 +159,8 @@ let get_host_updates_uri = "/host_updates" (* ocaml/xapi/repository.ml *) let get_updates_uri = "/updates" (* ocaml/xapi/repository.ml *) +let put_bundle_uri = "/bundle" (* ocaml/xapi/xapi_pool.ml *) + let default_usb_speed = -1. let use_compression = "use_compression" diff --git a/ocaml/xapi/repository.ml b/ocaml/xapi/repository.ml index fb77d41488b..95007999782 100644 --- a/ocaml/xapi/repository.ml +++ b/ocaml/xapi/repository.ml @@ -51,13 +51,16 @@ let introduce ~__context ~name_label ~name_description ~binary_url ~source_url let introduce_bundle ~__context ~name_label ~name_description = Db.Repository.get_all ~__context |> List.iter (fun ref -> - if - name_label = Db.Repository.get_name_label ~__context ~self:ref - || Db.Repository.get_origin ~__context ~self:ref = `bundle - then + if name_label = Db.Repository.get_name_label ~__context ~self:ref then raise Api_errors.( Server_error (repository_already_exists, [Ref.string_of ref]) + ) ; + if Db.Repository.get_origin ~__context ~self:ref = `bundle then + raise + Api_errors.( + Server_error + (bundle_repository_already_exists, [Ref.string_of ref]) ) ) ; create_repository_record ~__context ~name_label ~name_description diff --git a/ocaml/xapi/tar_ext.ml b/ocaml/xapi/tar_ext.ml index 3595cbee683..35c60719070 100644 --- a/ocaml/xapi/tar_ext.ml +++ b/ocaml/xapi/tar_ext.ml @@ -58,7 +58,7 @@ let unpack_error_to_string = function (Int64.to_string expected_size) (Int64.to_string actual_size) | File_incomplete -> - "File incompete" + "File incomplete" | File_corrupted -> "File corrupted" | Unpacking_failure -> diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml index 26659a55801..b568ecded15 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -858,6 +858,7 @@ let common_http_handlers () = , Http_svr.FdIO Xapi_pool_update.pool_update_download_handler ) ; ("get_host_updates", Http_svr.FdIO Xapi_host.get_host_updates_handler) + ; ("put_bundle", Http_svr.FdIO Xapi_pool.put_bundle_handler) ] in if !Xapi_globs.disable_webserver then diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index ee2b83df171..cdb1cc40144 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -957,6 +957,9 @@ let ignore_vtpm_unimplemented = ref false let evacuation_batch_size = ref 10 +(* Max size limit of bundle file: 500 MB*) +let bundle_max_size_limit = ref (Int64.of_int (500 * 1024 * 1024)) + type xapi_globs_spec = | Float of float ref | Int of int ref diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index f0cd7c49bfc..d02cfa185c8 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -25,6 +25,7 @@ let finally = Xapi_stdext_pervasives.Pervasiveext.finally let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute open Network +open Http module L = Debug.Make (struct let name = "license" end) @@ -3347,10 +3348,30 @@ let enable_tls_verification ~__context = | Some self -> Xapi_cluster_host.set_tls_config ~__context ~self ~verify:true +let contains_bundle_repo ~__context ~repos = + List.exists + (fun repo -> Db.Repository.get_origin ~__context ~self:repo = `bundle) + repos + +let assert_single_bundle_repo_can_be_enabled ~__context ~repos = + if List.length repos > 1 && contains_bundle_repo ~__context ~repos then + raise Api_errors.(Server_error (bundle_repo_should_be_single_enabled, [])) + +let assert_not_bundle_repo ~__context ~repos = + if contains_bundle_repo ~__context ~repos then + raise Api_errors.(Server_error (can_not_sync_updates, [])) + +let disable_auto_update_sync_for_bundle_repo ~__context ~self ~repos = + if contains_bundle_repo ~__context ~repos then ( + Pool_periodic_update_sync.set_enabled ~__context ~value:false ; + Db.Pool.set_update_sync_enabled ~__context ~self ~value:false + ) + let set_repositories ~__context ~self ~value = Xapi_pool_helpers.with_pool_operation ~__context ~self ~doc:"pool.set_repositories" ~op:`configure_repositories @@ fun () -> + assert_single_bundle_repo_can_be_enabled ~__context ~repos:value ; let existings = Db.Pool.get_repositories ~__context ~self in (* To be removed *) List.iter @@ -3373,7 +3394,8 @@ let set_repositories ~__context ~self ~value = value ; Db.Pool.set_repositories ~__context ~self ~value ; if Db.Pool.get_repositories ~__context ~self = [] then - Db.Pool.set_last_update_sync ~__context ~self ~value:Date.epoch + Db.Pool.set_last_update_sync ~__context ~self ~value:Date.epoch ; + disable_auto_update_sync_for_bundle_repo ~__context ~self ~repos:value let add_repository ~__context ~self ~value = Xapi_pool_helpers.with_pool_operation ~__context ~self @@ -3381,11 +3403,15 @@ let add_repository ~__context ~self ~value = @@ fun () -> let existings = Db.Pool.get_repositories ~__context ~self in if not (List.mem value existings) then ( + assert_single_bundle_repo_can_be_enabled ~__context + ~repos:(value :: existings) ; Db.Pool.add_repositories ~__context ~self ~value ; Db.Repository.set_hash ~__context ~self:value ~value:"" ; Repository.reset_updates_in_cache () ; Db.Pool.set_last_update_sync ~__context ~self ~value:Date.epoch - ) + ) ; + disable_auto_update_sync_for_bundle_repo ~__context ~self + ~repos:(value :: existings) let remove_repository ~__context ~self ~value = Xapi_pool_helpers.with_pool_operation ~__context ~self @@ -3403,13 +3429,9 @@ let remove_repository ~__context ~self ~value = if Db.Pool.get_repositories ~__context ~self = [] then Db.Pool.set_last_update_sync ~__context ~self ~value:Date.epoch -let sync_updates ~__context ~self ~force ~token ~token_id = - Pool_features.assert_enabled ~__context ~f:Features.Updates ; +let sync_repos ~__context ~self ~repos ~force ~token ~token_id = let open Repository in - Xapi_pool_helpers.with_pool_operation ~__context ~self - ~doc:"pool.sync_updates" ~op:`sync_updates - @@ fun () -> - Repository_helpers.get_enabled_repositories ~__context + repos |> List.iter (fun repo -> if force then cleanup_pool_repo ~__context ~self:repo ; sync ~__context ~self:repo ~token ~token_id ; @@ -3422,6 +3444,15 @@ let sync_updates ~__context ~self ~force ~token ~token_id = Db.Pool.set_last_update_sync ~__context ~self ~value:(Date.now ()) ; checksum +let sync_updates ~__context ~self ~force ~token ~token_id = + Pool_features.assert_enabled ~__context ~f:Features.Updates ; + Xapi_pool_helpers.with_pool_operation ~__context ~self + ~doc:"pool.sync_updates" ~op:`sync_updates + @@ fun () -> + let repos = Repository_helpers.get_enabled_repositories ~__context in + assert_not_bundle_repo ~__context ~repos ; + sync_repos ~__context ~self ~repos ~force ~token ~token_id + let check_update_readiness ~__context ~self:_ ~requires_reboot = (* Pool license check *) Pool_features.assert_enabled ~__context ~f:Features.Updates ; @@ -3696,9 +3727,15 @@ let configure_update_sync ~__context ~self ~update_sync_frequency Pool_periodic_update_sync.set_enabled ~__context ~value:true let set_update_sync_enabled ~__context ~self ~value = - if value && Db.Pool.get_repositories ~__context ~self = [] then ( - error "Cannot enable automatic update syncing if there are no repositories." ; - raise Api_errors.(Server_error (no_repositories_configured, [])) + ( if value then + match Db.Pool.get_repositories ~__context ~self with + | [] -> + error + "Cannot enable automatic update syncing if there are no \ + repositories." ; + raise Api_errors.(Server_error (no_repositories_configured, [])) + | repos -> + assert_not_bundle_repo ~__context ~repos ) ; Pool_periodic_update_sync.set_enabled ~__context ~value ; Db.Pool.set_update_sync_enabled ~__context ~self ~value @@ -3722,3 +3759,52 @@ let get_guest_secureboot_readiness ~__context ~self:_ = `ready_no_dbx | _, _, _, _ -> `not_ready + +let put_bundle_handler (req : Request.t) s _ = + req.Request.close <- true ; + Xapi_http.with_context "Sync bundle" req s (fun __context -> + (* This is the signal to say we've taken responsibility from the CLI server + for completing the task *) + (* The GUI can deal with this itself, but the CLI is complicated by the thin + cli/cli server split *) + TaskHelper.set_progress ~__context 0.0 ; + Pool_features.assert_enabled ~__context ~f:Features.Updates ; + let pool = Helpers.get_pool ~__context in + Xapi_pool_helpers.with_pool_operation ~__context ~self:pool + ~doc:"pool.sync_updates" ~op:`sync_updates + @@ fun () -> + Http_svr.headers s (Http.http_200_ok ()) ; + let repo = + Repository_helpers.get_single_enabled_update_repository ~__context + in + match Db.Repository.get_origin ~__context ~self:repo with + | `bundle -> ( + let result = + Tar_ext.unpack_tar_file + ~dir:!Xapi_globs.bundle_repository_dir + ~ifd:s + ~max_size_limit:!Xapi_globs.bundle_max_size_limit + in + match result with + | Ok () -> + TaskHelper.set_progress ~__context 0.8 ; + finally + (fun () -> + sync_repos ~__context ~self:pool ~repos:[repo] ~force:true + ~token:"" ~token_id:"" + |> ignore + ) + (fun () -> Unixext.rm_rec !Xapi_globs.bundle_repository_dir) + | Error e -> + error "%s: Failed to unpack bundle with error %s" __FUNCTION__ + (Tar_ext.unpack_error_to_string e) ; + TaskHelper.failed ~__context + Api_errors.( + Server_error + (bundle_unpack_failed, [Tar_ext.unpack_error_to_string e]) + ) ; + Http_svr.headers s (Http.http_400_badrequest ()) + ) + | `remote -> + raise Api_errors.(Server_error (bundle_repo_not_enabled, [])) + ) diff --git a/ocaml/xapi/xapi_pool.mli b/ocaml/xapi/xapi_pool.mli index 39b023810cd..5fc33c66cad 100644 --- a/ocaml/xapi/xapi_pool.mli +++ b/ocaml/xapi/xapi_pool.mli @@ -422,3 +422,5 @@ val get_guest_secureboot_readiness : __context:Context.t -> self:API.ref_pool -> API.pool_guest_secureboot_readiness + +val put_bundle_handler : Http.Request.t -> Unix.file_descr -> 'a -> unit From 3dff387a154cb48827db7e02ea05ffab53200927 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Wed, 24 Jul 2024 10:25:01 +0800 Subject: [PATCH 061/157] CP-49214: Allowed operations for sync bundle Add an allowed_operations for sync bundle. Signed-off-by: Bengang Yuan --- ocaml/idl/datamodel_errors.ml | 5 +++++ ocaml/idl/datamodel_pool.ml | 3 +++ ocaml/idl/schematest.ml | 2 +- ocaml/xapi-cli-server/record_util.ml | 2 ++ ocaml/xapi-consts/api_errors.ml | 2 ++ ocaml/xapi/xapi_pool.ml | 2 +- ocaml/xapi/xapi_pool_helpers.ml | 1 + 7 files changed, 15 insertions(+), 2 deletions(-) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 4fb61ebbd24..921a289f04d 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1920,6 +1920,11 @@ let _ = "The operation could not be performed because syncing updates is in \ progress." () ; + error Api_errors.sync_bundle_in_progress [] + ~doc: + "The operation could not be performed because syncing bundle is in \ + progress." + () ; error Api_errors.reposync_failed [] ~doc:"Syncing with remote YUM repository failed." () ; error Api_errors.invalid_repomd_xml [] ~doc:"The repomd.xml is invalid." () ; diff --git a/ocaml/idl/datamodel_pool.ml b/ocaml/idl/datamodel_pool.ml index 4e7336dc2d6..cdc830add08 100644 --- a/ocaml/idl/datamodel_pool.ml +++ b/ocaml/idl/datamodel_pool.ml @@ -21,6 +21,9 @@ let operations = ; ( "sync_updates" , "Indicates this pool is in the process of syncing updates" ) + ; ( "sync_bundle" + , "Indicates this pool is in the process of syncing bundle" + ) ; ( "get_updates" , "Indicates this pool is in the process of getting updates" ) diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index 6091444dcc9..e81d05ee0ab 100644 --- a/ocaml/idl/schematest.ml +++ b/ocaml/idl/schematest.ml @@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex (* BEWARE: if this changes, check that schema has been bumped accordingly in ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *) -let last_known_schema_hash = "2a6baa01032827a321845b264c6aaae4" +let last_known_schema_hash = "4417b0087b481c3038e73f170b7d4d01" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml index 92b395185a9..2c98955fffd 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -201,6 +201,8 @@ let pool_operation_to_string = function "configure_repositories" | `sync_updates -> "sync_updates" + | `sync_bundle -> + "sync_bundle" | `get_updates -> "get_updates" | `apply_updates -> diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 9d11674e7a0..0ade8d9cdbf 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1334,6 +1334,8 @@ let multiple_update_repositories_enabled = let sync_updates_in_progress = add_error "SYNC_UPDATES_IN_PROGRESS" +let sync_bundle_in_progress = add_error "SYNC_BUNDLE_IN_PROGRESS" + let reposync_failed = add_error "REPOSYNC_FAILED" let createrepo_failed = add_error "CREATEREPO_FAILED" diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index d02cfa185c8..6176729caa4 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -3771,7 +3771,7 @@ let put_bundle_handler (req : Request.t) s _ = Pool_features.assert_enabled ~__context ~f:Features.Updates ; let pool = Helpers.get_pool ~__context in Xapi_pool_helpers.with_pool_operation ~__context ~self:pool - ~doc:"pool.sync_updates" ~op:`sync_updates + ~doc:"pool.sync_bundle" ~op:`sync_bundle @@ fun () -> Http_svr.headers s (Http.http_200_ok ()) ; let repo = diff --git a/ocaml/xapi/xapi_pool_helpers.ml b/ocaml/xapi/xapi_pool_helpers.ml index d023cce84d1..16309c7bd51 100644 --- a/ocaml/xapi/xapi_pool_helpers.ml +++ b/ocaml/xapi/xapi_pool_helpers.ml @@ -36,6 +36,7 @@ let blocking_ops = ; (`tls_verification_enable, Api_errors.tls_verification_enable_in_progress) ; (`configure_repositories, Api_errors.configure_repositories_in_progress) ; (`sync_updates, Api_errors.sync_updates_in_progress) + ; (`sync_bundle, Api_errors.sync_bundle_in_progress) ; (`apply_updates, Api_errors.apply_updates_in_progress) ] From 8f4c71bdc5488daabcb9c6c10b7ec23a34656e05 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Wed, 24 Jul 2024 10:25:20 +0800 Subject: [PATCH 062/157] CP-49214: UT for upload and sync bundle file Signed-off-by: Bengang Yuan --- ocaml/tests/dune | 6 +- ocaml/tests/test_pool_repository.ml | 116 ++++++++++++++++++++++++++++ ocaml/tests/test_repository.ml | 4 +- 3 files changed, 122 insertions(+), 4 deletions(-) create mode 100644 ocaml/tests/test_pool_repository.ml diff --git a/ocaml/tests/dune b/ocaml/tests/dune index 2bd666ff4c0..816b18577c4 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -9,7 +9,7 @@ test_vm_placement test_vm_helpers test_repository test_repository_helpers test_ref test_vm_group test_livepatch test_rpm test_updateinfo test_storage_smapiv1_wrapper test_storage_quicktest test_observer - test_pool_periodic_update_sync test_pkg_mgr test_tar_ext)) + test_pool_periodic_update_sync test_pkg_mgr test_tar_ext test_pool_repository)) (libraries alcotest angstrom @@ -79,13 +79,13 @@ (tests (names test_vm_helpers test_vm_placement test_network_sriov test_vdi_cbt test_clustering test_pusb test_daemon_manager test_repository test_repository_helpers - test_livepatch test_rpm test_updateinfo test_pool_periodic_update_sync test_pkg_mgr test_tar_ext) + test_livepatch test_rpm test_updateinfo test_pool_periodic_update_sync test_pkg_mgr test_tar_ext test_pool_repository) (package xapi) (modes exe) (modules test_vm_helpers test_vm_placement test_network_sriov test_vdi_cbt test_event test_clustering test_cluster_host test_cluster test_pusb test_daemon_manager test_repository test_repository_helpers test_livepatch test_rpm - test_updateinfo test_pool_periodic_update_sync test_pkg_mgr test_tar_ext) + test_updateinfo test_pool_periodic_update_sync test_pkg_mgr test_tar_ext test_pool_repository) (libraries alcotest bos diff --git a/ocaml/tests/test_pool_repository.ml b/ocaml/tests/test_pool_repository.ml new file mode 100644 index 00000000000..bdfcc314e20 --- /dev/null +++ b/ocaml/tests/test_pool_repository.ml @@ -0,0 +1,116 @@ +(* + * Copyright (c) Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module T = Test_common + +let test_set_remote_and_bundle_repos () = + let __context = T.make_test_database () in + let name_label = "remote" in + let name_description = "remote" in + let binary_url = "https://repo.example.com" in + let source_url = "https://repo-src.example.com" in + let gpgkey_path = "" in + let ref_remote = + Repository.introduce ~__context ~name_label ~name_description ~binary_url + ~source_url ~update:true ~gpgkey_path + in + let ref_bundle = + Repository.introduce_bundle ~__context ~name_label:"bundle" + ~name_description:"bundle" + in + let self = Helpers.get_pool ~__context in + Alcotest.check_raises "test_set_remote_and_bundle_repos" + Api_errors.(Server_error (bundle_repo_should_be_single_enabled, [])) + (fun () -> + Xapi_pool.set_repositories ~__context ~self + ~value:[ref_remote; ref_bundle] + ) + +let test_add_bundle_repo () = + let __context = T.make_test_database () in + let name_label = "remote" in + let name_description = "remote" in + let binary_url = "https://repo.example.com" in + let source_url = "https://repo-src.example.com" in + let gpgkey_path = "" in + let ref_remote = + Repository.introduce ~__context ~name_label ~name_description ~binary_url + ~source_url ~update:true ~gpgkey_path + in + let ref_bundle = + Repository.introduce_bundle ~__context ~name_label:"bundle" + ~name_description:"bundle" + in + let self = Helpers.get_pool ~__context in + Alcotest.check_raises "test_add_bundle_repo" + Api_errors.(Server_error (bundle_repo_should_be_single_enabled, [])) + (fun () -> + Xapi_pool.set_repositories ~__context ~self ~value:[ref_remote] ; + Xapi_pool.add_repository ~__context ~self ~value:ref_bundle + ) + +let test_add_remote_repo () = + let __context = T.make_test_database () in + let name_label = "remote" in + let name_description = "remote" in + let binary_url = "https://repo.example.com" in + let source_url = "https://repo-src.example.com" in + let gpgkey_path = "" in + let ref_remote = + Repository.introduce ~__context ~name_label ~name_description ~binary_url + ~source_url ~update:true ~gpgkey_path + in + let ref_bundle = + Repository.introduce_bundle ~__context ~name_label:"bundle" + ~name_description:"bundle" + in + let self = Helpers.get_pool ~__context in + Alcotest.check_raises "test_add_remote_repo" + Api_errors.(Server_error (bundle_repo_should_be_single_enabled, [])) + (fun () -> + Xapi_pool.set_repositories ~__context ~self ~value:[ref_bundle] ; + Xapi_pool.add_repository ~__context ~self ~value:ref_remote + ) + +let test_can_not_enable_bundle_repo_auto_sync () = + let __context = T.make_test_database () in + let ref_bundle = + Repository.introduce_bundle ~__context ~name_label:"bundle" + ~name_description:"bundle" + in + let self = Helpers.get_pool ~__context in + Alcotest.check_raises "test_can_not_enable_bundle_repo_auto_sync" + Api_errors.(Server_error (can_not_sync_updates, [])) + (fun () -> + Xapi_pool.set_repositories ~__context ~self ~value:[ref_bundle] ; + Xapi_pool.set_update_sync_enabled ~__context ~self ~value:true + ) + +let test = + [ + ( "test_set_remote_and_bundle_repos" + , `Quick + , test_set_remote_and_bundle_repos + ) + ; ("test_add_bundle_repo", `Quick, test_add_bundle_repo) + ; ("test_add_remote_repo", `Quick, test_add_remote_repo) + ; ( "test_can_not_enable_bundle_repo_auto_sync" + , `Quick + , test_can_not_enable_bundle_repo_auto_sync + ) + ] + +let () = + Suite_init.harness_init () ; + Alcotest.run "Test Pool Repository suite" [("Test_pool_repository", test)] diff --git a/ocaml/tests/test_repository.ml b/ocaml/tests/test_repository.ml index 860dc63a950..59008a61272 100644 --- a/ocaml/tests/test_repository.ml +++ b/ocaml/tests/test_repository.ml @@ -101,7 +101,9 @@ let test_introduce_duplicate_bundle_repo () = in Alcotest.check_raises "test_introduce_duplicate_bundle_repo" - Api_errors.(Server_error (repository_already_exists, [Ref.string_of ref])) + Api_errors.( + Server_error (bundle_repository_already_exists, [Ref.string_of ref]) + ) (fun () -> Repository.introduce_bundle ~__context ~name_label:name_label_1 ~name_description:name_description_1 From c870b266b07313f9283966e710e7074822ae3fc1 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Wed, 24 Jul 2024 10:27:53 +0800 Subject: [PATCH 063/157] CP-49214: Refactor cli_operations 1. Replace all `Client.Pool.get_all` and `Client.Pool.get_master` with self-defined function `cli_util.get_pool` and `cli_util.get_master` so that we can reduce the use of `List.hd`. 2. Remove some unused getting pool_master code in function `host_careful_op`. Signed-off-by: Bengang Yuan --- ocaml/xapi-cli-server/cli_operations.ml | 17 +++++------------ quality-gate.sh | 2 +- 2 files changed, 6 insertions(+), 13 deletions(-) diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 1e049f034b2..a64b850df40 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -2462,8 +2462,7 @@ let parse_host_uuid ?(default_master = true) rpc session_id params = let hosts = Client.Host.get_all ~rpc ~session_id in let standalone = List.length hosts = 1 in if standalone || default_master then - let pool = List.hd (Client.Pool.get_all ~rpc ~session_id) in - Client.Pool.get_master ~rpc ~session_id ~self:pool + get_master ~rpc ~session_id else failwith "Required parameter not found: host-uuid" @@ -3989,7 +3988,7 @@ let vm_install_real printer rpc session_id template name description params = , [Features.name_of_feature Features.PCI_device_for_auto_update] ) in - let pool = List.hd (Client.Pool.get_all ~rpc ~session_id) in + let pool = get_pool ~rpc ~session_id in let policy_vendor_device_is_ok = not (Client.Pool.get_policy_no_vendor_device ~rpc ~session_id ~self:pool) in @@ -5133,11 +5132,6 @@ let vm_cd_insert printer rpc session_id params = let host_careful_op op warnings fd _printer rpc session_id params = let uuid = List.assoc "uuid" params in let host = Client.Host.get_by_uuid ~rpc ~session_id ~uuid in - let pool = List.hd (Client.Pool.get_all ~rpc ~session_id) in - let _ (* unused variable 'pool_master' *) = - Client.Pool.get_master ~rpc ~session_id ~self:pool - in - (* if pool_master = host then failwith "Cannot forget pool master"; *) let force = get_bool_param params "force" in let go () = ignore (op ~rpc ~session_id ~self:host) in if force then @@ -6605,11 +6599,11 @@ let host_disable_local_storage_caching _printer rpc session_id params = ) let pool_enable_local_storage_caching _printer rpc session_id _params = - let pool = List.hd (Client.Pool.get_all ~rpc ~session_id) in + let pool = get_pool ~rpc ~session_id in Client.Pool.enable_local_storage_caching ~rpc ~session_id ~self:pool let pool_disable_local_storage_caching _printer rpc session_id _params = - let pool = List.hd (Client.Pool.get_all ~rpc ~session_id) in + let pool = get_pool ~rpc ~session_id in Client.Pool.disable_local_storage_caching ~rpc ~session_id ~self:pool let pool_apply_edition printer rpc session_id params = @@ -6692,8 +6686,7 @@ let host_backup fd _printer rpc session_id params = let pool_dump_db fd _printer rpc session_id params = let filename = List.assoc "file-name" params in let make_command task_id = - let pool = List.hd (Client.Pool.get_all ~rpc ~session_id) in - let master = Client.Pool.get_master ~rpc ~session_id ~self:pool in + let master = get_master ~rpc ~session_id in let master_address = Client.Host.get_address ~rpc ~session_id ~self:master in diff --git a/quality-gate.sh b/quality-gate.sh index 8f761718627..2cadb6a8d0e 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=302 + N=296 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages" From 29344a7fb088e2316c2fc1b76d3fdb99e8e6f408 Mon Sep 17 00:00:00 2001 From: Steven Woods Date: Mon, 22 Jul 2024 12:20:24 +0100 Subject: [PATCH 064/157] CP-49876: Create spans for observer.py itself Creates two spans for observer.py, one for the entire script and one for the opentelemtry import statements. This fixes the current discrepancy between the sm script span and the outer xapi span. Signed-off-by: Steven Woods --- python3/packages/observer.py | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/python3/packages/observer.py b/python3/packages/observer.py index 13c01179a44..4f2966e5a9a 100644 --- a/python3/packages/observer.py +++ b/python3/packages/observer.py @@ -20,6 +20,17 @@ passed script without any instrumentation. """ +import time + +def to_otel_timestamp(ts): + return int(ts * 1000000000) + +observer_ts_start = to_otel_timestamp(time.time()) +observer_mono_start = time.monotonic() + +def current_otel_time(): + return observer_ts_start + to_otel_timestamp(time.monotonic() - observer_mono_start) + import configparser import functools import inspect @@ -117,6 +128,9 @@ def _init_tracing(configs: List[str], config_dir: str): # On 3.10-3.12, the import of wrapt might trigger warnings, filter them: simplefilter(action="ignore", category=DeprecationWarning) + + import_ts_start = current_otel_time() + import wrapt # type: ignore[import-untyped] from opentelemetry import context, trace from opentelemetry.baggage.propagation import W3CBaggagePropagator @@ -127,6 +141,8 @@ def _init_tracing(configs: List[str], config_dir: str): from opentelemetry.trace.propagation.tracecontext import ( TraceContextTextMapPropagator, ) + + import_ts_end = current_otel_time() except ImportError as err: syslog.error("missing opentelemetry dependencies: %s", err) return _span_noop, _patch_module_noop @@ -359,6 +375,12 @@ def _patch_module(module_name): for m in module_names: _patch_module(m) + # Create spans to track observer.py's setup duration + t = tracers[0] + with t.start_as_current_span("observer.py:init_tracing", start_time=observer_ts_start): + import_span = t.start_span("observer.py:imports", start_time=import_ts_start) + import_span.end(end_time=import_ts_end) + return span_of_tracers, _patch_module From 670cb990fcc5292c01f16f77556a60a718c824eb Mon Sep 17 00:00:00 2001 From: Deli Zhang Date: Mon, 29 Jul 2024 06:06:00 +0000 Subject: [PATCH 065/157] CP-50121: Remove bc package from XS9 dom0 To ensure consistency and simplicity for both XS9 and XS8, this change replaces bc command use to python. Signed-off-by: Deli Zhang --- scripts/xe-xentrace | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/xe-xentrace b/scripts/xe-xentrace index 94b51bcf134..ff39f3164ba 100755 --- a/scripts/xe-xentrace +++ b/scripts/xe-xentrace @@ -144,7 +144,7 @@ if [ -n "${DUMP_ON_CPUAVG}" ]; then | (TRIGGER=0 read -r _IGNORE while IFS=, read -r _time value; do - if (( $(echo "${value} > ${DUMP_ON_CPUAVG}/100" | bc -l) )); then + if (( $(python3 -c "print(1 if ${value} > ${DUMP_ON_CPUAVG}/100.0 else 0)") )); then TRIGGER=$((TRIGGER + 1)) else TRIGGER=0 From f7860c7fb30deb22a71bc058ecf4fe0b24381b9b Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 30 Jul 2024 11:50:21 +0100 Subject: [PATCH 066/157] dune: declare stresstests dependencies This should fix the nightly CIs Signed-off-by: Pau Ruiz Safont --- ocaml/libs/http-lib/dune | 9 +++++---- ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune | 3 ++- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index 1deae570337..623cb1ddb33 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -60,7 +60,7 @@ (modules http_test radix_tree_test) (libraries alcotest - + fmt http_lib ) @@ -88,8 +88,9 @@ (rule (alias stresstest) + (deps bufio_test.exe) ; use default random seed on stresstests - (action (run %{dep:bufio_test.exe} -v -bt)) + (action (run %{deps} -v -bt)) ) (executable @@ -97,7 +98,7 @@ (name test_client) (modules test_client) (libraries - + http_lib safe-resources stunnel @@ -112,7 +113,7 @@ (name test_server) (modules test_server) (libraries - + http_lib httpsvr safe-resources diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune index 407d025a8a8..0a2e4e27de7 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune @@ -9,8 +9,9 @@ (rule (alias stresstest) + (deps unixext_test.exe) ; use default random seed on stresstests - (action (run %{dep:unixext_test.exe} -v -bt)) + (action (run %{deps} -v -bt)) ) (test From 83cded633fe8e9cb01b52826af264080ab0ddbd9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 31 Jul 2024 10:50:19 +0100 Subject: [PATCH 067/157] Update qcheck-alcotest dependencies MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit test_timer shouldn't be part of the clock package: it is only needed for testing. test_timer doesn't need to depend on qcheck-alcotest: only _run needs to. XAPI needs to depend on qcheck-alcotest, because quicktest uses it too now. Signed-off-by: Edwin Török --- dune-project | 1 + ocaml/libs/clock/dune | 2 -- xapi.opam | 1 + 3 files changed, 2 insertions(+), 2 deletions(-) diff --git a/dune-project b/dune-project index 20a8079ca44..0efbe491956 100644 --- a/dune-project +++ b/dune-project @@ -331,6 +331,7 @@ ppx_sexp_conv ppx_deriving psq + qcheck-alcotest rpclib (rrdd-plugin (= :version)) rresult diff --git a/ocaml/libs/clock/dune b/ocaml/libs/clock/dune index 67fbef3208f..76285033f35 100644 --- a/ocaml/libs/clock/dune +++ b/ocaml/libs/clock/dune @@ -13,14 +13,12 @@ (library (name test_timer) - (package clock) (modules test_timer) (libraries alcotest clock fmt mtime.clock.os - qcheck-alcotest qcheck-core ) ) diff --git a/xapi.opam b/xapi.opam index 6f67cf1c1f3..16dcc46d2b4 100644 --- a/xapi.opam +++ b/xapi.opam @@ -37,6 +37,7 @@ depends: [ "ppx_sexp_conv" "ppx_deriving" "psq" + "qcheck-alcotest" "rpclib" "rrdd-plugin" {= version} "rresult" From 4fd52425e4a5eefa480c1164e8a87513538bfdcc Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 29 Jul 2024 17:21:33 +0100 Subject: [PATCH 068/157] docs: add design documents for certificate-related features There are 2: user-installable certificates and certificate checking for pool communications. Signed-off-by: Pau Ruiz Safont --- doc/content/design/pool-certificates.md | 374 ++++++++++++++++++++++++ doc/content/design/user-certificates.md | 271 +++++++++++++++++ 2 files changed, 645 insertions(+) create mode 100644 doc/content/design/pool-certificates.md create mode 100644 doc/content/design/user-certificates.md diff --git a/doc/content/design/pool-certificates.md b/doc/content/design/pool-certificates.md new file mode 100644 index 00000000000..043638e3296 --- /dev/null +++ b/doc/content/design/pool-certificates.md @@ -0,0 +1,374 @@ +--- +title: TLS vertification for intra-pool communications +layout: default +design_doc: true +revision: 2 +status: released (22.6.0) +--- + +## Overview + +Xenserver has used TLS-encrypted communications between xapi daemons in a pool since its first release. +However it does not use TLS certificates to authenticate the servers it connects to. +This allows possible attackers opportunities to impersonate servers when the pools’ management network is compromised. + +In order to enable certificate verification, certificate exchange as well as proper set up to trust them must be provided by xapi. +This is currently done by allowing users to generate, sign and install the certificates themselves; and then enable the Common Criteria mode. +This requires a CA and has a high barrier of entry. + +Using the same certificates for intra-host communication creates friction between what the user needs and what the host needs. +Instead of trying to reconcile these two uses with one set of certificates, host will serve two certificates: one for API calls from external clients, which is the one that can be changed by the users; and one that is use for intra-pool communications. +The TLS server in the host can select which certificate to serve depending on the service name the client requests when opening a TLS connection. +This mechanism is called Server Name Identification or SNI in short. + +Last but not least the update bearing these changes must not disrupt pool operations while or after being applied. + +## Glossary + +| Term | Meaning | +| ---- | ------- | +| SNI | Server Name Identification. This TLS protocol extension allows a server to select a certificate during the initial TLS handshake depending on a client-provided name. This usually allows a single reverse-proxy to serve several HTTPS websites. +| Host certificate | Certificate that a host sends clients when the latter initiate a connection with the former. The clients may close the connection depending on the properties of this certificate and whether they have decided to trust it previously. +| Trusted certificate | Certificate that a computer uses to verify whether a host certificate is valid. If the host certificate's chain of trust does not include a trusted certificate it will be considered invalid. +| Default Certificate | Xenserver hosts present this certificate to clients which do not request an SNI. Users are allowed to install their own custom certificate. +| Pool Certificate | Xenserver hosts present this certificate to clients which request `xapi:pool`as the SNI. They are used for host-to-host communications. +| Common Criteria | Common Criteria for Information Technology Security Evaluation is a certification on computer security. + +# Certificates and Identity management + +Currently Xenserver hosts generate self-signed certificates with the IP or FQDN as their subjects, users may also choose to install certificates. +When installing these certificates only the cryptographic algorithms used to generate the certificates (private key and hash) are validated and no properties about them are required. + +This means that using user-installed certificates for intra-pool communication may prove difficult as restrictions regarding FQDN and chain validation need to be ensured before enabling TLS certificate checking or the pool communications will break down. + +Instead a different certificate is used only for pool communication. +This allows to decouple whatever requirements users might have for the certificates they install to the requirements needed for secure pool communication. +This has several benefits: + +* Frees the pool from ensuring a sound hostname resolution on the internal communications. +* Allows the pool to rotate the certificates when it deems necessary. (in particular expiration, or forced invalidation) +* Hosts never share a host certificate, and their private keys never get transmitted. + +In general, the project is able to more safely change the parameters of intra-pool communication without disrupting how users use custom certificates. + +To be able to establish trust in a pool, hosts must distribute the certificates to the rest of the pool members. +Once that is done servers can verify whether they are connecting to another host in the pool by comparing the server certificate with the certificates in the trust root. +Certificate pinning is available and would allow more stringent checks, but it doesn't seem a necessity: hosts in a pool already share secret that allows them to have full control of the pool. + +To be able to select a host certificate depending whether the connections is intra-pool or comes from API clients SNI will be used. +This allows clients to ask for a service when establishing a TLS connection. +This allows the server to choose the certificate they want to offer when negotiating the connection with the client. +The hosts will exploit this to request a particular service when they establish a connection with other hosts in the pool. +When initiating a connection to another host in the pool, a server will create requests for TLS connections with the server_name `xapi:pool` with the `name_type` `DNS`, this goes against RFC-6066 as this `server_name` is not resolvable. +This still works because we control the implementation in both peers of the connection and can follow the same convention. + +In addition connections to the WLB appliance will continue to be validated using the current scheme of user-installed CA certificates. +This means that hosts connecting to the appliance will need a special case to only trust user-installed certificated when establishing the connection. +Conversely pool connections will ignore these certificates. +| Name | Filesystem location | User-configurable | Used for | +| ---- | ------------------- | ----------------- | -------- | +| Host Default | /etc/xensource/xapi-ssl.pem | yes (using API) | Hosts serve it to normal API clients +| Host Pool | /etc/xensource/xapi-pool-tls.pem | no | Hosts serve to clients requesting "xapi:pool" as the SNI +| Trusted Default | /etc/stunnel/certs/ | yes (using API) | Certificates that users can install for trusting appliances +| Trusted Pool | /etc/stunnel/certs-pool/ | no | Certificates that are managed by the pool for host-to-host communications +| Default Bundle | /etc/stunnel/xapi-stunnel-ca-bundle.pem | no | Bundle of certificates that hosts use to verify appliances (in particular WLB), this is kept in sync with "Trusted Default" +| Pool Bundle | /etc/stunnel/xapi-pool-ca-bundle.pem | no | Bundle of certificates that hosts use to verify other hosts on pool communications, this is kept in sync with "Trusted Pool" + +## Cryptography of certificates + +The certificates until now have been signed using sha256WithRSAEncryption: + +* Pre-8.0 releases use 1024-bit RSA keys. +* 8.0, 8.1 and 8.2 use 2048-bit RSA keys. + +The Default Certificates served to API clients will continue to use sha256WithRSAEncryption with 2048-bit RSA keys. The Pool certificates will use the same algorithms for consistency. + +The self-signed certificates until now have used a mix of IP and hostname claims: + +* All released versions: + - Subject and issuer have CN FQDN if the hostname is different from localhost, or CN management IP + - Subject Alternate Names extension contains all the domain names as DNS names +* Next release: + - Subject and issuer have CN management IP + - SAN extension contains all domain names as DNS names and the management IP as IP + +The Pool certificates do not contain claims about IPs nor hostnames as this may change during runtime and depending on their validity may make pool communication more brittle. +Instead the only claim they have is that their Issuer and their Subject are CN Host UUID, along with a serial number. + +Self-signed certificates produced until now have had validity periods of 3650 days (~10 years). +The Pool certificates will have the same validity period. + +# Server Components + +HTTPS Connections between hosts usually involve the xapi daemons and stunnel processes: + +- When a xapi daemon needs to initiate a connection with another host it starts an HTTP connection with a local stunnel process. +- The stunnel processes wrap http connections inside a TLS connection, allowing HTTPS to be used when hosts communicate + +This means that stunnel needs to be set up correctly to verify certificates when connecting to other hosts. +Some aspects like CA certificates are already managed, but certificate pinning is not. + +# Use Cases + +There are several use cases that need to be modified in order correctly manage trust between hosts. + +## Opening a connection with a pool host + +This is the main use case for the feature, the rest of use cases that need changes are modified to support this one. +Currently a Xenserver host connecting to another host within the pool does not try to authenticate the receiving server when opening a TLS connection. +(The receiving server authenticates the originating server by xapi authentication, see below) + +Stunnel will be configured to verify the peer certificate against the CA certificates that are present in the host. +The CA certificates must be correctly set up when a host joins the pool to correctly establish trust. + +The previous behaviour for WLB must be kept as the WLB connection _must_ be checked against the user-friendly CA certificates. + +## Receiving an incoming TLS connection + +All incoming connections authenticate the client using credentials, this does not need the addition of certificates. +(username and password, pool secret) + +The hosts must present the certificate file to incoming connections so the client can authenticate them. +This is already managed by xapi, it configures stunnel to present the configured host certificate. +The configuration has to be changed so stunnel responds to SNI requests containing the string `xapi:pool` to serve the internal certificate instead of the client-installed one. + +## U1. Host Installation + +On xapi startup an additional certificate is created now for pool operations. +It's added to the trusted pool certificates. +The certificate's only claim is the host's UUID. +No IP nor hostname information is kept as the clients only check for the certificate presence in the trust root. + +## U2. Pool Join + +This use-case is delicate as it is the point where trust is established between hosts. +This is done with a call from the joiner to the pool coordinator where the certificate of the coordinator is not verified. +In this call the joiner transmits its certificate to the coordinator and the coordinator returns a list of the pool members' UUIDs and certificates. +This means that in the policy used is trust on first use. + +To deal with parallel pool joins, hosts download all the Pool certificates in the pool from the coordinator after all restarts. + +The connection is initiated by a client, just like before, there is no change in the API as all the information needed to start the join is already provided (pool username and password, IP of coordinator) + +~~~mermaid + +sequenceDiagram +participant clnt as Client +participant join as Joiner +participant coor as Coordinator +participant memb as Member +clnt->>join: pool.join coordinator_ip coordinator_username coordinator_password +join->>coor:login_with_password coordinator_ip coordinator_username coordinator_password + +Note over join: pre_join_checks +join->>join: remote_pool_has_tls_enabled = self_pool_has_tls_enabled +alt are different +Note over join: interrupt join, raise error +end +Note right of join: certificate distribution +coor-->>join: +join->>coor: pool.internal_certificate_list_content +coor-->>join: + +join->>coor: pool.upload_identity_host_certificate joiner_certificate uuid +coor->>memb: pool.internal_certificates_sync +memb-->>coor: + +loop for every in Joiner +join->>coor: Pool.install_ca_certitificate +coor-->>join: +end + +loop for every in Joiner +join->>coor: Pool.install_crl +coor-->>join: +end + +join->>coor: host.add joiner +coor-->>join: + +join->>join: restart_as_slave +join->>coor: pool.user_certificates_sync +join->>coor: host.copy_primary_host_certs + +~~~ + +## U3. Pool Eject + +During pool eject the pool must remove the host certificate of the ejected member from the internal trust root, this must be done by the xapi daemon of the coordinator. + +The ejected member will recreate both server certificates to replicate a new installation. +This can be triggered by deleting the certificates and their private keys in the host before rebooting, the current boot scripts automatically generates a new self-signed certificate if the file is not present. +Additionally, both the user and the internal trust roots will be cleared before rebooting as well. + +## U4. Pool Upgrade + +When a pool has finished upgrading to the version with certificate checking the database reflects that the feature is turned off, this is done as part of the database upgrade procedure in xen-api. +The internal certificate is created on restart. +It is added to the internal trusted certificates directory. +The distribution of certificate will happens when the tls verification is turned on, afterwards. + +## U5. Host certificate state inspection + +In order to give information about the validity and useful information of installed user-facing certificates to API clients as well as the certificates used for internal purposes, 2 fields are added to certificate records in xapi's datamodel and database: + +- type: indicates which of the 3 kind of certificates is the certificate. If it's a user-installed trusted CA certificate, a server certificate served to clients that do not use SNI, and a server certificate served when the SNI xapi:pool is used. The exact values are ca, host and host-internal, respectively. +- name: the human-readable name given by the user. This fields is only present on trusted CA certificates and allows the pool operators to better recognise the certificates. + +Additionally, now the _host field contains a null reference if the certificate is a corporate CA (a ca certificate). + +The fields will get exposed in the CLI whenever a certificate record is listed, this needs a xapi-cli-server to be modified to show the new field. + +## U6. Migrating a VM to another pool + +To enable a frictionless migration when pools have tls verification enabled, the host certificate of the host receiving the vm is sent to the sender. +This is done by adding the certificate of the receiving host as well as its pool coordinator to the return value of the function migrate_receive function. +The sender can then add the certificate to the folder of CA certificates that stunnel uses to verify the server in a TLS connection. +When the transaction finishes, whether it fails or succeeds the CA certificate is deleted. + +The certificate is stored in a temporary location so xapi can clean up the file when it starts up, in case after the host fences or power cycles while the migration is in progress. + +Xapi invokes sparse_dd with the filename correct trusted bundle as a parameter so it can verify the vhd-server running on the other host. + +Xapi also invokes xcp-rrdd to migrate the VM metrics. +xcp-rrdd is passed the 2 certificates to verify the remote hosts when sending the metrics. + +Clients should not be aware of this change and require no change. + +Xapi-cli-server, the server of xe embedded into xapi, connects to the remote coordinator using TLS to be able to initiate the migration. +Currently no verification is done. A certificate is required to initiate the connection to verify the remote server. + +In u6.3 and u6.4 no changes seem necessary. + +## U7. Change a host's name + +The Pool certificates do not depend on hostnames. +Changing the hostnames does not affect TLS certificate verification in a pool. + +## U8. Installing a certificate (corporate CA) + +Installation of corporate CA can be done with current API. +Certificates are added to the database as CA certificates. + +## U9. Resetting a certificate (to self-signed certificate) + +This needs a reimplementation of the current API to reset host certificate, this time allowing the operation to happen when the host is not on emergency node and to be able to do it remotely. + +## U10. Enabling certificate verification + +A new API call is introduced to enable tls certificate verification: Pool.enable_tls_verification. +This is used by the CLI command pool-enable-tls-verification. +The call causes the coordinator of the pool to install the Pool certificates of all the members in its internal trust root. +Then calls the api for each member to install all of these certificates. +After this public key exchange is done, TLS certificate verification is enabled on the members, with the coordinator being the last to enable it. + +When there are issues that block enabling the feature, the call returns an error specific to that problem: + +* HA must not be enabled, as it can interrupt the procedure when certificates are distributed +* Pool operations that can disrupt the certificate exchange block this operation: These operations are listed in here +* There was an issue with the certificate exchange in the pool. + +The coordinator enabling verification last is done to ensure that if there is any issue enabling the coordinator host can still connect to members and rollback the setting. + +A new field is added to the pool: tls_verification_enabled. This enables clients to query whether TLS verification is enabled. + +## U11. Disabling certificate verification + +A new emergency command is added emergency-host-disable-tls-verification. +This command disables tls-verification for the xapi daemon in a host. +This allows the host to communicate with other hosts in the pool. + +After that, the admin can regenerate the certificates using the new host-refresh-server-certificate in the hosts with invalid certificates, finally they can reenable tls certificate checking using the call emergency-host-reenable-tls-verification. + +The documentation will include instructions for administrators on how to reset certificates and manually installing the host certificates as CA certificates to recover pools. + +This means they will not have to disable TLS and compromise on security. + +## U12. Being aware of certificate expiry + +Stockholm hosts provide alerts 30 days before hosts certificates expire, it must be changed to alert about users' CA certificates expiring. + +Pool certificates need to be cycled when the certificate expiry is approaching. +Alerts are introduced to warn the administrator this task must be done, or risk the operation of the pool. +A new API is introduced to create certificates for all members in a pool and replace the existing internal certificates with these. +This call imposes the same requirements in a pool as the pool secret rotation: It cannot be run in a pool unless all the host are online, it can only be started by the coordinator, the coordinator is in a valid state, HA is disabled, no RPU is in progress, and no pool operations are in progress. +The API call is Pool.rotate_internal_certificates. +It is exposed by xe as pool-rotate-internal-certificates. + +# Changes + +Xapi startup has to account for host changes that affect this feature and modify the filesystem and pool database accordingly. + +* Public certificate changed: On first boot, after a pool join and when doing emergency repairs the server certificate record of the host may not match to the contents in the filesystem. A check is to be introduced that detects if the database does not associate a certificate with the host or if the certificate's public key in the database and the filesystem are different. If that's the case the database is updated with the certificate in the filesystem. +* Pool certificate not present: In the same way the public certificate served is generated on startup, the internal certificate must be generated if the certificate is not present in the filesystem. +* Pool certificate changed: On first boot, after a pool join and after having done emergency repairs the internal server certificate record may not match the contents of the filesystem. A check is to be introduced that detects if the database does not associate a certificate with the host or if the certificate's public key in the database and the filesystem are different. This check is made aware whether the host is joining a pool or is on first-boot, it does this by counting the amount of hosts in the pool from the database. In the case where it's joining a pool it simply updated the database record with the correct information from the filesystem as the filesystem contents have been put in place before the restart. In the case of first boot the public part of the certificate is copied to the directory and the bundle for internally-trusted certificates: /etc/stunnel/certs-pool/ and /etc/stunnel/xapi-pool-ca-bundle.pem. + +The xapi database records for certificates must be changed according with the additions explained before. + +### API + +Additions +* Pool.tls_verification_enabled: this is a field that indicates whether TLS verification is enabled. +* Pool.enable_tls_verification: this call is allowed for role _R_POOL_ADMIN. It's not allowed to run if HA is enabled nor pool operations are in progress. All the hosts in the pool transmit their certificate to the coordinator and the coordinator then distributes the certificates to all members of the pool. Once that is done the coordinator tries to initiate a session with all the pool members with TLS verification enabled. If it's successful TLS verification is enabled for the whole pool, otherwise the error COULD_NOT_VERIFY_HOST [member UUID] is emmited. +* TLS_VERIFICATION_ENABLE_IN_PROGRESS is a new error that is produced when trying to do other pool operations while enabling TLS verification is in progress +* Host.emergency_disable_tls_verification: this called is allowed for role _R_LOCAL_ROOT_ONLY: it's an emergency command and acts locally. It forces connections in xapi to stop verifying the peers on outgoing connections. It generates an alert to warn the administrators of this uncommon state. +* Host.emergency_reenable_tls_verification: this call is allowed for role _R_LOCAL_ROOT_ONLY: it's an emergency command and acts locally. It changes the configuration so xapi verifies connections by default after being switched off with the previous command. +* Pool.install_ca_certificate: rename of Pool.certificate_install, add the ca certificate to the database. +* Pool.uninstall_ca_certificate: rename of Pool.certificate_uninstall, removes the certificate from the database. +* Host.reset_server_certificate: replaces Host.emergency_reset_server_certificate, now it's allowed for role _R_POOL_ADMIN. It adds a record for the generated Default Certificate to the database while removing the previous record, if any. +* Pool.rotate_internal_certificates: This call generates new Pool certificates, and substitutes the previous certificates with these. See the certificate expiry section for more details. + +Modifications: +* Pool.join: certificates must be correctly distributed. API Error POOL_JOINING_HOST_TLS_VERIFICATION_MISMATCH is returned if the tls_verification of the two pools doesn't match. +* Pool.eject: all certificates must be deleted from the ejected host's filesystem and the ejected host's certificate must be deleted from the pool's trust root. +* Host.install_server_certificate: the certificate type host for the record must be added to denote it's a Standard Certificate. + +Deprecations: +* pool.certificate_install +* pool.certificate_uninstall +* pool.certificate_list +* pool.wlb_verify_cert: This setting is superseeded by pool.enable_tls_verification. It cannot be removed, however. When updating from a previous version when this setting is on, TLS connections to WLB must still verify the external host. When the global setting is enabled this setting is ignored. +* host.emergency_reset_server_certificate: host.reset_server_certificate should be used instead as this call does not modify the database. + +### CLI + +Following API additions: +* pool-enable-tls-verification +* pool-install-ca-certificate +* pool-uninstall-ca-certificate +* pool-internal-certificates-rotation +* host-reset-server-certificate +* host-emergency-disable-tls-verification (emits a warning when verification is off and the pool-level is on) +* host-emergency-reenable-tls-verification + +And removals: +* host-emergency-server-certificate + +### Feature Flags + +This feature needs clients to behave differently when initiating pool joins, to allow them to choose behaviour the toolstack will expose a new feature flag 'Certificate_verification'. This flag will be part of the express edition as it's meant to aid detection of a feature and not block access to it. + +### Alerts + +Several alerts are introduced: +* POOL_CA_CERTIFICATE_EXPIRING_30, POOL_CA_CERTIFICATE_EXPIRING_14, POOL_CA_CERTIFICATE_EXPIRING_07, POOL_CA_CERTIFICATE_EXPIRED: Similar to host certificates, now the user-installable pool's CA certificates are monitored for expiry dates and alerts are generated about them. The body for this type of message is: + + The trusted TLS server certificate {is expiring soon|has expired}.20210302T02:00:01Z + +* HOST_INTERNAL_CERTIFICATE_EXPIRING_30, HOST_INTERNAL_CERTIFICATE_EXPIRING_14, HOST_INTERNAL_CERTIFICATE_EXPIRING_07, HOST_INTERNAL_CERTIFICATE_EXPIRED: Similar to host certificates, the newly-introduced hosts' internal server certificates are monitored for expiry dates and alerts are generated about them. The body for this type of message is: + + The TLS server certificate for internal communications {is expiring soon|has expired}.20210302T02:00:01Z + +* TLS_VERIFICATION_EMERGENCY_DISABLED: The host is in emergency mode and is not enforcing tls verification anymore, the situation that forced the disabling must be fixed and the verification enabled ASAP. + + HOST-UUID + +* FAILED_LOGIN_ATTEMPTS: An hourly alert that contains the number of failed attempts and the 3 most common origins for these failed alerts. The body for this type of message is: + + + 35 + usr5origin55.4.3.21020200922T15:03:13Z + usr4UA620200922T15:03:13Z + UA4.3.2.1420200922T14:57:11Z + 10 + diff --git a/doc/content/design/user-certificates.md b/doc/content/design/user-certificates.md new file mode 100644 index 00000000000..33f61c3e905 --- /dev/null +++ b/doc/content/design/user-certificates.md @@ -0,0 +1,271 @@ +--- +title: User-installable host certificates +layout: default +design_doc: true +revision: 2 +status: released (8.2) +--- + +## Introduction + +It is often necessary to replace the TLS certificate used to secure +communications to Xenservers hosts, for example to allow a XenAPI user such as +Citrix Virtual Apps and Desktops (CVAD) to validate that the host is genuine +and not impersonating the actual host. + +Historically there has not been a supported mechanism to do this, and as a +result users have had to rely on guides written by third parties that show how +to manually replace the xapi-ssl.pem file on a host. This process is +error-prone, and if a mistake is made, can result in an unuseable system. +This design provides a fully supported mechanism to allow replacing the +certificates. + +## Design proposal + +It is expected that an API caller will provide, in a single API call, a private +key, and one or more certificates for use on the host. The key will be provided +in PKCS #8 format, and the certificates in X509 format, both in +base-64-encoded PEM containers. + +Multiple certificates can be provided to cater for the case where an +intermediate certificate or certificates are required for the caller to be able +to verify the certificate back to a trusted root (best practice for Certificate +Authorities is to have an 'offline' root, and issue certificates from an +intermediate Certificate Authority). In this situation, it is expected (and +common practice among other tools) that the first certificate provided in the +chain is the host's unique server certificate, and subsequent certificates form +the chain. + +To detect mistakes a user may make, certain checks will be carried out on the +provided key and certificate(s) before they are used on the host. If all checks +pass, the key and certificate(s) will be written to the host, at which stage a +signal will be sent to stunnel that will cause it to start serving the new +certificate. + +## Certificate Installation + +### API Additions + +Xapi must provide an API call through Host RPC API to install host +certificates: + +```ocaml +let install_server_certificate = call + ~lifecycle:[Published, rel_stockholm, ""] + ~name:"install_server_certificate" + ~doc:"Install the TLS server certificate." + ~versioned_params: + [{ param_type=Ref _host; param_name="host"; param_doc="The host" + ; param_release=stockholm_release; param_default=None} + ;{ param_type=String; param_name="certificate" + ; param_doc="The server certificate, in PEM form" + ; param_release=stockholm_release; param_default=None} + ;{ param_type=String; param_name="private_key" + ; param_doc="The unencrypted private key used to sign the certificate, \ + in PKCS#8 form" + ; param_release=stockholm_release; param_default=None} + ;{ param_type=String; param_name="certificate_chain" + ; param_doc="The certificate chain, in PEM form" + ; param_release=stockholm_release; param_default=Some (VString "")} + ] + ~allowed_roles:_R_POOL_ADMIN + () +``` + +This call should be implemented within xapi, using the already-existing crypto +libraries available to it. + +Analogous to the API call, a new CLI call `host-server-certificate-install` +must be introduced, which takes the parameters `certificate`, `key` and +`certificate-chain` - these parameters are expected to be filenames, from which +the key and certificate(s) must be read, and passed to the +`install_server_certificate` RPC call. + +The CLI will be defined as: +```ocaml +"host-server-certificate-install", +{ + reqd=["certificate"; "private-key"]; + optn=["certificate-chain"]; + help="Install a server TLS certificate on a host"; + implementation=With_fd Cli_operations.host_install_server_certificate; + flags=[ Host_selectors ]; +}; +``` + +### Validation + +Xapi must perform the following validation steps on the provided key and +certificate. If any validation step fails, the API call must return an error +with the specified error code, providing any associated text: + +### Private Key + +* Validate that it is a pem-encoded PKCS#8 key, use error +`SERVER_CERTIFICATE_KEY_INVALID []` and exposed as +"The provided key is not in a pem-encoded PKCS#8 format." + +* Validate that the algorithm of the key is RSA, use error +`SERVER_CERTIFICATE_KEY_ALGORITHM_NOT_SUPPORTED, []` +and exposed as "The provided key uses an unsupported algorithm." + +* Validate that the key length is ≥ 2048, and ≤ 4096 bits, use error +`SERVER_CERTIFICATE_KEY_RSA_LENGTH_NOT_SUPPORTED, [length]` and exposed as +"The provided RSA key does not have a length between 2048 and 4096." + +* The library used does not support multi-prime RSA keys, when it's +encountered use error `SERVER_CERTIFICATE_KEY_RSA_MULTI_NOT_SUPPORTED []` and +exposed as "The provided RSA key is using more than 2 primes, expecting only +2" + +#### Server Certificate +* Validate that it is a pem-encoded X509 certificate, use error +`SERVER_CERTIFICATE_INVALID []` and exposed as "The provided certificate is not +in a pem-encoded X509." + +* Validate that the public key of the certificate matches the public key from +the private key, using error `SERVER_CERTIFICATE_KEY_MISMATCH []` and exposing +it as "The provided key does not match the provided certificate's public key." + +* Validate that the certificate is currently valid. (ensure all time +comparisons are done using UTC, and any times presented in errors are using +ISO8601 format): + + * Ensure the certificate's `not_before` date is ≤ NOW + `SERVER_CERTIFICATE_NOT_VALID_YET, [; ]` and exposed as + "The provided certificate certificate is not valid yet." + + * Ensure the certificate's `not_after` date is > NOW + `SERVER_CERTIFICATE_EXPIRED, [; ]` and exposed as "The + provided certificate has expired." + +* Validate that the certificate signature algorithm is SHA-256 +`SERVER_CERTIFICATE_SIGNATURE_NOT_SUPPORTED []` and exposed as +"The provided certificate is not using the SHA256 (SHA2) signature algorithm." + +#### Intermediate Certificates +* Validate that it is an X509 certificate, use +`SERVER_CERTIFICATE_CHAIN_INVALID []` and exposed as "The provided +intermediate certificates are not in a pem-encoded X509." + +### Filesystem Interaction + +If validation has been completed successfully, a temporary file must be created +with permissions 0x400 containing the key and certificate(s), in that order, +separated by an empty line. + +This file must then be atomically moved to /etc/xensource/xapi-ssl.pem in +order to ensure the integrity of the contents. This may be done using rename +with the origin and destination in the same mount-point. + +## Alerting + +A daily task must be added. This task must check the expiry date of the first +certificate present in /etc/xensource/xapi-ssl.pem, and if it is within 30 +days of expiry, generate a `message` to alert the administrator that the +certificate is due to expire shortly. + +The body of the message should contain: +``` + + + The TLS server certificate is expiring soon + + + ` + + + +``` + +The priority of the message should be based on the number of days to expiry as +follows: + +| Number of days | Priority | +| -------------- | -------- | +| 0-7 | 1 | +| 8-14 | 2 | +| 14+ | 3 | + +The other fields of the message should be: + +| Field | Value | +| ----- | ----- | +| name | HOST_SERVER_CERTIFICATE_EXPIRING | +| class | Host | +| obj-uuid | < Host UUID > | + +Any existing `HOST_SERVER_CERTIFICATE_EXPIRING` messages with this host's UUID +should be removed to avoid a build-up of messages. + +Additionally, the task may also produce messages for expired server +certificates which must use the name `HOST_SERVER_CERTIFICATE_EXPIRED`. +These kind of message must contain the message "The TLS server certificate has +expired." as well as the expiry date, like the expiring messages. +They also may replace the existing expiring messages in a host. + +## Expose Certificate metadata + +Currently xapi exposes a CLI command to print the certificate being used to +verify external hosts. We would like to also expose through the API and the +CLI useful metadata about the certificates in use by each host. + +The new class is meant to cover server certificates and trusted certificates. + +### Schema + +A new class, Certificate, will be added with the following schema: + +| Field | Type | Notes | +| ---------- | --------- | ----- | +| uuid | | +| type | CA | Certificate trusted by all hosts +| | Host | Certificate that the host present sto normal clients +| name | String | Name, only present for trusted certificates +| host | Ref _host | Host where the certificate is installed +| not_before | DateTime | Date after which the certificate is valid +| not_after | DateTime | Date before which the certificate is valid +| fingerprint_sha256 | String | The certificate's SHA256 fingerprint / hash +| fingerprint_sha1 | String | The certificate's SHA1 fingerprint / hash + +### CLI / API + +There are currently-existing CLI parameters for certificates: +`pool-certificate-{install,uninstall,list,sync}`, +`pool-crl-{install,uninstall,list}` and `host-get-server-certificate`. + +The new command must show the metadata of installed server certificates in +the pool. +It must be able to show all of them in the same call, and be able to filter +the certificates per-host. + +To make it easy to separate it from the previous calls and to reflect that +certificates are a class type in xapi the call will be named `certificate-list` +and it will accept the parameter `host-uuid=`. + +## Recovery mechanism + +In the case a certificate is let to expire TLS clients connecting to the host +will refuse establish the connection. +This means that the host is going to be unable to be managed using the xapi +API (Xencenter, or a CVAD control plane) + +There needs to be a mechanism to recover from this situation. +A CLI command must be provided to install a self-signed certificate, in the +same way it is generated during the setup process at the moment. +The command will be `host-emergency-reset-server-certificate`. +This command is never to be forwarded to another host and will call openssl to +create a new RSA private key + +The command must notify stunnel to make sure stunnel uses the newly-created +certificate. + +# Miscellaneous + +The auto-generated `xapi-ssl.pem` currently contains Diffie-Hellman (DH) +Parameters, specifically 512 bits worth. We no longer support any ciphers which +require DH parameters, so these are no longer needed, and it is acceptable for +them to be lost as part of installing a new certificate/key pair. + +The generation should also be modified to avoid creating these for new +installations. From 39199a5b1722c32ba27539184b74852eae3a5634 Mon Sep 17 00:00:00 2001 From: Danilo Del Busso Date: Wed, 31 Jul 2024 09:06:53 +0100 Subject: [PATCH 069/157] CA-396479: Use default value for unknown enums in Java Default enum is `UNRECOGNIZED` Signed-off-by: Danilo Del Busso --- .../src/main/java/com/xensource/xenapi/JsonRpcClient.java | 1 + 1 file changed, 1 insertion(+) diff --git a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcClient.java b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcClient.java index 20d6e5efc8e..9d1389eaf28 100644 --- a/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcClient.java +++ b/ocaml/sdk-gen/java/autogen/xen-api/src/main/java/com/xensource/xenapi/JsonRpcClient.java @@ -216,6 +216,7 @@ private void initializeObjectMapperConfiguration() { dateHandlerModule.addDeserializer(Date.class, new CustomDateDeserializer()); this.objectMapper.enable(JsonReadFeature.ALLOW_NON_NUMERIC_NUMBERS.mappedFeature()); this.objectMapper.configure(DeserializationFeature.FAIL_ON_UNKNOWN_PROPERTIES, false); + this.objectMapper.configure(DeserializationFeature.READ_UNKNOWN_ENUM_VALUES_USING_DEFAULT_VALUE, true); this.objectMapper.registerModule(dateHandlerModule); } From eb34314f0c946fe2ae6dc63cb8079f2b473c8c90 Mon Sep 17 00:00:00 2001 From: Danilo Del Busso Date: Wed, 31 Jul 2024 11:34:45 +0100 Subject: [PATCH 070/157] Default to "UNRECOGNIZED" when using `toString()` of Type enums Signed-off-by: Danilo Del Busso --- ocaml/sdk-gen/java/main.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/sdk-gen/java/main.ml b/ocaml/sdk-gen/java/main.ml index 3edcf1ea3a2..483d8689db1 100644 --- a/ocaml/sdk-gen/java/main.ml +++ b/ocaml/sdk-gen/java/main.ml @@ -882,7 +882,7 @@ let gen_enum file name ls = ) ls ; fprintf file " /* This can never be reached */\n" ; - fprintf file " return \"illegal enum\";\n" ; + fprintf file " return \"UNRECOGNIZED\";\n" ; fprintf file " }\n" ; fprintf file "\n }\n\n" From 62db5cb48965f80ed98d545de759d192080013af Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 23 May 2024 10:48:53 +0100 Subject: [PATCH 071/157] xapi-idl: Delete String.{explode,implode} functions These are highly inefficient. Also changes some functions to be able to have less types and make normal usage clearer. This comes at the cost of having to destructure the main type when pattern-matching it. Moves the device_number tests to its own executable to easily iterate on the tests. Signed-off-by: Pau Ruiz Safont --- ocaml/idl/markdown_backend.ml | 5 +- ocaml/libs/http-lib/http.ml | 59 +--- ocaml/libs/http-lib/http.mli | 1 + .../lib/xapi-stdext-std/xstringext.ml | 44 ++- .../lib/xapi-stdext-std/xstringext.mli | 12 +- ocaml/perftest/createpool.ml | 64 ++-- ocaml/xapi-idl/lib_test/device_number_test.ml | 93 +++--- .../xapi-idl/lib_test/device_number_test.mli | 0 ocaml/xapi-idl/lib_test/dune | 14 +- ocaml/xapi-idl/lib_test/test.ml | 1 - ocaml/xapi-idl/xen/device_number.ml | 277 +++++++++--------- ocaml/xapi-idl/xen/device_number.mli | 36 +-- ocaml/xapi-idl/xen/dune | 1 + ocaml/xapi/dbsync_slave.ml | 2 +- ocaml/xapi/storage_access.ml | 13 +- ocaml/xapi/vbdops.ml | 24 +- ocaml/xapi/xapi_dr_task.ml | 2 +- ocaml/xapi/xapi_templates_install.ml | 5 +- ocaml/xapi/xapi_vbd.ml | 29 +- ocaml/xapi/xapi_vbd_helpers.ml | 37 +-- ocaml/xapi/xapi_vm.ml | 2 +- ocaml/xapi/xapi_vm_helpers.ml | 10 +- ocaml/xapi/xapi_xenops.ml | 64 ++-- ocaml/xapi/xha_interface.ml | 4 +- ocaml/xapi/xmlrpc_sexpr.ml | 4 +- ocaml/xenopsd/cli/xn.ml | 20 +- ocaml/xenopsd/lib/xenops_server_simulator.ml | 16 +- ocaml/xenopsd/xc/device.ml | 19 +- ocaml/xenopsd/xc/xenops_server_xen.ml | 4 +- quality-gate.sh | 4 +- xapi-idl.opam | 1 + xapi-idl.opam.template | 1 + 32 files changed, 408 insertions(+), 460 deletions(-) create mode 100644 ocaml/xapi-idl/lib_test/device_number_test.mli diff --git a/ocaml/idl/markdown_backend.ml b/ocaml/idl/markdown_backend.ml index e039a7cfc42..66110b7d694 100644 --- a/ocaml/idl/markdown_backend.ml +++ b/ocaml/idl/markdown_backend.ml @@ -43,8 +43,6 @@ let compare_case_ins x y = compare (String.lowercase_ascii x) (String.lowercase_ascii y) let escape s = - let open Xapi_stdext_std.Xstringext in - let sl = String.explode s in let esc_char = function | '\\' -> "\" @@ -79,8 +77,7 @@ let escape s = | c -> String.make 1 c in - let escaped_list = List.map esc_char sl in - String.concat "" escaped_list + String.to_seq s |> Seq.map esc_char |> List.of_seq |> String.concat "" let rec of_ty_verbatim = function | SecretString | String -> diff --git a/ocaml/libs/http-lib/http.ml b/ocaml/libs/http-lib/http.ml index b6b4791e06f..c2f7e2aeda8 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -24,8 +24,6 @@ exception Forbidden exception Method_not_implemented -exception Malformed_url of string - exception Timeout exception Too_large @@ -145,61 +143,8 @@ let output_http fd headers = |> String.concat "" |> Unixext.really_write_string fd -let explode str = Astring.String.fold_right (fun c acc -> c :: acc) str [] - -let implode chr_list = - String.concat "" (List.map Astring.String.of_char chr_list) - -let urldecode url = - let chars = explode url in - let rec fn ac = function - | '+' :: tl -> - fn (' ' :: ac) tl - | '%' :: a :: b :: tl -> - let cs = - try int_of_string (implode ['0'; 'x'; a; b]) - with _ -> raise (Malformed_url url) - in - fn (Char.chr cs :: ac) tl - | x :: tl -> - fn (x :: ac) tl - | [] -> - implode (List.rev ac) - in - fn [] chars - (* Encode @param suitably for appearing in a query parameter in a URL. *) -let urlencode param = - let chars = explode param in - let rec fn = function - | x :: tl -> - let s = - if x = ' ' then - "+" - else - match x with - | 'A' .. 'Z' - | 'a' .. 'z' - | '0' .. '9' - | '$' - | '-' - | '_' - | '.' - | '!' - | '*' - | '\'' - | '(' - | ')' - | ',' -> - Astring.String.of_char x - | _ -> - Printf.sprintf "%%%2x" (Char.code x) - in - s ^ fn tl - | [] -> - "" - in - fn chars +let urlencode param = Uri.pct_encode ~component:`Query param (** Parses strings of the form a=b;c=d (new, RFC-compliant cookie format) and a=b&c=d (old, incorrect style) into [("a", "b"); ("c", "d")] *) @@ -219,7 +164,7 @@ let parse_cookies xs = List.map (function | k :: vs -> - (urldecode k, urldecode (String.concat "=" vs)) + (Uri.pct_decode k, Uri.pct_decode (String.concat "=" vs)) | [] -> raise Http_parse_failure ) diff --git a/ocaml/libs/http-lib/http.mli b/ocaml/libs/http-lib/http.mli index 384367e2463..91590bcdcdd 100644 --- a/ocaml/libs/http-lib/http.mli +++ b/ocaml/libs/http-lib/http.mli @@ -235,6 +235,7 @@ val output_http : Unix.file_descr -> string list -> unit val parse_cookies : string -> (string * string) list val urlencode : string -> string +(** Encode parameter suitably for appearing in a query parameter in a URL. *) type 'a ll = End | Item of 'a * (unit -> 'a ll) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml index 7fb16aba6f8..0b3da00c476 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml @@ -39,10 +39,6 @@ module String = struct done ; !accu - let explode string = fold_right (fun h t -> h :: t) string [] - - let implode list = concat "" (List.map of_char list) - (** True if string 'x' ends with suffix 'suffix' *) let endswith suffix x = let x_l = String.length x and suffix_l = String.length suffix in @@ -56,16 +52,6 @@ module String = struct (** Returns true for whitespace characters, false otherwise *) let isspace = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false - (** Removes all the characters from the ends of a string for which the predicate is true *) - let strip predicate string = - let rec remove = function - | [] -> - [] - | c :: cs -> - if predicate c then remove cs else c :: cs - in - implode (List.rev (remove (List.rev (remove (explode string))))) - let escaped ?rules string = match rules with | None -> @@ -81,24 +67,28 @@ module String = struct in concat "" (fold_right aux string []) - (** Take a predicate and a string, return a list of strings separated by - runs of characters where the predicate was true (excluding those characters from the result) *) let split_f p str = - let not_p x = not (p x) in - let rec split_one p acc = function - | [] -> - (List.rev acc, []) - | c :: cs -> - if p c then split_one p (c :: acc) cs else (List.rev acc, c :: cs) + let split_one seq = + let not_p c = not (p c) in + let a = Seq.take_while not_p seq in + let b = Seq.drop_while not_p seq in + (a, b) in - let rec alternate acc drop chars = - if chars = [] then + let drop seq = Seq.drop_while p seq in + let rec split acc chars = + if Seq.is_empty chars then acc else - let a, b = split_one (if drop then p else not_p) [] chars in - alternate (if drop then acc else a :: acc) (not drop) b + let a, b = split_one chars in + let b = drop b in + let acc = if Seq.is_empty a then acc else Seq.cons a acc in + split acc b in - List.rev (List.map implode (alternate [] true (explode str))) + String.to_seq str + |> split Seq.empty + |> Seq.map String.of_seq + |> List.of_seq + |> List.rev let index_opt s c = let rec loop i = diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli index e2587929916..e2b486285a6 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli @@ -29,12 +29,6 @@ module String : sig val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a (** Iterate over the characters in a string in reverse order. *) - val explode : string -> char list - (** Split a string into a list of characters. *) - - val implode : char list -> string - (** Concatenate a list of characters into a string. *) - val endswith : string -> string -> bool (** True if string 'x' ends with suffix 'suffix' *) @@ -44,9 +38,6 @@ module String : sig val isspace : char -> bool (** True if the character is whitespace *) - val strip : (char -> bool) -> string -> string - (** Removes all the characters from the ends of a string for which the predicate is true *) - val escaped : ?rules:(char * string) list -> string -> string (** Backward-compatible string escaping, defaulting to the built-in OCaml string escaping but allowing an arbitrary mapping from characters @@ -54,7 +45,8 @@ module String : sig val split_f : (char -> bool) -> string -> string list (** Take a predicate and a string, return a list of strings separated by - runs of characters where the predicate was true *) + runs of characters where the predicate was true. Avoid if possible, it's + very costly to execute. *) val split : ?limit:int -> char -> string -> string list (** split a string on a single char *) diff --git a/ocaml/perftest/createpool.ml b/ocaml/perftest/createpool.ml index ad4207427f6..bf96cfb7c36 100644 --- a/ocaml/perftest/createpool.ml +++ b/ocaml/perftest/createpool.ml @@ -350,24 +350,20 @@ let create_sdk_pool session_id sdkname pool_name key ipbase = let pingable = Array.make (Array.length hosts) false in let firstboot = Array.make (Array.length hosts) false in let string_of_status () = - Xstringext.String.implode - (Array.to_list - (Array.mapi - (fun i ping -> - let boot = firstboot.(i) in - match (ping, boot) with - | false, false -> - '.' - | true, false -> - 'P' - | true, true -> - 'B' - | _, _ -> - '?' - ) - pingable - ) - ) + Array.to_seq pingable + |> Seq.mapi (fun i ping -> + let boot = firstboot.(i) in + match (ping, boot) with + | false, false -> + '.' + | true, false -> + 'P' + | true, true -> + 'B' + | _, _ -> + '?' + ) + |> String.of_seq in let has_guest_booted i _vm = let ip = Printf.sprintf "192.168.%d.%d" pool.ipbase (i + 1) in @@ -469,24 +465,20 @@ let create_sdk_pool session_id sdkname pool_name key ipbase = let live = Array.make (Array.length hosts) false in let enabled = Array.make (Array.length hosts) false in let string_of_status () = - Xstringext.String.implode - (Array.to_list - (Array.mapi - (fun i live -> - let enabled = enabled.(i) in - match (live, enabled) with - | false, false -> - '.' - | true, false -> - 'L' - | true, true -> - 'E' - | _, _ -> - '?' - ) - live - ) - ) + Array.to_seq live + |> Seq.mapi (fun i live -> + let enabled = enabled.(i) in + match (live, enabled) with + | false, false -> + '.' + | true, false -> + 'L' + | true, true -> + 'E' + | _, _ -> + '?' + ) + |> String.of_seq in let has_host_booted rpc session_id i host = try diff --git a/ocaml/xapi-idl/lib_test/device_number_test.ml b/ocaml/xapi-idl/lib_test/device_number_test.ml index 9105299a16e..fc8d5b210f1 100644 --- a/ocaml/xapi-idl/lib_test/device_number_test.ml +++ b/ocaml/xapi-idl/lib_test/device_number_test.ml @@ -30,7 +30,7 @@ let deprecated = let examples_to_test = let using_deprecated_ide = try - ignore (make (Ide, 4, 0)) ; + ignore (make Ide ~disk:4 ~partition:0) ; true with _ -> false in @@ -46,16 +46,18 @@ let equivalent = ; ("d536p37", "xvdtq37") ] +let invalid = ["d0p0q"] + let test_examples = let tests = List.map - (fun (spec, linux, xenstore) -> - ( "test_examples " ^ linux + (fun ((bus, disk, partition), linux, xenstore) -> + let of_spec = make bus ~disk ~partition |> Option.get in + let of_linux = of_linux_device linux |> Option.get in + let of_xenstore = of_xenstore_key xenstore in + ( Printf.sprintf "%s = %s = %d" (to_debug_string of_spec) linux xenstore , `Quick , fun () -> - let of_spec = make spec in - let of_linux = of_linux_device linux in - let of_xenstore = of_xenstore_key xenstore in Alcotest.check device_number "examples must be equal" of_spec of_linux ; Alcotest.check device_number "examples must be equal" of_spec @@ -64,7 +66,7 @@ let test_examples = ) examples_to_test in - tests + ("Compare with linux and xenstore values", tests) (* NB we always understand the deprecated linux/xenstore devices even if we don't generate them ourselves *) @@ -72,40 +74,50 @@ let test_deprecated = let tests = List.map (fun (_, linux, xenstore) -> - ( "test_deprecated " ^ linux + ( linux , `Quick , fun () -> - let of_linux = of_linux_device linux in + let of_linux = of_linux_device linux |> Option.get in let of_xenstore = of_xenstore_key xenstore in Alcotest.check device_number "must be equal" of_linux of_xenstore ) ) deprecated in - tests + ("Deprecated linux device", tests) let test_equivalent = let tests = List.map (fun (x, y) -> - let test_name = Printf.sprintf "test_equivalent %s=%s" x y in + let test_name = Printf.sprintf "%s = %s" x y in ( test_name , `Quick , fun () -> - let x' = of_string false x in - let y' = of_string false y in + let x' = of_string ~hvm:false x |> Option.get in + let y' = of_string ~hvm:false y |> Option.get in Alcotest.check device_number "must be equal" x' y' ) ) equivalent in - tests + ("Equivalent devices", tests) + +let test_invalid = + let test x () = + if Option.is_some (of_string ~hvm:false x) then + Alcotest.failf "%s was not rejected" x + in + let tests = List.map (fun x -> (x, `Quick, test x)) invalid in + ("Reject invalid devices", tests) let test_2_way_convert = (* We now always convert Ide specs into xvd* linux devices, so they become Xen specs when converted back. *) - let equal_linux old_t new_t = - match (spec old_t, spec new_t) with + let equal_linux (old_t : t) (new_t : t) = + match + ((old_t, new_t) :> (bus_type * int * int) * (bus_type * int * int)) + with | (Ide, disk1, partition1), (Xen, disk2, partition2) when disk1 = disk2 && partition1 = partition2 -> true @@ -117,25 +129,36 @@ let test_2_way_convert = (Fmt.of_to_string Device_number.to_debug_string) equal_linux in + let test disk_number hvm = + let original = of_disk_number hvm disk_number |> Option.get in + let of_linux = of_linux_device (to_linux_device original) |> Option.get in + let of_xenstore = of_xenstore_key (to_xenstore_key original) in + Alcotest.check device_number_equal_linux + "of_linux must be equal to original" original of_linux ; + Alcotest.check device_number "of_xenstore must be equal to original" + original of_xenstore + in + + let max_d = (1 lsl 20) - 1 in + ( "2-way conversion" + , [ + ( Printf.sprintf "All disk numbers until %d" max_d + , `Slow + , fun () -> + for disk_number = 0 to max_d do + List.iter (test disk_number) [true; false] + done + ) + ] + ) + +let tests = [ - ( "test_2_way_convert" - , `Slow - , fun () -> - for disk_number = 0 to (1 lsl 20) - 1 do - List.iter - (fun hvm -> - let original = of_disk_number hvm disk_number in - let of_linux = of_linux_device (to_linux_device original) in - let of_xenstore = of_xenstore_key (to_xenstore_key original) in - Alcotest.check device_number_equal_linux - "of_linux must be equal to original" original of_linux ; - Alcotest.check device_number - "of_xenstore must be equal to original" original of_xenstore - ) - [true; false] - done - ) + test_examples + ; test_deprecated + ; test_equivalent + ; test_invalid + ; test_2_way_convert ] -let tests = - test_examples @ test_deprecated @ test_equivalent @ test_2_way_convert +let () = Alcotest.run "Device_number" tests diff --git a/ocaml/xapi-idl/lib_test/device_number_test.mli b/ocaml/xapi-idl/lib_test/device_number_test.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/xapi-idl/lib_test/dune b/ocaml/xapi-idl/lib_test/dune index 0806453c035..1b1e8193ca7 100644 --- a/ocaml/xapi-idl/lib_test/dune +++ b/ocaml/xapi-idl/lib_test/dune @@ -18,11 +18,22 @@ ) ) +(test + (name device_number_test) + (package xapi-idl) + (modules device_number_test) + (libraries + alcotest + fmt + xapi-idl.xen.interface.types + ) +) + (test (name test) (modes exe) (package xapi-idl) - (modules (:standard \ idl_test_common guard_interfaces_test)) + (modules (:standard \ idl_test_common guard_interfaces_test device_number_test)) (deps (source_tree test_data)) (libraries alcotest @@ -47,7 +58,6 @@ xapi-idl.v6 xapi-idl.xen xapi-idl.xen.interface - xapi-idl.xen.interface.types xapi-log ) (preprocess (per_module ((pps ppx_deriving_rpc) Task_server_test Updates_test)))) diff --git a/ocaml/xapi-idl/lib_test/test.ml b/ocaml/xapi-idl/lib_test/test.ml index 712ac7a4640..bba5c5f6055 100644 --- a/ocaml/xapi-idl/lib_test/test.ml +++ b/ocaml/xapi-idl/lib_test/test.ml @@ -17,7 +17,6 @@ let () = ; ("Syslog tests", Syslog_test.tests) ; ("Cohttp_posix_io tests", Http_test.tests) ; ("Xenops_interface tests", Xen_test.tests) - ; ("Device_number tests", Device_number_test.tests) ; ("xcp-config-file tests", Config_file_test.tests) (* "xcp-channel-test", Channel_test.tests; TODO: Turn these on when the code works. *) diff --git a/ocaml/xapi-idl/xen/device_number.ml b/ocaml/xapi-idl/xen/device_number.ml index 2577c8a54ad..66bee601edb 100644 --- a/ocaml/xapi-idl/xen/device_number.ml +++ b/ocaml/xapi-idl/xen/device_number.ml @@ -1,63 +1,51 @@ type bus_type = Xen | Scsi | Floppy | Ide [@@deriving rpcty] -type spec = bus_type * int * int [@@deriving rpcty] +type t = bus_type * int * int [@@deriving rpcty] -type t = spec [@@deriving rpcty] +let bus_type_to_string = function + | Xen -> + "Xen" + | Scsi -> + "Scsi" + | Floppy -> + "Floppy" + | Ide -> + "Ide" -let to_debug_string = function - | Xen, disk, partition -> - Printf.sprintf "Xen(%d, %d)" disk partition - | Scsi, disk, partition -> - Printf.sprintf "Scsi(%d, %d)" disk partition - | Floppy, disk, partition -> - Printf.sprintf "Floppy(%d, %d)" disk partition - | Ide, disk, partition -> - Printf.sprintf "Ide(%d, %d)" disk partition +let to_debug_string (bus, disk, partition) = + Printf.sprintf "%s(%d, %d)" (bus_type_to_string bus) disk partition + +let ( let* ) = Option.bind (* ocamlp4-friendly operators *) let ( <| ) = ( lsl ) let ( >| ) = ( lsr ) -let int_of_string x = - try int_of_string x - with _ -> failwith (Printf.sprintf "int_of_string [%s]" x) - (* If this is true then we will use the deprecated (linux-specific) IDE encodings for disks > 3 *) let use_deprecated_ide_encoding = true -let make (x : spec) : t = - let max_xen = ((1 <| 20) - 1, 15) in - let max_scsi = (15, 15) in - let max_ide = if use_deprecated_ide_encoding then (19, 63) else (3, 63) in - let max_floppy = (2, 0) in - let assert_in_range description (disk_limit, partition_limit) (disk, partition) - = - if disk < 0 || disk > disk_limit then - failwith - (Printf.sprintf "%s disk number out of range 0 <= %d <= %d" description - disk disk_limit - ) ; - if partition < 0 || partition > partition_limit then - failwith - (Printf.sprintf "%s partition number out of range 0 <= %d <= %d" - description partition partition_limit - ) +let max_of = function + | Xen -> + ((1 <| 20) - 1, 15) + | Scsi -> + (15, 15) + | Floppy -> + (2, 0) + | Ide -> + if use_deprecated_ide_encoding then (19, 63) else (3, 63) + +let make bus ~disk ~partition = + let in_range ~min ~max n = min <= n && n <= max in + let all_in_range (disk_max, partition_max) ~disk ~partition = + in_range ~min:0 ~max:disk_max disk + && in_range ~min:0 ~max:partition_max partition in - ( match x with - | Xen, disk, partition -> - assert_in_range "xen" max_xen (disk, partition) - | Scsi, disk, partition -> - assert_in_range "scsi" max_scsi (disk, partition) - | Floppy, disk, partition -> - assert_in_range "floppy" max_floppy (disk, partition) - | Ide, disk, partition -> - assert_in_range "ide" max_ide (disk, partition) - ) ; - x - -let spec (x : t) : spec = x + if all_in_range (max_of bus) ~disk ~partition then + Some (bus, disk, partition) + else + None let ( || ) = ( lor ) @@ -103,8 +91,6 @@ let of_xenstore_int x = if idx < 0 then failwith (Printf.sprintf "Unknown device number: %d" x) ; (Ide, (x >| 6 && ((1 <| 2) - 1)) + (idx * 2), x && ((1 <| 6) - 1)) -type xenstore_key = int - let to_xenstore_key x = to_xenstore_int x let of_xenstore_key x = of_xenstore_int x @@ -119,112 +105,119 @@ let rec string_of_int26 x = let low' = String.make 1 (char_of_int (low + int_of_char 'a' - 1)) in high' ^ low' -module String = struct - include String - - let fold_right f string accu = - let accu = ref accu in - for i = length string - 1 downto 0 do - accu := f string.[i] !accu - done ; - !accu - - let explode string = fold_right (fun h t -> h :: t) string [] - - let implode list = concat "" (List.map (String.make 1) list) -end - -(** Convert a linux device string back into an integer *) -let int26_of_string x = - let ints = - List.map (fun c -> int_of_char c - int_of_char 'a' + 1) (String.explode x) - in - List.fold_left (fun acc x -> (acc * 26) + x) 0 ints - 1 - -let to_linux_device = +let to_linux_prefix = function + | Xen -> + "xvd" + | Scsi -> + "sd" + | Floppy -> + "fd" + | Ide -> + "xvd" + +let to_linux_device (bus, disk, part) = let p x = if x = 0 then "" else string_of_int x in - function - | Xen, disk, part -> - Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) - | Scsi, disk, part -> - Printf.sprintf "sd%s%s" (string_of_int26 disk) (p part) - | Floppy, disk, part -> - Printf.sprintf "fd%s%s" (string_of_int26 disk) (p part) - | Ide, disk, part -> - Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) + let bus = to_linux_prefix bus in + Printf.sprintf "%s%s%s" bus (string_of_int26 disk) (p part) let of_linux_device x = - let letter c = 'a' <= c && c <= 'z' in - let digit c = '0' <= c && c <= '9' in - let take f x = - let rec inner f acc = function - | x :: xs -> - if f x then inner f (x :: acc) xs else (List.rev acc, x :: xs) - | [] -> - (List.rev acc, []) + let open Astring in + let b26_to_int x = + (* Convert a linux device string back into an integer *) + (* Assumes all characters are in range *) + let b26 = + String.Sub.to_string x + |> Stdlib.String.to_seq + |> Seq.map (fun c -> int_of_char c - int_of_char 'a' + 1) + |> Seq.fold_left (fun acc x -> (acc * 26) + x) 0 in - inner f [] x + b26 - 1 + in + + let parse_int x = + match String.Sub.span ~min:1 ~sat:Char.Ascii.is_digit x with + | i, s -> + Option.map (fun i -> (i, s)) (String.Sub.to_int i) + in + let parse_b26 x = + match String.Sub.span ~min:1 ~sat:Char.Ascii.is_lower x with + | b, s -> + (b26_to_int b, s) in (* Parse a string "abc123" into x, y where x is "abc" interpreted as base-26 and y is 123 *) let parse_b26_int x = - let d, p = take letter x in - let d' = int26_of_string (String.implode d) in - let p' = if p = [] then 0 else int_of_string (String.implode p) in - (d', p') + let pre, x = parse_b26 x in + if String.Sub.is_empty x then + Some (pre, 0) + else + let* post, x = parse_int x in + if not (String.Sub.is_empty x) then + None + else + Some (pre, post) in (* Parse a string "123p456" into x, y where x = 123 and y = 456 *) let parse_int_p_int x = - let d, rest = take digit x in - match rest with - | 'p' :: rest -> - let p, _ = take digit rest in - (int_of_string (String.implode d), int_of_string (String.implode p)) - | [] -> - (int_of_string (String.implode d), 0) - | _ -> - failwith - (Printf.sprintf "expected digit+ p digit+ got: %s" (String.implode x)) + let parse_p x = + match String.Sub.head x with + | Some 'p' -> + Some (String.Sub.tail x) + | Some _ | None -> + None + in + let* pre, x = parse_int x in + if String.Sub.is_empty x then + Some (pre, 0) + else + let* x = parse_p x in + let* post, x = parse_int x in + if not (String.Sub.is_empty x) then + None + else + Some (pre, post) in - match String.explode x with - | 'x' :: 'v' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - (Xen, disk, partition) - | 's' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - (Scsi, disk, partition) - | 'f' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - (Floppy, disk, partition) - | 'h' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - (Ide, disk, partition) - | 'd' :: rest -> - let disk, partition = parse_int_p_int rest in - (Xen, disk, partition) - | _ -> - failwith (Printf.sprintf "Failed to parse device name: %s" x) + if String.is_prefix ~affix:"xvd" x then + let rest = String.sub_with_range ~first:3 x in + let* disk, partition = parse_b26_int rest in + Some (Xen, disk, partition) + else if String.is_prefix ~affix:"sd" x then + let rest = String.sub_with_range ~first:2 x in + let* disk, partition = parse_b26_int rest in + Some (Scsi, disk, partition) + else if String.is_prefix ~affix:"fd" x then + let rest = String.sub_with_range ~first:2 x in + let* disk, partition = parse_b26_int rest in + Some (Floppy, disk, partition) + else if String.is_prefix ~affix:"hd" x then + let rest = String.sub_with_range ~first:2 x in + let* disk, partition = parse_b26_int rest in + Some (Ide, disk, partition) + else if String.is_prefix ~affix:"d" x then + let rest = String.sub_with_range ~first:1 x in + let* disk, partition = parse_int_p_int rest in + Some (Xen, disk, partition) + else + None let upgrade_linux_device x = - match String.explode x with - | 'h' :: 'd' :: rest -> - "xvd" ^ String.implode rest - | _ -> - x - -type disk_number = int - -let to_disk_number = function - | Xen, disk, _ -> - disk - | Scsi, disk, _ -> - disk - | Floppy, disk, _ -> - disk - | Ide, disk, _ -> - disk - -let of_disk_number hvm n = if hvm && n < 4 then (Ide, n, 0) else (Xen, n, 0) - -let of_string hvm name = - try of_disk_number hvm (int_of_string name) with _ -> of_linux_device name + if Astring.String.is_prefix ~affix:"hd" x then + let rest = Astring.String.with_range ~first:2 x in + "xvd" ^ rest + else + x + +let disk (_, disk, _) = disk + +let bus (bus, _, _) = bus + +let of_disk_number hvm n = + let bus = if hvm && n < 4 then Ide else Xen in + make bus ~disk:n ~partition:0 + +let of_string ~hvm name = + let maybe_disk = + let* n = int_of_string_opt name in + of_disk_number hvm n + in + match maybe_disk with None -> of_linux_device name | dev -> dev diff --git a/ocaml/xapi-idl/xen/device_number.mli b/ocaml/xapi-idl/xen/device_number.mli index 4b5c431cd62..ffcfcbd05e9 100644 --- a/ocaml/xapi-idl/xen/device_number.mli +++ b/ocaml/xapi-idl/xen/device_number.mli @@ -5,23 +5,22 @@ type bus_type = | Floppy (** A floppy bus *) | Ide (** An IDE bus *) -(** A specification for a device number. There are more valid specifications - than valid device numbers because of hardware and/or protocol limits. *) -type spec = bus_type * int * int - (** A valid device number *) -type t +type t = private bus_type * int * int val typ_of : t Rpc.Types.typ -val make : spec -> t -(** [make spec] validates a given device number specification [spec] and returns - a device number *) +val make : bus_type -> disk:int -> partition:int -> t option +(** [make bus ~disk ~partition] returns [Some device] when the parameters + define a valid device number, or [None] otherwise. *) + +val disk : t -> int +(** [disk t] returns the corresponding non-negative disk number *) -val spec : t -> spec -(** [spec t] takes a [t] and returns the corresponding [spec] *) +val bus : t -> bus_type +(** [bus t] returns the bus type of the device *) -val of_string : bool -> string -> t +val of_string : hvm:bool -> string -> t option (** [of_string hvm name] returns the interface which best matches the [name] by applying the policy: first check if it is a disk_number, else fall back to a linux_device for backwards compatability *) @@ -33,26 +32,19 @@ val to_linux_device : t -> string (** [to_linux_device i] returns a possible linux string representation of interface [i] *) -val of_linux_device : string -> t +val of_linux_device : string -> t option (** [of_linux_device x] returns the interface corresponding to string [x] *) val upgrade_linux_device : string -> string (** [upgrade_linux_device x] upgrades hd* style device names to xvd* and leaves all other device names unchanged. *) -type xenstore_key = int - -val to_xenstore_key : t -> xenstore_key +val to_xenstore_key : t -> int (** [to_xenstore_key i] returns the xenstore key from interface [i] *) -val of_xenstore_key : xenstore_key -> t +val of_xenstore_key : int -> t (** [of_xenstore_key key] returns an interface from a xenstore key *) -type disk_number = int - -val to_disk_number : t -> disk_number -(** [to_disk_number i] returns the corresponding non-negative disk number *) - -val of_disk_number : bool -> disk_number -> t +val of_disk_number : bool -> int -> t option (** [of_disk_number hvm n] returns the interface corresponding to disk number [n] which depends on whether the guest is [hvm] or not. *) diff --git a/ocaml/xapi-idl/xen/dune b/ocaml/xapi-idl/xen/dune index c2352eff385..7f19e4a2714 100644 --- a/ocaml/xapi-idl/xen/dune +++ b/ocaml/xapi-idl/xen/dune @@ -3,6 +3,7 @@ (public_name xapi-idl.xen.interface.types) (modules xenops_types device_number) (libraries + astring result rpclib.core rresult diff --git a/ocaml/xapi/dbsync_slave.ml b/ocaml/xapi/dbsync_slave.ml index 84af29bbf7f..32ee7d44d21 100644 --- a/ocaml/xapi/dbsync_slave.ml +++ b/ocaml/xapi/dbsync_slave.ml @@ -69,7 +69,7 @@ let get_start_time () = debug "Calculating boot time..." ; let now = Unix.time () in let uptime = Unixext.string_of_file "/proc/uptime" in - let uptime = String.strip String.isspace uptime in + let uptime = String.trim uptime in let uptime = String.split ' ' uptime in let uptime = List.hd uptime in let uptime = float_of_string uptime in diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index 02e5545d16e..a307eb48bdd 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -558,8 +558,17 @@ let of_vbd ~__context ~vbd ~domid = Helpers.has_qemu ~__context ~self:(Db.VBD.get_VM ~__context ~self:vbd) in let dbg = Context.get_task_id __context in - let device_number = Device_number.of_string has_qemu userdevice in - let device = Device_number.to_linux_device device_number in + let device = + Option.map Device_number.to_linux_device + (Device_number.of_string ~hvm:has_qemu userdevice) + in + let device = + match device with + | Some dev -> + dev + | None -> + raise Api_errors.(Server_error (invalid_device, [userdevice])) + in let dp = datapath_of_vbd ~domid ~device in ( rpc , Ref.string_of dbg diff --git a/ocaml/xapi/vbdops.ml b/ocaml/xapi/vbdops.ml index 18e1f8413b9..0b9494e6f9e 100644 --- a/ocaml/xapi/vbdops.ml +++ b/ocaml/xapi/vbdops.ml @@ -24,15 +24,15 @@ module L = Debug.Make (struct let name = "license" end) (** Thrown if an empty VBD which isn't a CDROM is attached to an HVM guest *) exception Only_CD_VBDs_may_be_empty -let translate_vbd_device vbd_ref name is_hvm = - try - let i = Device_number.of_string is_hvm name in - debug "VBD device name %s interpreted as %s (hvm = %b)" name - (Device_number.to_debug_string i) - is_hvm ; - i - with _ -> - raise - (Api_errors.Server_error - (Api_errors.illegal_vbd_device, [Ref.string_of vbd_ref; name]) - ) +let translate_vbd_device vbd_ref name hvm = + match Device_number.of_string ~hvm name with + | Some i -> + debug "VBD device name %s interpreted as %s (hvm = %b)" name + (Device_number.to_debug_string i) + hvm ; + i + | None -> + raise + (Api_errors.Server_error + (Api_errors.illegal_vbd_device, [Ref.string_of vbd_ref; name]) + ) diff --git a/ocaml/xapi/xapi_dr_task.ml b/ocaml/xapi/xapi_dr_task.ml index 6766775a5f1..415a4e45c8f 100644 --- a/ocaml/xapi/xapi_dr_task.ml +++ b/ocaml/xapi/xapi_dr_task.ml @@ -31,7 +31,7 @@ type sr_probe_sr = {uuid: string; name_label: string; name_description: string} (* Attempt to parse a key/value pair from XML. *) let parse_kv = function | Xml.Element (key, _, [Xml.PCData v]) -> - (key, String.strip String.isspace v) (* remove whitespace at both ends *) + (key, String.trim v) | Xml.Element (key, _, []) -> (key, "") | _ -> diff --git a/ocaml/xapi/xapi_templates_install.ml b/ocaml/xapi/xapi_templates_install.ml index c22e51bf0ae..fc126b588bb 100644 --- a/ocaml/xapi/xapi_templates_install.ml +++ b/ocaml/xapi/xapi_templates_install.ml @@ -34,10 +34,7 @@ let is_whitelisted script = | _ -> false in - let safe_str str = - List.fold_left ( && ) true - (List.map safe_char (Xapi_stdext_std.Xstringext.String.explode str)) - in + let safe_str str = String.for_all safe_char str in (* make sure the script prefix is the allowed dom0 directory *) Filename.dirname script = !Xapi_globs.post_install_scripts_dir (* avoid ..-style attacks and other weird things *) diff --git a/ocaml/xapi/xapi_vbd.ml b/ocaml/xapi/xapi_vbd.ml index 1da2516d809..5e1b31c5bee 100644 --- a/ocaml/xapi/xapi_vbd.ml +++ b/ocaml/xapi/xapi_vbd.ml @@ -215,24 +215,23 @@ let create ~__context ~vM ~vDI ~device ~userdevice ~bootable ~mode ~_type ) ) in - if - (not (valid_device userdevice ~_type)) - || (userdevice = "autodetect" && possibilities = []) - then - raise - (Api_errors.Server_error (Api_errors.invalid_device, [userdevice])) ; + let raise_invalid_device () = + raise Api_errors.(Server_error (invalid_device, [userdevice])) + in + if not (valid_device userdevice ~_type) then + raise_invalid_device () ; (* Resolve the "autodetect" into a fixed device name now *) let userdevice = - if userdevice = "autodetect" then - match _type with - (* already checked for [] above *) - | `Floppy -> - Device_number.to_linux_device (List.hd possibilities) - | `CD | `Disk -> - string_of_int - (Device_number.to_disk_number (List.hd possibilities)) - else + if userdevice <> "autodetect" then userdevice + else + match (_type, possibilities) with + | _, [] -> + raise_invalid_device () + | `Floppy, dev :: _ -> + Device_number.to_linux_device dev + | (`CD | `Disk), dev :: _ -> + string_of_int (Device_number.disk dev) in let uuid = Uuidx.make () in let ref = Ref.make () in diff --git a/ocaml/xapi/xapi_vbd_helpers.ml b/ocaml/xapi/xapi_vbd_helpers.ml index 6226b26c34e..1285c740c27 100644 --- a/ocaml/xapi/xapi_vbd_helpers.ml +++ b/ocaml/xapi/xapi_vbd_helpers.ml @@ -376,38 +376,17 @@ let clear_current_operations ~__context ~self = (** Check if the device string has the right form *) let valid_device dev ~_type = - let check_rest rest = - (* checks the rest of the device name = [] is ok, or a number is ok *) - if rest = [] then - true - else - try - ignore (int_of_string (String.implode rest)) ; - true - with _ -> false - in dev = "autodetect" + || Option.is_none (Device_number.of_string dev ~hvm:false) || - match String.explode dev with - | 's' :: 'd' :: 'a' .. 'p' :: rest -> - check_rest rest - | 'x' :: 'v' :: 'd' :: 'a' .. 'p' :: rest -> - check_rest rest - | 'h' :: 'd' :: 'a' .. 'p' :: rest -> - check_rest rest - | 'f' :: 'd' :: 'a' .. 'b' :: rest -> - check_rest rest - (* QEMU only supports up to 2 floppy drives, hence fda or fdb *) + match _type with + | `Floppy -> + false | _ -> ( - match _type with - | `Floppy -> - false - | _ -> ( - try - let n = int_of_string dev in - n >= 0 || n < 16 - with _ -> false - ) + try + let n = int_of_string dev in + n >= 0 || n < 16 + with _ -> false ) (** VBD.destroy doesn't require any interaction with xen *) diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 8819d393170..eff46f84b93 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1206,7 +1206,7 @@ let get_possible_hosts ~__context ~vm = let get_allowed_VBD_devices ~__context ~vm = List.map - (fun d -> string_of_int (Device_number.to_disk_number d)) + (fun d -> string_of_int (Device_number.disk d)) (snd @@ allowed_VBD_devices ~__context ~vm ~_type:`Disk) let get_allowed_VIF_devices = allowed_VIF_devices diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index c715303b836..88590dc195b 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -1284,7 +1284,7 @@ let set_HVM_shadow_multiplier ~__context ~self ~value = let inclusive_range a b = List.init (b - a + 1) (fun k -> a + k) let vbd_inclusive_range hvm a b = - List.map (Device_number.of_disk_number hvm) (inclusive_range a b) + List.filter_map (Device_number.of_disk_number hvm) (inclusive_range a b) let vif_inclusive_range a b = List.map string_of_int (inclusive_range a b) @@ -1302,8 +1302,8 @@ let allowed_VBD_devices_PV = vbd_inclusive_range false 0 254 let allowed_VBD_devices_control_domain = vbd_inclusive_range false 0 255 let allowed_VBD_devices_HVM_floppy = - List.map - (fun x -> Device_number.make (Device_number.Floppy, x, 0)) + List.filter_map + (fun x -> Device_number.(make Floppy ~disk:x ~partition:0)) (inclusive_range 0 1) let allowed_VIF_devices_HVM = vif_inclusive_range 0 6 @@ -1314,8 +1314,8 @@ let allowed_VIF_devices_PV = vif_inclusive_range 0 6 represent possible interpretations of [s]. *) let possible_VBD_devices_of_string s = (* NB userdevice fields are arbitrary strings and device fields may be "" *) - let parse hvm x = try Some (Device_number.of_string hvm x) with _ -> None in - Listext.List.unbox_list [parse true s; parse false s] + let parse hvm x = Device_number.of_string ~hvm x in + List.filter_map Fun.id [parse true s; parse false s] (** [all_used_VBD_devices __context self] returns a list of Device_number.t which are considered to be already in-use in the VM *) diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index cb1932aab0a..dfb2b666205 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -555,31 +555,37 @@ module MD = struct | `pv_in_pvh | `pv | `pvh | `unspecified -> false in - let device_number = Device_number.of_string hvm vbd.API.vBD_userdevice in + let device_number = + match Device_number.of_string ~hvm vbd.API.vBD_userdevice with + | Some dev -> + dev + | None -> + raise + Api_errors.(Server_error (invalid_device, [vbd.API.vBD_userdevice])) + in let open Vbd in let ty = vbd.API.vBD_qos_algorithm_type in let params = vbd.API.vBD_qos_algorithm_params in let qos_class params = - if List.mem_assoc "class" params then - match List.assoc "class" params with - | "highest" -> - Highest - | "high" -> - High - | "normal" -> - Normal - | "low" -> - Low - | "lowest" -> - Lowest - | s -> ( - try Other (int_of_string s) - with _ -> - warn "Unknown VBD QoS scheduler class (try 'high' 'low' 'normal')" ; - Normal - ) - else - Normal + match List.assoc_opt "class" params with + | Some "highest" -> + Highest + | Some "high" -> + High + | Some "normal" -> + Normal + | Some "low" -> + Low + | Some "lowest" -> + Lowest + | Some s -> ( + try Other (int_of_string s) + with _ -> + warn "Unknown VBD QoS scheduler class (try 'high' 'low' 'normal')" ; + Normal + ) + | None -> + Normal in let qos_scheduler params = try @@ -2459,18 +2465,16 @@ let update_vbd ~__context (id : string * string) = in let linux_device = snd id in let device_number = Device_number.of_linux_device linux_device in - (* only try matching against disk number if the device is not a floppy (as "0" shouldn't match "fda") *) - let disk_number = - match Device_number.spec device_number with - | Device_number.Ide, _, _ | Device_number.Xen, _, _ -> - Some - (device_number - |> Device_number.to_disk_number - |> string_of_int - ) + let disk_of dev = + (* only try matching against disk number if the device is not a + floppy (as "0" shouldn't match "fda") *) + match Device_number.bus dev with + | Ide | Xen -> + Some (string_of_int Device_number.(disk dev)) | _ -> None in + let disk_number = Option.bind device_number disk_of in debug "VM %s VBD userdevices = [ %s ]" (fst id) (String.concat "; " (List.map (fun (_, r) -> r.API.vBD_userdevice) vbdrs) diff --git a/ocaml/xapi/xha_interface.ml b/ocaml/xapi/xha_interface.ml index 608ae9a64a2..53be303e04c 100644 --- a/ocaml/xapi/xha_interface.ml +++ b/ocaml/xapi/xha_interface.ml @@ -40,9 +40,9 @@ let first_xml_element_with_name elements name = are stripped of leading and trailing whitespace. *) let hash_table_entry_of_leaf_xml_element = function | Xml.Element (name, _, Xml.PCData value :: _) -> - Some (String.strip String.isspace name, String.strip String.isspace value) + Some (String.trim name, String.trim value) | Xml.Element (name, _, []) -> - Some (String.strip String.isspace name, "") + Some (String.trim name, "") | _ -> None diff --git a/ocaml/xapi/xmlrpc_sexpr.ml b/ocaml/xapi/xmlrpc_sexpr.ml index 4e394fdb697..d241491cdc3 100644 --- a/ocaml/xapi/xmlrpc_sexpr.ml +++ b/ocaml/xapi/xmlrpc_sexpr.ml @@ -41,7 +41,7 @@ let xmlrpc_to_sexpr (root : xml) = | _, [] -> [] | _, PCData text :: _ -> - let text = String.strip String.isspace text in + let text = String.trim text in [SExpr.String text] (* empty s have default value '' *) | h, Element ("value", _, []) :: siblings -> @@ -69,7 +69,7 @@ let xmlrpc_to_sexpr (root : xml) = (*ignore incorrect member*) (* any other element *) | h, Element (tag, _, children) :: siblings -> - let tag = String.strip String.isspace tag in + let tag = String.trim tag in let mytag = SExpr.String tag in let (mychildren : SExpr.t list) = visit (h + 1) children in let anode = SExpr.Node (mytag :: mychildren) in diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index 5ac6100669c..9658650699f 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -223,20 +223,30 @@ type disk_info = { let parse_disk_info x = match Re.Str.split_delim (Re.Str.regexp "[,]") x with | [source; device_number; rw] -> - let ty, device_number, device_number' = + let maybe_device = match Re.Str.split_delim (Re.Str.regexp "[:]") device_number with | [x] -> - (Vbd.Disk, x, Device_number.of_string false x) + Some (Vbd.Disk, x) | [x; "floppy"] -> - (Vbd.Floppy, x, Device_number.of_string false x) + Some (Vbd.Floppy, x) | [x; "cdrom"] -> - (Vbd.CDROM, x, Device_number.of_string false x) + Some (Vbd.CDROM, x) | _ -> + None + in + let get_position (ty, id) = + Option.map (fun x -> (ty, id, x)) (Device_number.of_string ~hvm:false id) + in + let ty, device_number, position = + match Option.bind maybe_device get_position with + | None -> Printf.fprintf stderr "Failed to understand disk name '%s'. It should be 'xvda' or \ 'hda:cdrom'\n" device_number ; exit 2 + | Some disk -> + disk in let mode = match String.lowercase_ascii rw with @@ -250,7 +260,7 @@ let parse_disk_info x = exit 2 in let backend = parse_source source in - {id= device_number; ty; position= device_number'; mode; disk= backend} + {id= device_number; ty; position; mode; disk= backend} | _ -> Printf.fprintf stderr "I don't understand '%s'. Please use 'phy:path,xvda,w'\n" x ; diff --git a/ocaml/xenopsd/lib/xenops_server_simulator.ml b/ocaml/xenopsd/lib/xenops_server_simulator.ml index c12a929392f..c5123641978 100644 --- a/ocaml/xenopsd/lib/xenops_server_simulator.ml +++ b/ocaml/xenopsd/lib/xenops_server_simulator.ml @@ -240,12 +240,20 @@ let add_vbd (vm : Vm.id) (vbd : Vbd.t) () = debug "add_vbd" ; let d = DB.read_exn vm in (* there shouldn't be any None values in here anyway *) - let ps = List.map (fun vbd -> vbd.Vbd.position) d.Domain.vbds in - assert (not (List.mem None ps)) ; - let dns = List.map Option.get ps in - let indices = List.map Device_number.to_disk_number dns in + let dns = List.filter_map (fun vbd -> vbd.Vbd.position) d.Domain.vbds in + let indices = List.map Device_number.disk dns in let next_index = List.fold_left max (-1) indices + 1 in let next_dn = Device_number.of_disk_number d.Domain.hvm next_index in + let next_dn = + match next_dn with + | None -> + raise + (Xenopsd_error + (Internal_error "Ran out of available device numbers for the vbd") + ) + | Some dn -> + dn + in let this_dn = Option.value ~default:next_dn vbd.Vbd.position in if List.mem this_dn dns then ( debug "VBD.plug %s.%s: Already exists" (fst vbd.Vbd.id) (snd vbd.Vbd.id) ; diff --git a/ocaml/xenopsd/xc/device.ml b/ocaml/xenopsd/xc/device.ml index 20f2405a7e7..3f6da8152a6 100644 --- a/ocaml/xenopsd/xc/device.ml +++ b/ocaml/xenopsd/xc/device.ml @@ -585,17 +585,18 @@ module Vbd_Common = struct (fun x -> x.frontend.devid |> Device_number.of_xenstore_key - |> Device_number.spec - |> function - | _, disk, _ -> - disk + |> Device_number.disk ) (Device_common.list_frontends ~xs domid) in let next = List.fold_left max 0 disks + 1 in let open Device_number in let bus_type = if hvm && next < 4 then Ide else Xen in - (bus_type, next, 0) + match make bus_type ~disk:next ~partition:0 with + | Some x -> + x + | None -> + raise (Xenopsd_error (Internal_error "Unable to decide slot for vbd")) type t = { mode: mode @@ -620,7 +621,7 @@ module Vbd_Common = struct | Some x -> x | None -> - make (free_device ~xs hvm domid) + free_device ~xs hvm domid in let devid = to_xenstore_key device_number in let device = @@ -2986,7 +2987,11 @@ module Backend = struct qemu-upstream-compat backend *) module Vbd = struct let cd_of devid = - devid |> Device_number.of_xenstore_key |> Device_number.spec |> function + match + ( Device_number.of_xenstore_key devid + :> Device_number.bus_type * int * int + ) + with | Ide, 0, _ -> "ide0-cd0" | Ide, 1, _ -> diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index 44d4e4e942c..ee4524cf781 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -3774,14 +3774,14 @@ module VBD = struct let qemu_domid = this_domid ~xs in let qemu_frontend = let maybe_create_vbd_frontend () = - let index = Device_number.to_disk_number device_number in + let index = Device_number.disk device_number in match vbd.Vbd.backend with | None -> Some (index, Empty) | Some _ -> Some (index, create_vbd_frontend ~xc ~xs task qemu_domid vdi) in - match Device_number.spec device_number with + match (device_number :> Device_number.bus_type * int * int) with | Ide, n, _ when 0 <= n && n < 4 -> maybe_create_vbd_frontend () | Floppy, n, _ when 0 <= n && n < 2 -> diff --git a/quality-gate.sh b/quality-gate.sh index 8f761718627..e4a8379f214 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=302 + N=300 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages" @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=513 + N=512 # do not count ml files from the tests in ocaml/{tests/perftest/quicktest} MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) diff --git a/xapi-idl.opam b/xapi-idl.opam index d6e7a390671..1af2c2bd516 100644 --- a/xapi-idl.opam +++ b/xapi-idl.opam @@ -36,6 +36,7 @@ depends: [ "xapi-open-uri" "xapi-stdext-date" "xapi-stdext-pervasives" + "xapi-stdext-std" "xapi-stdext-threads" "xapi-tracing" "xapi-inventory" diff --git a/xapi-idl.opam.template b/xapi-idl.opam.template index 6c879e68b97..b07bec320ec 100644 --- a/xapi-idl.opam.template +++ b/xapi-idl.opam.template @@ -34,6 +34,7 @@ depends: [ "xapi-open-uri" "xapi-stdext-date" "xapi-stdext-pervasives" + "xapi-stdext-std" "xapi-stdext-threads" "xapi-tracing" "xapi-inventory" From bc511a3f31cc260f7be000651dcae3dc9a067c61 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 24 May 2024 11:42:54 +0100 Subject: [PATCH 072/157] xapi-idl: do not use custom operators for bit manipulations Use the standard ones instead Signed-off-by: Pau Ruiz Safont --- ocaml/xapi-idl/xen/device_number.ml | 35 +++++++++++++---------------- 1 file changed, 15 insertions(+), 20 deletions(-) diff --git a/ocaml/xapi-idl/xen/device_number.ml b/ocaml/xapi-idl/xen/device_number.ml index 66bee601edb..31943b7e123 100644 --- a/ocaml/xapi-idl/xen/device_number.ml +++ b/ocaml/xapi-idl/xen/device_number.ml @@ -17,18 +17,13 @@ let to_debug_string (bus, disk, partition) = let ( let* ) = Option.bind -(* ocamlp4-friendly operators *) -let ( <| ) = ( lsl ) - -let ( >| ) = ( lsr ) - (* If this is true then we will use the deprecated (linux-specific) IDE encodings for disks > 3 *) let use_deprecated_ide_encoding = true let max_of = function | Xen -> - ((1 <| 20) - 1, 15) + ((1 lsl 20) - 1, 15) | Scsi -> (15, 15) | Floppy -> @@ -55,31 +50,30 @@ let deprecated_ide_table = standard_ide_table @ [33; 34; 56; 57; 88; 89; 90; 91] let to_xenstore_int = function | Xen, disk, partition when disk < 16 -> - 202 <| 8 || disk <| 4 || partition + (202 lsl 8) || (disk lsl 4) || partition | Xen, disk, partition -> - 1 <| 28 || disk <| 8 || partition + (1 lsl 28) || (disk lsl 8) || partition | Scsi, disk, partition -> - 8 <| 8 || disk <| 4 || partition + (8 lsl 8) || (disk lsl 4) || partition | Floppy, disk, partition -> - 203 <| 8 || disk <| 4 || partition + (203 lsl 8) || (disk lsl 4) || partition | Ide, disk, partition -> let m = List.nth deprecated_ide_table (disk / 2) in let n = disk - (disk / 2 * 2) in (* NB integers behave differently to reals *) - m <| 8 || n <| 6 || partition + (m lsl 8) || (n lsl 6) || partition let of_xenstore_int x = - let ( && ) = ( land ) in - if (x && 1 <| 28) <> 0 then - (Xen, x >| 8 && ((1 <| 20) - 1), x && ((1 <| 8) - 1)) + if x land (1 lsl 28) <> 0 then + (Xen, (x lsr 8) land ((1 lsl 20) - 1), x land ((1 lsl 8) - 1)) else - match x >| 8 with + match x lsr 8 with | 202 -> - (Xen, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + (Xen, (x lsr 4) land ((1 lsl 4) - 1), x land ((1 lsl 4) - 1)) | 8 -> - (Scsi, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + (Scsi, (x lsr 4) land ((1 lsl 4) - 1), x land ((1 lsl 4) - 1)) | 203 -> - (Floppy, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + (Floppy, (x lsr 4) land ((1 lsl 4) - 1), x land ((1 lsl 4) - 1)) | n -> let idx = snd @@ -88,8 +82,9 @@ let of_xenstore_int x = (0, -1) deprecated_ide_table ) in - if idx < 0 then failwith (Printf.sprintf "Unknown device number: %d" x) ; - (Ide, (x >| 6 && ((1 <| 2) - 1)) + (idx * 2), x && ((1 <| 6) - 1)) + let disk = ((x lsr 6) land ((1 lsl 2) - 1)) + (idx * 2) in + let partition = x land ((1 lsl 6) - 1) in + (Ide, disk, partition) let to_xenstore_key x = to_xenstore_int x From 4b691d1868aff06ebe129114ae78336258f7fde6 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 24 May 2024 12:24:34 +0100 Subject: [PATCH 073/157] xapi-idl: Refactor out find_index and add it to Listext The function is implemented using foldleft using a weird form, use a recursive form instead. Unfortunately the function was introduced in OCaml 5.1, so it had to be moved to Listext so it can be reused. Signed-off-by: Pau Ruiz Safont --- .../libs/xapi-stdext/lib/xapi-stdext-std/listext.ml | 11 +++++++++++ .../libs/xapi-stdext/lib/xapi-stdext-std/listext.mli | 7 +++++++ ocaml/xapi-idl/xen/device_number.ml | 12 +++++++----- ocaml/xapi-idl/xen/dune | 1 + 4 files changed, 26 insertions(+), 5 deletions(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml index e89cefba3da..c290ab8e569 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml @@ -208,4 +208,15 @@ module List = struct let find_minimum compare = let min a b = if compare a b <= 0 then a else b in function [] -> None | x :: xs -> Some (List.fold_left min x xs) + + let find_index f l = + let rec loop i = function + | [] -> + None + | x :: _ when f x -> + Some i + | _ :: xs -> + loop (i + 1) xs + in + loop 0 l end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli index d836c751230..231c3891060 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli @@ -60,6 +60,13 @@ module List : sig the sort order of [cmp], or [None] if the list is empty. When two ore more elements match the lowest value, the left-most is returned. *) + val find_index : ('a -> bool) -> 'a list -> int option + (** [find_index f l] returns the position of the first element in [l] that + satisfies [f x]. If there is no such element, returns [None]. + + When using OCaml compilers 5.1 or later, please use the standard library + instead. *) + (** {1 Using indices to manipulate lists} *) val chop : int -> 'a list -> 'a list * 'a list diff --git a/ocaml/xapi-idl/xen/device_number.ml b/ocaml/xapi-idl/xen/device_number.ml index 31943b7e123..2233354b030 100644 --- a/ocaml/xapi-idl/xen/device_number.ml +++ b/ocaml/xapi-idl/xen/device_number.ml @@ -1,3 +1,5 @@ +module Listext = Xapi_stdext_std.Listext.List + type bus_type = Xen | Scsi | Floppy | Ide [@@deriving rpcty] type t = bus_type * int * int [@@deriving rpcty] @@ -76,11 +78,11 @@ let of_xenstore_int x = (Floppy, (x lsr 4) land ((1 lsl 4) - 1), x land ((1 lsl 4) - 1)) | n -> let idx = - snd - (List.fold_left - (fun (i, res) e -> (i + 1, if e = n then i else res)) - (0, -1) deprecated_ide_table - ) + match Listext.find_index (Int.equal n) deprecated_ide_table with + | Some idx -> + idx + | None -> + failwith (Printf.sprintf "Unknown device number: %d" x) in let disk = ((x lsr 6) land ((1 lsl 2) - 1)) + (idx * 2) in let partition = x land ((1 lsl 6) - 1) in diff --git a/ocaml/xapi-idl/xen/dune b/ocaml/xapi-idl/xen/dune index 7f19e4a2714..16ed23ecd22 100644 --- a/ocaml/xapi-idl/xen/dune +++ b/ocaml/xapi-idl/xen/dune @@ -11,6 +11,7 @@ sexplib0 threads xapi-idl + xapi-stdext-std ) (wrapped false) (preprocess (pps ppx_deriving_rpc ppx_sexp_conv))) From 57bb11e7b6f142e40587057713ecff30d72d5a85 Mon Sep 17 00:00:00 2001 From: Colin James Date: Wed, 31 Jul 2024 13:59:45 +0100 Subject: [PATCH 074/157] CP-50426: Factor out module signature prefix This stylistic change is shorter than alternatives. The actual intention is to ensure that Merlin doesn't get confused when jumping to definition. The previous behaviour is that Merlin jumps to the type definition rather than realising it ought to jump to the implementation being referred to inside the record. This commit should be squashed together with what follows. Signed-off-by: Colin James --- ocaml/xapi/authx.ml | 23 ++++++++++++----------- ocaml/xapi/extauth_plugin_ADpbis.ml | 23 ++++++++++++----------- ocaml/xapi/extauth_plugin_ADwinbind.ml | 23 ++++++++++++----------- 3 files changed, 36 insertions(+), 33 deletions(-) diff --git a/ocaml/xapi/authx.ml b/ocaml/xapi/authx.ml index 73224d31295..d0efeb64bea 100644 --- a/ocaml/xapi/authx.ml +++ b/ocaml/xapi/authx.ml @@ -337,15 +337,16 @@ module AuthX : Auth_signature.AUTH_MODULE = struct (* Implement the single value required for the module signature *) let methods = - { - Auth_signature.authenticate_username_password - ; Auth_signature.authenticate_ticket - ; Auth_signature.get_subject_identifier - ; Auth_signature.query_subject_information - ; Auth_signature.query_group_membership - ; Auth_signature.on_enable - ; Auth_signature.on_disable - ; Auth_signature.on_xapi_initialize - ; Auth_signature.on_xapi_exit - } + Auth_signature. + { + authenticate_username_password + ; authenticate_ticket + ; get_subject_identifier + ; query_subject_information + ; query_group_membership + ; on_enable + ; on_disable + ; on_xapi_initialize + ; on_xapi_exit + } end diff --git a/ocaml/xapi/extauth_plugin_ADpbis.ml b/ocaml/xapi/extauth_plugin_ADpbis.ml index dd14ab6df4c..b46364da946 100644 --- a/ocaml/xapi/extauth_plugin_ADpbis.ml +++ b/ocaml/xapi/extauth_plugin_ADpbis.ml @@ -1162,15 +1162,16 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct (* Implement the single value required for the module signature *) let methods = - { - Auth_signature.authenticate_username_password - ; Auth_signature.authenticate_ticket - ; Auth_signature.get_subject_identifier - ; Auth_signature.query_subject_information - ; Auth_signature.query_group_membership - ; Auth_signature.on_enable - ; Auth_signature.on_disable - ; Auth_signature.on_xapi_initialize - ; Auth_signature.on_xapi_exit - } + Auth_signature. + { + authenticate_username_password + ; authenticate_ticket + ; get_subject_identifier + ; query_subject_information + ; query_group_membership + ; on_enable + ; on_disable + ; on_xapi_initialize + ; on_xapi_exit + } end diff --git a/ocaml/xapi/extauth_plugin_ADwinbind.ml b/ocaml/xapi/extauth_plugin_ADwinbind.ml index bcfbd31e8e8..da3a1e0e4b3 100644 --- a/ocaml/xapi/extauth_plugin_ADwinbind.ml +++ b/ocaml/xapi/extauth_plugin_ADwinbind.ml @@ -1690,15 +1690,16 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct (* Implement the single value required for the module signature *) let methods = - { - Auth_signature.authenticate_username_password - ; Auth_signature.authenticate_ticket - ; Auth_signature.get_subject_identifier - ; Auth_signature.query_subject_information - ; Auth_signature.query_group_membership - ; Auth_signature.on_enable - ; Auth_signature.on_disable - ; Auth_signature.on_xapi_initialize - ; Auth_signature.on_xapi_exit - } + Auth_signature. + { + authenticate_username_password + ; authenticate_ticket + ; get_subject_identifier + ; query_subject_information + ; query_group_membership + ; on_enable + ; on_disable + ; on_xapi_initialize + ; on_xapi_exit + } end From 88271409b396927fca6560eaa8971f7e6935e45e Mon Sep 17 00:00:00 2001 From: Colin James Date: Wed, 31 Jul 2024 14:50:55 +0100 Subject: [PATCH 075/157] CP-50426: Propagate __context in Auth_signature Rewrites all functions in Auth_signature.t - the record type used by external authentication plugins - to take a xapi __context:Context.t as a first parameter. Changes are rather mechanical but, by threading this through, we can now add tracing to interesting parts (along with making the tracing more granular in future). Signed-off-by: Colin James --- ocaml/tests/testauthx.ml | 49 ++++++++++++++++++-------- ocaml/xapi/auth_signature.ml | 20 ++++++----- ocaml/xapi/authx.ml | 20 +++++------ ocaml/xapi/extauth_plugin_ADpbis.ml | 40 +++++++++++---------- ocaml/xapi/extauth_plugin_ADwinbind.ml | 18 +++++----- ocaml/xapi/xapi.ml | 3 +- ocaml/xapi/xapi_auth.ml | 6 ++-- ocaml/xapi/xapi_host.ml | 4 +-- ocaml/xapi/xapi_pool.ml | 3 +- ocaml/xapi/xapi_session.ml | 14 +++++--- ocaml/xapi/xapi_subject.ml | 2 +- 11 files changed, 106 insertions(+), 73 deletions(-) diff --git a/ocaml/tests/testauthx.ml b/ocaml/tests/testauthx.ml index 8d0856101bb..2632ef8b919 100644 --- a/ocaml/tests/testauthx.ml +++ b/ocaml/tests/testauthx.ml @@ -20,19 +20,22 @@ let usage () = exit 1 let _ = + let __context = Context.make __MODULE__ in if Array.length Sys.argv <> 3 then usage () ; let username = Sys.argv.(1) and password = Sys.argv.(2) in let hr x = print_endline ("-----------------------------\n" ^ x) in (* should return 2037 *) hr ("TEST 1a. Authx.get_subject_identifier " ^ username) ; - let userid = AuthX.methods.get_subject_identifier username in + let userid = AuthX.methods.get_subject_identifier ~__context username in print_endline ("userid=" ^ userid) ; hr ("TEST 1b. AuthX.methods.get_subject_identifier " ^ username ^ "_werq (unknown subject)" ) ; - try print_endline (AuthX.methods.get_subject_identifier (username ^ "_werq")) + try + print_endline + (AuthX.methods.get_subject_identifier ~__context (username ^ "_werq")) with Not_found -> ( print_endline "subject Not_found, as expected" ; (* should return a list of groups that subjectid 1000 (a user) belongs to *) @@ -42,7 +45,7 @@ let _ = ^ " (a user subject)" ) ; let conc x y = x ^ "," ^ y in - let groupid_list = AuthX.methods.query_group_membership userid in + let groupid_list = AuthX.methods.query_group_membership ~__context userid in print_endline (List.fold_left conc "" groupid_list) ; (* should return a list of groups that subjectid 10024 (a group) belongs to *) let agroup = List.hd groupid_list in @@ -52,23 +55,31 @@ let _ = ^ " (a group subject)" ) ; print_endline - (List.fold_left conc "" (AuthX.methods.query_group_membership agroup)) ; + (List.fold_left conc "" + (AuthX.methods.query_group_membership ~__context agroup) + ) ; hr "TEST 2c. AuthX.methods.query_group_membership u999 (unknown subject)" ; try print_endline - (List.fold_left conc "" (AuthX.methods.query_group_membership "u999")) + (List.fold_left conc "" + (AuthX.methods.query_group_membership ~__context "u999") + ) with Not_found -> ( print_endline "subject Not_found, as expected." ; hr "TEST 2d. AuthX.methods.query_group_membership a999 (unknown subject)" ; try print_endline - (List.fold_left conc "" (AuthX.methods.query_group_membership "a999")) + (List.fold_left conc "" + (AuthX.methods.query_group_membership ~__context "a999") + ) with Not_found -> ( print_endline "subject Not_found, as expected." ; hr "TEST 2e. AuthX.methods.query_group_membership 999 (unknown subject)" ; try print_endline - (List.fold_left conc "" (AuthX.methods.query_group_membership "999")) + (List.fold_left conc "" + (AuthX.methods.query_group_membership ~__context "999") + ) with Not_found -> ( print_endline "subject Not_found, as expected." ; (* should return a list with information about subject_id 1000 (a user)*) @@ -77,7 +88,9 @@ let _ = ^ userid ^ " (a user)" ) ; - let infolist1 = AuthX.methods.query_subject_information userid in + let infolist1 = + AuthX.methods.query_subject_information ~__context userid + in for i = 0 to List.length infolist1 - 1 do let print_elems (e1, e2) = print_endline (e1 ^ ": " ^ e2) in print_elems (List.nth infolist1 i) @@ -88,7 +101,9 @@ let _ = ^ agroup ^ " (a group)" ) ; - let infolist1 = AuthX.methods.query_subject_information agroup in + let infolist1 = + AuthX.methods.query_subject_information ~__context agroup + in for i = 0 to List.length infolist1 - 1 do let print_elems (e1, e2) = print_endline (e1 ^ ": " ^ e2) in print_elems (List.nth infolist1 i) @@ -98,7 +113,9 @@ let _ = "TEST 3c. AuthX.methods.query_subject_information u999 (unknown \ subject)" ; try - let infolist1 = AuthX.methods.query_subject_information "u999" in + let infolist1 = + AuthX.methods.query_subject_information ~__context "u999" + in for i = 0 to List.length infolist1 - 1 do let print_elems (e1, e2) = print_endline (e1 ^ ": " ^ e2) in print_elems (List.nth infolist1 i) @@ -110,7 +127,9 @@ let _ = "TEST 3d. AuthX.methods.query_subject_information a999 (unknown \ subject)" ; try - let infolist1 = AuthX.methods.query_subject_information "a999" in + let infolist1 = + AuthX.methods.query_subject_information ~__context "a999" + in for i = 0 to List.length infolist1 - 1 do let print_elems (e1, e2) = print_endline (e1 ^ ": " ^ e2) in print_elems (List.nth infolist1 i) @@ -122,7 +141,9 @@ let _ = "TEST 3e. AuthX.methods.query_subject_information 999 (unknown \ subject)" ; try - let infolist1 = AuthX.methods.query_subject_information "999" in + let infolist1 = + AuthX.methods.query_subject_information ~__context "999" + in for i = 0 to List.length infolist1 - 1 do let print_elems (e1, e2) = print_endline (e1 ^ ": " ^ e2) in print_elems (List.nth infolist1 i) @@ -134,8 +155,8 @@ let _ = ^ username ) ; print_endline - (AuthX.methods.authenticate_username_password username - password + (AuthX.methods.authenticate_username_password ~__context + username password ) ) ) diff --git a/ocaml/xapi/auth_signature.ml b/ocaml/xapi/auth_signature.ml index ff4fb076742..f4a16677712 100644 --- a/ocaml/xapi/auth_signature.ml +++ b/ocaml/xapi/auth_signature.ml @@ -67,12 +67,13 @@ type t = { the auth module/service itself -- e.g. maybe a SID or something in the AD case). Raises auth_failure if authentication is not successful *) - authenticate_username_password: string -> string -> string + authenticate_username_password: + __context:Context.t -> string -> string -> string ; (* subject_id Authenticate_ticket(string ticket) As above but uses a ticket as credentials (i.e. for single sign-on) *) - authenticate_ticket: string -> string + authenticate_ticket: __context:Context.t -> string -> string ; (* subject_id get_subject_identifier(string subject_name) Takes a subject_name (as may be entered into the XenCenter UI when defining subjects -- @@ -80,7 +81,7 @@ type t = { auth/directory service. Raises Not_found if authentication is not succesful. *) - get_subject_identifier: string -> string + get_subject_identifier: __context:Context.t -> string -> string ; (* ((string*string) list) query_subject_information(string subject_identifier) Takes a subject_identifier and returns the user record from the directory service as @@ -91,7 +92,8 @@ type t = { it's a string*string list anyway for possible future expansion. Raises Not_found if subject_id cannot be resolved by external auth service *) - query_subject_information: string -> (string * string) list + query_subject_information: + __context:Context.t -> string -> (string * string) list ; (* (string list) query_group_membership(string subject_identifier) Takes a subject_identifier and returns its group membership (i.e. a list of subject @@ -99,7 +101,7 @@ type t = { _must_ be transitively closed wrt the is_member_of relation if the external directory service supports nested groups (as AD does for example) *) - query_group_membership: string -> string list + query_group_membership: __context:Context.t -> string -> string list ; (* In addition, there are some event hooks that auth modules implement as follows: *) @@ -118,7 +120,7 @@ type t = { explicitly filter any one-time credentials [like AD username/password for example] that it does not need long-term.] *) - on_enable: (string * string) list -> unit + on_enable: __context:Context.t -> (string * string) list -> unit ; (* unit on_disable() Called internally by xapi _on each host_ when a client disables an auth service via the XenAPI. @@ -126,18 +128,18 @@ type t = { service are cleared (i.e. so you can access the config params you need from the pool metadata within the body of the on_disable method) *) - on_disable: (string * string) list -> unit + on_disable: __context:Context.t -> (string * string) list -> unit ; (* unit on_xapi_initialize(bool system_boot) Called internally by xapi whenever it starts up. The system_boot flag is true iff xapi is starting for the first time after a host boot *) - on_xapi_initialize: bool -> unit + on_xapi_initialize: __context:Context.t -> bool -> unit ; (* unit on_xapi_exit() Called internally when xapi is doing a clean exit. *) - on_xapi_exit: unit -> unit + on_xapi_exit: __context:Context.t -> unit -> unit } (* Auth modules must implement this signature:*) diff --git a/ocaml/xapi/authx.ml b/ocaml/xapi/authx.ml index d0efeb64bea..5ab5406558d 100644 --- a/ocaml/xapi/authx.ml +++ b/ocaml/xapi/authx.ml @@ -113,7 +113,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct auth/directory service. Raises Not_found if authentication is not succesful. *) - let get_subject_identifier subject_name = + let get_subject_identifier ~__context:_ subject_name = try (* looks up list of users*) "u" ^ getent_idbyname "passwd" subject_name with Not_found -> @@ -131,7 +131,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct Raises auth_failure if authentication is not successful *) - let authenticate_username_password username password = + let authenticate_username_password ~__context username password = (* we try to authenticate against our user database using PAM *) let () = try @@ -139,7 +139,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct (* no exception raised, then authentication succeeded *) with Failure msg -> raise (Auth_signature.Auth_failure msg) in - try get_subject_identifier username + try get_subject_identifier ~__context username with Not_found -> raise (Auth_signature.Auth_failure @@ -155,7 +155,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct *) (* not implemented now, not needed for our tests, only for a *) (* future single sign-on feature *) - let authenticate_ticket _tgt = + let authenticate_ticket ~__context:_ _tgt = failwith "authx authenticate_ticket not implemented" (* ((string*string) list) query_subject_information(string subject_identifier) @@ -168,7 +168,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct it's a string*string list anyway for possible future expansion. Raises Not_found if subject_id cannot be resolved by external auth service *) - let query_subject_information subject_identifier = + let query_subject_information ~__context:_ subject_identifier = (* we are expecting an id such as u0, g0, u123 etc *) if String.length subject_identifier < 2 then raise Not_found ; match subject_identifier.[0] with @@ -246,7 +246,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct *) (* in unix, groups cannot contain groups, so we just verify the groups a user *) (* belongs to and, if that fails, if some group has the required identifier *) - let query_group_membership subject_identifier = + let query_group_membership ~__context subject_identifier = (* 1. first we try to see if our subject identifier is a user id...*) let sanitized_subject_id = String.escaped subject_identifier in (* we are expecting an id such as u0, g0, u123 etc *) @@ -303,7 +303,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct explicitly filter any one-time credentials [like AD username/password for example] that it does not need long-term.] *) - let on_enable _config_params = + let on_enable ~__context:_ _config_params = (* nothing to do in this unix plugin, we always have /etc/passwd and /etc/group *) () @@ -314,7 +314,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct service are cleared (i.e. so you can access the config params you need from the pool metadata within the body of the on_disable method) *) - let on_disable _config_params = + let on_disable ~__context:_ _config_params = (* nothing to disable in this unix plugin, we should not disable /etc/passwd and /etc/group:) *) () @@ -323,7 +323,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct Called internally by xapi whenever it starts up. The system_boot flag is true iff xapi is starting for the first time after a host boot *) - let on_xapi_initialize _system_boot = + let on_xapi_initialize ~__context:_ _system_boot = (* again, nothing to be initialized here in this unix plugin *) () @@ -331,7 +331,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct Called internally when xapi is doing a clean exit. *) - let on_xapi_exit () = + let on_xapi_exit ~__context:_ () = (* nothing to do here in this unix plugin *) () diff --git a/ocaml/xapi/extauth_plugin_ADpbis.ml b/ocaml/xapi/extauth_plugin_ADpbis.ml index b46364da946..0bce49b02d8 100644 --- a/ocaml/xapi/extauth_plugin_ADpbis.ml +++ b/ocaml/xapi/extauth_plugin_ADpbis.ml @@ -584,7 +584,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct auth/directory service. Raises Not_found (*Subject_cannot_be_resolved*) if authentication is not succesful. *) - let get_subject_identifier _subject_name = + let get_subject_identifier ~__context:_ _subject_name = try (* looks up list of users*) let subject_name = get_full_subject_name _subject_name in @@ -610,7 +610,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct Raises auth_failure if authentication is not successful *) - let authenticate_username_password username password = + let authenticate_username_password ~__context username password = (* first, we try to authenticated user against our external user database *) (* pbis_common will raise an Auth_failure if external authentication fails *) let domain, user = @@ -639,7 +639,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct in (* no exception raised, then authentication succeeded, *) (* now we return the authenticated user's id *) - get_subject_identifier (get_full_subject_name username) + get_subject_identifier ~__context (get_full_subject_name username) (* subject_id Authenticate_ticket(string ticket) @@ -647,7 +647,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct *) (* not implemented now, not needed for our tests, only for a *) (* future single sign-on feature *) - let authenticate_ticket _tgt = + let authenticate_ticket ~__context:_ _tgt = failwith "extauth_plugin authenticate_ticket not implemented" (* ((string*string) list) query_subject_information(string subject_identifier) @@ -660,7 +660,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct it's a string*string list anyway for possible future expansion. Raises Not_found (*Subject_cannot_be_resolved*) if subject_id cannot be resolved by external auth service *) - let query_subject_information subject_identifier = + let query_subject_information ~__context:_ subject_identifier = let unmap_lw_space_chars lwname = let defensive_copy = Bytes.of_string lwname in (* CA-29006: map chars in names back to original space chars in windows-names *) @@ -729,8 +729,10 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct _must_ be transitively closed wrt the is_member_of relation if the external directory service supports nested groups (as AD does for example) *) - let query_group_membership subject_identifier = - let subject_info = query_subject_information subject_identifier in + let query_group_membership ~__context subject_identifier = + let subject_info = + query_subject_information ~__context subject_identifier + in if List.assoc "subject-is-group" subject_info = "true" (* this field is always present *) @@ -759,7 +761,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct In addition, there are some event hooks that auth modules implement as follows: *) - let _is_pbis_server_available max_tries = + let _is_pbis_server_available ~__context max_tries = (* we _need_ to use a username contained in our domain, otherwise the following tests won't work. Microsoft KB/Q243330 article provides the KRBTGT account as a well-known built-in SID in AD Microsoft KB/Q229909 article says that KRBTGT account cannot be renamed or enabled, making @@ -793,12 +795,14 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct in let try_fetch_sid () = try - let sid = get_subject_identifier krbtgt in + let sid = get_subject_identifier ~__context krbtgt in debug "Request to external authentication server successful: user %s was \ found" krbtgt ; - let (_ : (string * string) list) = query_subject_information sid in + let (_ : (string * string) list) = + query_subject_information ~__context sid + in debug "Request to external authentication server successful: sid %s was \ found" @@ -849,9 +853,9 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct in go 0 - let is_pbis_server_available max = + let is_pbis_server_available ~__context max = Locking_helpers.Named_mutex.execute mutex_check_availability (fun () -> - _is_pbis_server_available max + _is_pbis_server_available ~__context max ) (* converts from domain.com\user to user@domain.com, in case domain.com is present in the subject_name *) @@ -885,7 +889,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct explicitly filter any one-time credentials [like AD username/password for example] that it does not need long-term.] *) - let on_enable config_params = + let on_enable ~__context config_params = (* but in the ldap plugin, we should 'join the AD/kerberos domain', i.e. we should*) (* basically: (1) create a machine account in the kerberos realm,*) (* (2) store the machine account password somewhere locally (in a keytab) *) @@ -990,7 +994,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct in let max_tries = 60 in (* tests 60 x 5.0 seconds = 300 seconds = 5minutes trying *) - if not (is_pbis_server_available max_tries) then ( + if not (is_pbis_server_available ~__context max_tries) then ( let errmsg = Printf.sprintf "External authentication server not available after %i query \ @@ -1033,7 +1037,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct service are cleared (i.e. so you can access the config params you need from the pool metadata within the body of the on_disable method) *) - let on_disable config_params = + let on_disable ~__context:_ config_params = (* but in the ldap plugin, we should 'leave the AD/kerberos domain', i.e. we should *) (* (1) remove the machine account from the kerberos realm, (2) remove the keytab locally *) let pbis_failure = @@ -1130,7 +1134,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct Called internally by xapi whenever it starts up. The system_boot flag is true iff xapi is starting for the first time after a host boot *) - let on_xapi_initialize _system_boot = + let on_xapi_initialize ~__context _system_boot = (* the AD server is initialized outside xapi, by init.d scripts *) (* this function is called during xapi initialization in xapi.ml *) @@ -1138,7 +1142,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct (* make sure that the AD/LSASS server is responding before returning *) let max_tries = 12 in (* tests 12 x 5.0 seconds = 60 seconds = up to 1 minute trying *) - if not (is_pbis_server_available max_tries) then ( + if not (is_pbis_server_available ~__context max_tries) then ( let errmsg = Printf.sprintf "External authentication server not available after %i query tests" @@ -1154,7 +1158,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct Called internally when xapi is doing a clean exit. *) - let on_xapi_exit () = + let on_xapi_exit ~__context:_ () = (* nothing to do here in this unix plugin *) (* in the ldap plugin, we should remove the tgt ticket in /tmp/krb5cc_0 *) diff --git a/ocaml/xapi/extauth_plugin_ADwinbind.ml b/ocaml/xapi/extauth_plugin_ADwinbind.ml index da3a1e0e4b3..b227433fa5d 100644 --- a/ocaml/xapi/extauth_plugin_ADwinbind.ml +++ b/ocaml/xapi/extauth_plugin_ADwinbind.ml @@ -1361,7 +1361,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct auth/directory service. Raises Not_found (*Subject_cannot_be_resolved*) if authentication is not succesful. *) - let get_subject_identifier subject_name = + let get_subject_identifier ~__context:_ subject_name = maybe_raise (get_subject_identifier' subject_name) (* subject_id Authenticate_username_password(string username, string password) @@ -1375,7 +1375,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct Raises auth_failure if authentication is not successful *) - let authenticate_username_password uname password = + let authenticate_username_password ~__context uname password = (* the `wbinfo --krb5auth` expects the username to be in either SAM or UPN format. * we use wbinfo to try to convert the provided [uname] into said format. * as a last ditch attempt, we try to auth with the provided [uname] @@ -1415,7 +1415,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct *) (* not implemented now, not needed for our tests, only for a *) (* future single sign-on feature *) - let authenticate_ticket _tgt = + let authenticate_ticket ~__context:_ _tgt = failwith "extauth_plugin authenticate_ticket not implemented" let query_subject_information_group (name : string) (gid : int) (sid : string) @@ -1512,7 +1512,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct it's a string*string list anyway for possible future expansion. Raises Not_found (*Subject_cannot_be_resolved*) if subject_id cannot be resolved by external auth service *) - let query_subject_information (sid : string) = + let query_subject_information ~__context:_ (sid : string) = let res = let* name = Wbinfo.name_of_sid sid in match name with @@ -1534,7 +1534,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct _must_ be transitively closed wrt the is_member_of relation if the external directory service supports nested groups (as AD does for example) *) - let query_group_membership subject_identifier = + let query_group_membership ~__context subject_identifier = maybe_raise (Wbinfo.user_domgroups subject_identifier) let assert_join_domain_user_format uname = @@ -1560,7 +1560,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct explicitly filter any one-time credentials [like AD username/password for example] that it does not need long-term.] *) - let on_enable config_params = + let on_enable ~__context:_ config_params = let user = from_config ~name:"user" ~err_msg:"enable requires user" ~config_params in @@ -1654,7 +1654,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct service are cleared (i.e. so you can access the config params you need from the pool metadata within the body of the on_disable method) *) - let on_disable config_params = + let on_disable ~__context:_ config_params = let user = List.assoc_opt "user" config_params in let pass = List.assoc_opt "pass" config_params in let {service_name; _} = get_domain_info_from_db () in @@ -1676,7 +1676,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct Called internally by xapi whenever it starts up. The system_boot flag is true iff xapi is starting for the first time after a host boot *) - let on_xapi_initialize _system_boot = + let on_xapi_initialize ~__context:_ _system_boot = Winbind.start ~timeout:5. ~wait_until_success:true ; ClosestKdc.trigger_update ~start:ClosestKdc.startup_delay ; RotateMachinePassword.trigger_rotate ~start:5. ; @@ -1686,7 +1686,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct Called internally when xapi is doing a clean exit. *) - let on_xapi_exit () = () + let on_xapi_exit ~__context:_ () = () (* Implement the single value required for the module signature *) let methods = diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml index 26659a55801..f06c19720f5 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -1024,7 +1024,8 @@ let server_init () = while not !Xapi_globs.event_hook_auth_on_xapi_initialize_succeeded do try (* try to initialize external authentication service *) - (Ext_auth.d ()).on_xapi_initialize !Xapi_globs.on_system_boot ; + (Ext_auth.d ()).on_xapi_initialize ~__context + !Xapi_globs.on_system_boot ; (* tell everybody the service initialized successfully *) Xapi_globs.event_hook_auth_on_xapi_initialize_succeeded := true ; (* 3. Now that we are sure that the external authentication service is working,*) diff --git a/ocaml/xapi/xapi_auth.ml b/ocaml/xapi/xapi_auth.ml index 58a851b3052..60ac443edd4 100644 --- a/ocaml/xapi/xapi_auth.ml +++ b/ocaml/xapi/xapi_auth.ml @@ -39,15 +39,15 @@ let call_with_exception_handler fn = let get_subject_identifier ~__context ~subject_name = call_with_exception_handler (fun () -> - (Ext_auth.d ()).get_subject_identifier subject_name + (Ext_auth.d ()).get_subject_identifier ~__context subject_name ) let get_group_membership ~__context ~subject_identifier = call_with_exception_handler (fun () -> - (Ext_auth.d ()).query_group_membership subject_identifier + (Ext_auth.d ()).query_group_membership ~__context subject_identifier ) let get_subject_information_from_identifier ~__context ~subject_identifier = call_with_exception_handler (fun () -> - (Ext_auth.d ()).query_subject_information subject_identifier + (Ext_auth.d ()).query_subject_information ~__context subject_identifier ) diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 666c5500bf4..05955958813 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -1778,7 +1778,7 @@ let enable_external_auth ~__context ~host ~config ~service_name ~auth_type = (* use the special 'named dispatcher' function to call an extauth plugin function even though we have *) (* not yet set up the external_auth_type value that will enable generic access to the extauth plugin. *) - (Ext_auth.nd auth_type).on_enable config ; + (Ext_auth.nd auth_type).on_enable ~__context config ; (* from this point on, we have successfully enabled the external authentication services. *) @@ -1891,7 +1891,7 @@ let disable_external_auth_common ?(during_pool_eject = false) ~__context ~host (* 1. first, we try to call the external auth plugin to disable the external authentication service *) let plugin_disable_failure = try - (Ext_auth.d ()).on_disable config ; + (Ext_auth.d ()).on_disable ~__context config ; None (* OK, on_disable succeeded *) with | Auth_signature.Auth_service_error (errtag, msg) -> diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index f0cd7c49bfc..63598c0d6b4 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -2559,7 +2559,8 @@ let revalidate_subjects ~__context = debug "Revalidating subject %s" subj_id ; try let open Auth_signature in - ignore ((Extauth.Ext_auth.d ()).query_subject_information subj_id) + ignore + ((Extauth.Ext_auth.d ()).query_subject_information ~__context subj_id) with Not_found -> debug "Destroying subject %s" subj_id ; Xapi_subject.destroy ~__context ~self diff --git a/ocaml/xapi/xapi_session.ml b/ocaml/xapi/xapi_session.ml index 2a5a933fe6a..9567dd156a2 100644 --- a/ocaml/xapi/xapi_session.ml +++ b/ocaml/xapi/xapi_session.ml @@ -268,9 +268,9 @@ let set_local_auth_max_threads n = let set_ext_auth_max_threads n = Locking_helpers.Semaphore.set_max throttle_auth_external @@ Int64.to_int n -let do_external_auth uname pwd = +let do_external_auth ~__context uname pwd = with_throttle throttle_auth_external (fun () -> - (Ext_auth.d ()).authenticate_username_password uname pwd + (Ext_auth.d ()).authenticate_username_password ~__context uname pwd ) let do_local_auth uname pwd = @@ -487,7 +487,8 @@ let revalidate_external_session ~__context ~session = try (* if the user is not in the external directory service anymore, this call raises Not_found *) let group_membership_closure = - (Ext_auth.d ()).query_group_membership authenticated_user_sid + (Ext_auth.d ()).query_group_membership ~__context + authenticated_user_sid in debug "obtained group membership for session %s, sid %s " (trackid session) authenticated_user_sid ; @@ -869,7 +870,9 @@ let login_with_password ~__context ~uname ~pwd ~version:_ ~originator = (* so that we know that he/she exists there *) let subject_identifier = try - let _subject_identifier = do_external_auth uname pwd in + let _subject_identifier = + do_external_auth ~__context uname pwd + in debug "Successful external authentication user %s \ (subject_identifier, %s from %s)" @@ -931,7 +934,8 @@ let login_with_password ~__context ~uname ~pwd ~version:_ ~originator = (* finds all the groups a user belongs to (non-reflexive closure of member-of relation) *) let group_membership_closure = try - (Ext_auth.d ()).query_group_membership subject_identifier + (Ext_auth.d ()).query_group_membership ~__context + subject_identifier with | Not_found | Auth_signature.Subject_cannot_be_resolved -> let msg = diff --git a/ocaml/xapi/xapi_subject.ml b/ocaml/xapi/xapi_subject.ml index 5c1cdd69a5d..fcdc8710dc4 100644 --- a/ocaml/xapi/xapi_subject.ml +++ b/ocaml/xapi/xapi_subject.ml @@ -261,4 +261,4 @@ let get_subject_information_from_identifier ~__context ~cache identifier = if cache then query_subject_information_from_db ~__context identifier else - (Ext_auth.d ()).query_subject_information identifier + (Ext_auth.d ()).query_subject_information ~__context identifier From 4acf937d684faacd6a79d8241d7e0ed0a7f52599 Mon Sep 17 00:00:00 2001 From: Colin James Date: Wed, 31 Jul 2024 15:22:59 +0100 Subject: [PATCH 076/157] CP-50426: Add tracing to external auth functions Endows the propagated __context parameters with tracing (in some cases). It is not applied to all possible places as many of the functions are actually failure/no-op stubs. Signed-off-by: Colin James --- ocaml/xapi/authx.ml | 10 ++++++++-- ocaml/xapi/extauth_plugin_ADpbis.ml | 18 +++++++++++++++--- ocaml/xapi/extauth_plugin_ADwinbind.ml | 20 +++++++++++++++----- 3 files changed, 38 insertions(+), 10 deletions(-) diff --git a/ocaml/xapi/authx.ml b/ocaml/xapi/authx.ml index 5ab5406558d..87d85e40332 100644 --- a/ocaml/xapi/authx.ml +++ b/ocaml/xapi/authx.ml @@ -19,6 +19,8 @@ module D = Debug.Make (struct let name = "extauth_plugin_PAM_NSS" end) open D +let ( let@ ) = ( @@ ) + module AuthX : Auth_signature.AUTH_MODULE = struct (* * External Authentication Plugin component @@ -113,7 +115,8 @@ module AuthX : Auth_signature.AUTH_MODULE = struct auth/directory service. Raises Not_found if authentication is not succesful. *) - let get_subject_identifier ~__context:_ subject_name = + let get_subject_identifier ~__context subject_name = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in try (* looks up list of users*) "u" ^ getent_idbyname "passwd" subject_name with Not_found -> @@ -132,6 +135,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct *) let authenticate_username_password ~__context username password = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* we try to authenticate against our user database using PAM *) let () = try @@ -168,7 +172,8 @@ module AuthX : Auth_signature.AUTH_MODULE = struct it's a string*string list anyway for possible future expansion. Raises Not_found if subject_id cannot be resolved by external auth service *) - let query_subject_information ~__context:_ subject_identifier = + let query_subject_information ~__context subject_identifier = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* we are expecting an id such as u0, g0, u123 etc *) if String.length subject_identifier < 2 then raise Not_found ; match subject_identifier.[0] with @@ -247,6 +252,7 @@ module AuthX : Auth_signature.AUTH_MODULE = struct (* in unix, groups cannot contain groups, so we just verify the groups a user *) (* belongs to and, if that fails, if some group has the required identifier *) let query_group_membership ~__context subject_identifier = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* 1. first we try to see if our subject identifier is a user id...*) let sanitized_subject_id = String.escaped subject_identifier in (* we are expecting an id such as u0, g0, u123 etc *) diff --git a/ocaml/xapi/extauth_plugin_ADpbis.ml b/ocaml/xapi/extauth_plugin_ADpbis.ml index 0bce49b02d8..fc73c7b7cb6 100644 --- a/ocaml/xapi/extauth_plugin_ADpbis.ml +++ b/ocaml/xapi/extauth_plugin_ADpbis.ml @@ -20,6 +20,8 @@ module D = Debug.Make (struct let name = "extauth_plugin_ADpbis" end) open D open Xapi_stdext_std.Xstringext +let ( let@ ) = ( @@ ) + let finally = Xapi_stdext_pervasives.Pervasiveext.finally let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute @@ -584,7 +586,9 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct auth/directory service. Raises Not_found (*Subject_cannot_be_resolved*) if authentication is not succesful. *) - let get_subject_identifier ~__context:_ _subject_name = + let get_subject_identifier ~__context _subject_name = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + try (* looks up list of users*) let subject_name = get_full_subject_name _subject_name in @@ -611,6 +615,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct *) let authenticate_username_password ~__context username password = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* first, we try to authenticated user against our external user database *) (* pbis_common will raise an Auth_failure if external authentication fails *) let domain, user = @@ -660,7 +665,8 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct it's a string*string list anyway for possible future expansion. Raises Not_found (*Subject_cannot_be_resolved*) if subject_id cannot be resolved by external auth service *) - let query_subject_information ~__context:_ subject_identifier = + let query_subject_information ~__context subject_identifier = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let unmap_lw_space_chars lwname = let defensive_copy = Bytes.of_string lwname in (* CA-29006: map chars in names back to original space chars in windows-names *) @@ -730,6 +736,8 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct supports nested groups (as AD does for example) *) let query_group_membership ~__context subject_identifier = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + let subject_info = query_subject_information ~__context subject_identifier in @@ -890,6 +898,7 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct does not need long-term.] *) let on_enable ~__context config_params = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* but in the ldap plugin, we should 'join the AD/kerberos domain', i.e. we should*) (* basically: (1) create a machine account in the kerberos realm,*) (* (2) store the machine account password somewhere locally (in a keytab) *) @@ -1037,7 +1046,8 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct service are cleared (i.e. so you can access the config params you need from the pool metadata within the body of the on_disable method) *) - let on_disable ~__context:_ config_params = + let on_disable ~__context config_params = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* but in the ldap plugin, we should 'leave the AD/kerberos domain', i.e. we should *) (* (1) remove the machine account from the kerberos realm, (2) remove the keytab locally *) let pbis_failure = @@ -1135,6 +1145,8 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct starting for the first time after a host boot *) let on_xapi_initialize ~__context _system_boot = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + (* the AD server is initialized outside xapi, by init.d scripts *) (* this function is called during xapi initialization in xapi.ml *) diff --git a/ocaml/xapi/extauth_plugin_ADwinbind.ml b/ocaml/xapi/extauth_plugin_ADwinbind.ml index b227433fa5d..fc0aa01ad0b 100644 --- a/ocaml/xapi/extauth_plugin_ADwinbind.ml +++ b/ocaml/xapi/extauth_plugin_ADwinbind.ml @@ -29,6 +29,8 @@ let krbtgt = "KRBTGT" let ( let* ) = Result.bind +let ( let@ ) = ( @@ ) + let ( ) x f = Rresult.R.reword_error f x let ( >>| ) = Rresult.( >>| ) @@ -1361,7 +1363,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct auth/directory service. Raises Not_found (*Subject_cannot_be_resolved*) if authentication is not succesful. *) - let get_subject_identifier ~__context:_ subject_name = + let get_subject_identifier ~__context subject_name = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in maybe_raise (get_subject_identifier' subject_name) (* subject_id Authenticate_username_password(string username, string password) @@ -1376,6 +1379,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct *) let authenticate_username_password ~__context uname password = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* the `wbinfo --krb5auth` expects the username to be in either SAM or UPN format. * we use wbinfo to try to convert the provided [uname] into said format. * as a last ditch attempt, we try to auth with the provided [uname] @@ -1512,7 +1516,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct it's a string*string list anyway for possible future expansion. Raises Not_found (*Subject_cannot_be_resolved*) if subject_id cannot be resolved by external auth service *) - let query_subject_information ~__context:_ (sid : string) = + let query_subject_information ~__context (sid : string) = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let res = let* name = Wbinfo.name_of_sid sid in match name with @@ -1535,6 +1540,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct supports nested groups (as AD does for example) *) let query_group_membership ~__context subject_identifier = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in maybe_raise (Wbinfo.user_domgroups subject_identifier) let assert_join_domain_user_format uname = @@ -1560,7 +1566,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct explicitly filter any one-time credentials [like AD username/password for example] that it does not need long-term.] *) - let on_enable ~__context:_ config_params = + let on_enable ~__context config_params = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let user = from_config ~name:"user" ~err_msg:"enable requires user" ~config_params in @@ -1654,7 +1661,8 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct service are cleared (i.e. so you can access the config params you need from the pool metadata within the body of the on_disable method) *) - let on_disable ~__context:_ config_params = + let on_disable ~__context config_params = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let user = List.assoc_opt "user" config_params in let pass = List.assoc_opt "pass" config_params in let {service_name; _} = get_domain_info_from_db () in @@ -1676,7 +1684,9 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct Called internally by xapi whenever it starts up. The system_boot flag is true iff xapi is starting for the first time after a host boot *) - let on_xapi_initialize ~__context:_ _system_boot = + let on_xapi_initialize ~__context _system_boot = + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + Winbind.start ~timeout:5. ~wait_until_success:true ; ClosestKdc.trigger_update ~start:ClosestKdc.startup_delay ; RotateMachinePassword.trigger_rotate ~start:5. ; From 10e615609371a880d5832cd0aa664bccdbe6b0db Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 1 Aug 2024 10:15:37 +0100 Subject: [PATCH 077/157] ci: use the names of binaries, not libraries in stresstests These were changed recently and the stresstest rules need to match the new name Signed-off-by: Pau Ruiz Safont --- ocaml/libs/http-lib/dune | 2 +- ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index a62d17ad62b..f6de65dbe48 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -97,7 +97,7 @@ (rule (alias stresstest) - (deps bufio_test.exe) + (deps bufio_test_run.exe) ; use default random seed on stresstests (action (run %{deps} -v -bt)) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune index ac19e3b6956..0eb42f9d114 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune @@ -15,7 +15,7 @@ (rule (alias stresstest) - (deps unixext_test.exe) + (deps unixext_test_run.exe) ; use default random seed on stresstests (action (run %{deps} -v -bt)) ) From 4ab22bc1b53442975b2347f19a13981202053b85 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Tue, 16 Jul 2024 10:44:15 +0100 Subject: [PATCH 078/157] CA-395789: Add polling to cluster health state update It was observed that the corosync-notifyd might send a notification when the data shown in corosync-quorumtool has not been updated. This causes xapi-clusterd to return the out-of-date cluster information to xapi. Xapi will not have a chance of updating these states again until there is a further change in the cluster (which may not happen for a long time). Now add polling in xapi to update the cluster info every 5 minutes, making sure that in the worst case, we still get up-to-date information after a 5-minute delay. Signed-off-by: Vincent Liu --- ocaml/xapi/xapi_clustering.ml | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index 93a65dadd12..cfa4ff4bffb 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -535,10 +535,10 @@ module Watcher = struct let cluster_change_watcher : bool Atomic.t = Atomic.make false - (* this is the time it takes for the update request to time out. It is ok to set + (* This is the time it takes for the update request to time out. It is ok to set it to a relatively long value since the call will return immediately if there - is an update *) - let cluster_change_interval = Mtime.Span.min + is an update. *) + let cluster_change_interval = Mtime.Span.(5 * min) let cluster_stack_watcher : bool Atomic.t = Atomic.make false @@ -550,21 +550,27 @@ module Watcher = struct while !Daemon.enabled do let m = Cluster_client.LocalClient.UPDATES.get (rpc ~__context) - "call cluster watcher" + "cluster change watcher call" (Clock.Timer.span_to_s cluster_change_interval) in - match Idl.IdM.run @@ Cluster_client.IDL.T.get m with - | Ok updates -> ( + let find_cluster_and_update updates = match find_cluster_host ~__context ~host with | Some ch -> let cluster = Db.Cluster_host.get_cluster ~__context ~self:ch in on_corosync_update ~__context ~cluster updates | None -> () - ) + in + match Idl.IdM.run @@ Cluster_client.IDL.T.get m with + | Ok updates -> + (* Received updates from corosync-notifyd *) + find_cluster_and_update updates | Error (InternalError "UPDATES.Timeout") -> - (* UPDATES.get timed out, this is normal, now retry *) - () + (* UPDATES.get timed out, this is normal. *) + (* CA-395789: We send a query to xapi-clusterd to fetch the latest state + anyway in case there is a race and the previous update did not give the + most up-to-date information *) + find_cluster_and_update ["routine updates"] | Error (InternalError message) | Error (Unix_error message) -> warn "%s: Cannot query cluster host updates with error %s" __FUNCTION__ message From 58a14201f17ab4b94e7facb48e94b31f8a92695f Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Thu, 1 Aug 2024 14:14:29 +0100 Subject: [PATCH 079/157] Add more detailed debug message Signed-off-by: Vincent Liu --- ocaml/xapi/xapi_clustering.ml | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index cfa4ff4bffb..545674e92e0 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -427,11 +427,16 @@ let compute_corosync_max_host_failures ~__context = corosync_ha_max_hosts module Watcher = struct + let routine_updates = "routine updates" + let on_corosync_update ~__context ~cluster updates = - debug - "%s: Received %d updates from corosync_notifyd, run diagnostics to get \ - new state" - __FUNCTION__ (List.length updates) ; + if updates = [routine_updates] then + debug "%s: Perform routine updates" __FUNCTION__ + else + debug + "%s: Received %d updates from corosync_notifyd, run diagnostics to get \ + new state" + __FUNCTION__ (List.length updates) ; let m = Cluster_client.LocalClient.diagnostics (rpc ~__context) "update quorum api fields with diagnostics" @@ -570,7 +575,7 @@ module Watcher = struct (* CA-395789: We send a query to xapi-clusterd to fetch the latest state anyway in case there is a race and the previous update did not give the most up-to-date information *) - find_cluster_and_update ["routine updates"] + find_cluster_and_update [routine_updates] | Error (InternalError message) | Error (Unix_error message) -> warn "%s: Cannot query cluster host updates with error %s" __FUNCTION__ message From b33c0a780370fec922b572d2e749298385cf141d Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 2 Aug 2024 13:04:14 +0100 Subject: [PATCH 080/157] ci: Avoid breaking through the opam sandbox in tests Use tmpdir whenever possible Signed-off-by: Pau Ruiz Safont --- .../libs/xapi-stdext/lib/xapi-stdext-unix/test/test_systemd.t | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/test_systemd.t b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/test_systemd.t index 33b39dc277c..28790e8a32d 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/test_systemd.t +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/test_systemd.t @@ -15,8 +15,7 @@ == Use socket files $ export TMPDIR=${TMPDIR:-/tmp} - $ export XDG_RUNTIME_DIR=${XDG_RUNTIME_DIR:-$TMPDIR} - $ export NOTIFY_SOCKET="${XDG_RUNTIME_DIR}/systemd.socket" + $ export NOTIFY_SOCKET="${TMPDIR}/systemd.socket" $ rm -f "$NOTIFY_SOCKET" $ ./test_systemd.exe --server & READY=1 From 00e44578118747ee7910f434d251c77d0e7d3175 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 2 Aug 2024 13:16:41 +0100 Subject: [PATCH 081/157] ci: use ocaml-setup v3 Signed-off-by: Pau Ruiz Safont --- .github/workflows/format.yml | 3 +-- .github/workflows/setup-xapi-environment/action.yml | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index aca7f00f4a6..4d0350056f3 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -28,14 +28,13 @@ jobs: run: sudo apt-get update - name: Use ocaml - uses: ocaml/setup-ocaml@v2 + uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ steps.dotenv.outputs.ocaml_version_full }} opam-repositories: | xs-opam: ${{ steps.dotenv.outputs.repository }} dune-cache: true opam-pin: false - opam-depext: false - name: Install ocamlformat run: opam install ocamlformat diff --git a/.github/workflows/setup-xapi-environment/action.yml b/.github/workflows/setup-xapi-environment/action.yml index a7890222498..e2f85bbb886 100644 --- a/.github/workflows/setup-xapi-environment/action.yml +++ b/.github/workflows/setup-xapi-environment/action.yml @@ -45,7 +45,7 @@ runs: # We set DUNE_CACHE_STORAGE_MODE, it is required for dune cache to work inside opam for now, # otherwise it gets EXDEV and considers it a cache miss - name: Use ocaml - uses: ocaml/setup-ocaml@v2 + uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ steps.dotenv.outputs.ocaml_version_full }} opam-repositories: | From f8ac0cbaf636760adbf0e61ae8071532678dbea1 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 2 Aug 2024 13:33:50 +0100 Subject: [PATCH 082/157] ci: Do not spend time pinning packages It takes literally minutes, for little benefit, now that opam 2.2.0 is used Signed-off-by: Pau Ruiz Safont --- .github/workflows/setup-xapi-environment/action.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/setup-xapi-environment/action.yml b/.github/workflows/setup-xapi-environment/action.yml index e2f85bbb886..72700599cf2 100644 --- a/.github/workflows/setup-xapi-environment/action.yml +++ b/.github/workflows/setup-xapi-environment/action.yml @@ -51,6 +51,7 @@ runs: opam-repositories: | xs-opam: ${{ steps.dotenv.outputs.repository }} dune-cache: true + opam-pin: false env: DUNE_CACHE_STORAGE_MODE: copy From f66981b8daceaee7414a96a62550abf87ea9e895 Mon Sep 17 00:00:00 2001 From: Chunjie Zhu Date: Mon, 5 Aug 2024 07:09:25 +0000 Subject: [PATCH 083/157] CA-389345: fix incorrect data type in python3 even if turning igmp snooping on in ovs bridge, if there is no external querier multicast traffic, ovs igmp snooping will not work, so we need to inject igmp traffic Signed-off-by: Chunjie Zhu --- ocaml/xenopsd/scripts/igmp_query_injector.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ocaml/xenopsd/scripts/igmp_query_injector.py b/ocaml/xenopsd/scripts/igmp_query_injector.py index 1c2f533c1f8..59324b5526b 100755 --- a/ocaml/xenopsd/scripts/igmp_query_injector.py +++ b/ocaml/xenopsd/scripts/igmp_query_injector.py @@ -53,7 +53,8 @@ def inject_packet(self, iface, dst_mac): ether_part = Ether(src='00:00:00:00:00:00', dst=dst_mac) ip_part = IP(ttl=1, src='0.0.0.0', dst='224.0.0.1') igmp_part = IGMP(type=0x11) - igmp_part.mrcode = (self.max_resp_time / 100) & 0xff + # Should use integer division // in python 3 + igmp_part.mrcode = (self.max_resp_time // 100) & 0xff igmp_part.igmpize() # Make this IGMP query packet as an unicast packet ether_part.dst = dst_mac From 6d8d21944f61f252e8e85f024b452af07b4ac70a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 25 Jul 2024 15:01:34 +0100 Subject: [PATCH 084/157] CP-50444: New `with_child_trace` function added to `tracing.ml` Adds `with_child_trace` fuction that only creates a span only if there exists a parent. Signed-off-by: Gabriel Buica --- ocaml/libs/tracing/tracing.ml | 13 ++++++++++--- ocaml/libs/tracing/tracing.mli | 9 +++++++++ 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index 8b22a8680a1..28a5b2f687b 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -519,8 +519,8 @@ module TracerProvider = struct get_tracer_providers_unlocked let set ?enabled ?attributes ?endpoints ~uuid () = - let update_provider (provider : t) ?(enabled = provider.enabled) attributes - endpoints = + let update_provider (provider : t) enabled attributes endpoints = + let enabled = Option.value ~default:provider.enabled enabled in let attributes : string Attributes.t = Option.fold ~none:provider.attributes ~some:Attributes.of_list attributes @@ -537,7 +537,7 @@ module TracerProvider = struct let provider = match Hashtbl.find_opt tracer_providers uuid with | Some (provider : t) -> - update_provider provider ?enabled attributes endpoints + update_provider provider enabled attributes endpoints | None -> fail "The TracerProvider : %s does not exist" uuid in @@ -673,6 +673,13 @@ let with_tracing ?(attributes = []) ?(parent = None) ~name f = ) else f None +let with_child_trace ?attributes parent ~name f = + match parent with + | None -> + f None + | Some _ as parent -> + with_tracing ?attributes ~parent ~name f + module EnvHelpers = struct let traceparent_key = "TRACEPARENT" diff --git a/ocaml/libs/tracing/tracing.mli b/ocaml/libs/tracing/tracing.mli index bfb37ddf292..cd6e4204602 100644 --- a/ocaml/libs/tracing/tracing.mli +++ b/ocaml/libs/tracing/tracing.mli @@ -199,6 +199,15 @@ val with_tracing : -> (Span.t option -> 'a) -> 'a +val with_child_trace : + ?attributes:(string * string) list + -> Span.t option + -> name:string + -> (Span.t option -> 'a) + -> 'a +(** [with_child_trace ?attributes ?parent ~name f] is like {!val:with_tracing}, but + only creates a span if the [parent] span exists. *) + val get_observe : unit -> bool val validate_attribute : string * string -> bool From c37859ddf8684b2406249fad00257626e3cc7a0e Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Tue, 23 Jul 2024 12:49:41 +0100 Subject: [PATCH 085/157] CP-50444: Intrument `http_svr` Intruments the following path of an http request: - `handle_one`, - `callback`, - `callback1`, - `dispatch`, - `jsoncallback`, - `response`. Signed-off-by: Gabriel Buica --- dune-project | 1 + ocaml/libs/http-lib/dune | 1 + ocaml/libs/http-lib/http_svr.ml | 22 ++++++++++++++++++++++ ocaml/libs/http-lib/http_svr.mli | 2 ++ ocaml/xapi/api_server.ml | 24 ++++++++++++++++++++++-- ocaml/xapi/dune | 2 ++ xapi-rrdd.opam | 1 + 7 files changed, 51 insertions(+), 2 deletions(-) diff --git a/dune-project b/dune-project index 0efbe491956..88080ce624c 100644 --- a/dune-project +++ b/dune-project @@ -205,6 +205,7 @@ (xapi-rrd (= :version)) (xapi-stdext-threads (= :version)) (xapi-stdext-unix (= :version)) + xapi-tracing ) ) diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index f6de65dbe48..ead0f1d19f6 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -45,6 +45,7 @@ ipaddr polly threads.posix + tracing uri xapi-log xapi-stdext-pervasives diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index 7c270874a96..51b2beacba8 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -43,6 +43,8 @@ module E = Debug.Make (struct let name = "http_internal_errors" end) let ( let* ) = Option.bind +let ( let@ ) f x = f x + type uri_path = string module Stats = struct @@ -99,8 +101,18 @@ let response_of_request req hdrs = ~headers:(connection :: cache :: hdrs) "200" "OK" +let traceparent_of_request req = + let open Tracing in + let ( let* ) = Option.bind in + let* traceparent = req.Http.Request.traceparent in + let* span_context = SpanContext.of_traceparent traceparent in + let span = Tracer.span_of_span_context span_context req.uri in + Some span + let response_fct req ?(hdrs = []) s (response_length : int64) (write_response_to_fd_fn : Unix.file_descr -> unit) = + let parent = traceparent_of_request req in + let@ _ = Tracing.with_child_trace parent ~name:__FUNCTION__ in let res = { (response_of_request req hdrs) with @@ -486,6 +498,8 @@ let request_of_bio ?proxy_seen ~read_timeout ~total_timeout ~max_length ic = (None, None) let handle_one (x : 'a Server.t) ss context req = + let parent = traceparent_of_request req in + let@ span = Tracing.with_child_trace parent ~name:__FUNCTION__ in let ic = Buf_io.of_fd ss in let finished = ref false in try @@ -499,6 +513,14 @@ let handle_one (x : 'a Server.t) ss context req = Option.value ~default:empty (Radix_tree.longest_prefix req.Request.uri method_map) in + let@ _ = Tracing.with_child_trace span ~name:"handler" in + let traceparent = + let open Tracing in + Option.map + (fun span -> Span.get_context span |> SpanContext.to_traceparent) + span + in + let req = {req with traceparent} in ( match te.TE.handler with | BufIO handlerfn -> handlerfn req ic context diff --git a/ocaml/libs/http-lib/http_svr.mli b/ocaml/libs/http-lib/http_svr.mli index d85ad28a2ec..8b76d6f66c6 100644 --- a/ocaml/libs/http-lib/http_svr.mli +++ b/ocaml/libs/http-lib/http_svr.mli @@ -143,3 +143,5 @@ val https_client_of_req : Http.Request.t -> Ipaddr.t option val client_of_req_and_fd : Http.Request.t -> Unix.file_descr -> client option val string_of_client : client -> string + +val traceparent_of_request : Http.Request.t -> Tracing.Span.t option diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index ba95fbe03d9..7ac5da45e89 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -1,8 +1,12 @@ open Api_server_common module Server = Server.Make (Actions) (Forwarder) +let ( let@ ) f x = f x + (* This bit is called directly by the fake_rpc callback *) let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call = + let parent = Http_svr.traceparent_of_request req in + let@ span = Tracing.with_child_trace parent ~name:__FUNCTION__ in (* We now have the body string, the xml and the call name, and can also tell *) (* if we're a master or slave and whether the call came in on the unix domain socket or the tcp socket *) (* If we're a slave, and the call is from the unix domain socket or from the HIMN, and the call *isn't* *) @@ -20,7 +24,10 @@ let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call = then forward req call is_json else - let response = Server.dispatch_call req fd call in + let response = + let@ _ = Tracing.with_child_trace span ~name:"Server.dispatch_call" in + Server.dispatch_call req fd call + in let translated = if is_json @@ -85,15 +92,26 @@ let create_thumbprint_header req response = (** HTML callback that dispatches an RPC and returns the response. *) let callback is_json req bio _ = + let parent = Http_svr.traceparent_of_request req in + let@ span = Tracing.with_child_trace parent ~name:__FUNCTION__ in let fd = Buf_io.fd_of bio in (* fd only used for writing *) let body = Http_svr.read_body ~limit:Constants.http_limit_max_rpc_size req bio in try - let rpc = Xmlrpc.call_of_string body in + let rpc = + let attributes = [("size", string_of_int (String.length body))] in + let@ _ = + Tracing.with_child_trace ~attributes ~name:"Xmlrpc.call_of_string" span + in + Xmlrpc.call_of_string body + in let response = callback1 is_json req fd rpc in let response_str = + let@ _ = + Tracing.with_child_trace ~name:"Xmlrpc.string_of_response" span + in if rpc.Rpc.name = "system.listMethods" then let inner = Xmlrpc.to_string response.Rpc.contents in Printf.sprintf @@ -129,6 +147,8 @@ let callback is_json req bio _ = (** HTML callback that dispatches an RPC and returns the response. *) let jsoncallback req bio _ = + let parent = Http_svr.traceparent_of_request req in + let@ _ = Tracing.with_child_trace parent ~name:__FUNCTION__ in let fd = Buf_io.fd_of bio in (* fd only used for writing *) let body = diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index aebdf144225..e3708bed112 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -149,6 +149,7 @@ tar tar-unix threads.posix + tracing unixpwd uri uuid @@ -234,6 +235,7 @@ rpclib.xml stunnel threads.posix + tracing xapi-backtrace xapi-client xapi-consts diff --git a/xapi-rrdd.opam b/xapi-rrdd.opam index 745af249f4b..89b2d827a69 100644 --- a/xapi-rrdd.opam +++ b/xapi-rrdd.opam @@ -27,6 +27,7 @@ depends: [ "xapi-rrd" {= version} "xapi-stdext-threads" {= version} "xapi-stdext-unix" {= version} + "xapi-tracing" "odoc" {with-doc} ] build: [ From 4ac5decc0ea28c1b65b26eb743a14965e2b56631 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Fri, 2 Aug 2024 09:36:19 +0100 Subject: [PATCH 086/157] CP-49526: Resolve non-CDN design comments 1. Change the max total bundle files size limit to 1G. 2. Change HTTP error code for the following error to 400: 1) bundle_repo_not_enabled. 2) no_repository_enabled. 3) multiple_update_repositories_enabled. Signed-off-by: Bengang Yuan --- ocaml/xapi/xapi_globs.ml | 4 +- ocaml/xapi/xapi_pool.ml | 80 ++++++++++++++++++++++++---------------- 2 files changed, 50 insertions(+), 34 deletions(-) diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index cdb1cc40144..02ce727a6a1 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -957,8 +957,8 @@ let ignore_vtpm_unimplemented = ref false let evacuation_batch_size = ref 10 -(* Max size limit of bundle file: 500 MB*) -let bundle_max_size_limit = ref (Int64.of_int (500 * 1024 * 1024)) +(* Max size limit of bundle file: 1 GB*) +let bundle_max_size_limit = ref (Int64.of_int (1024 * 1024 * 1024)) type xapi_globs_spec = | Float of float ref diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index 6176729caa4..dcf87d0b503 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -3774,37 +3774,53 @@ let put_bundle_handler (req : Request.t) s _ = ~doc:"pool.sync_bundle" ~op:`sync_bundle @@ fun () -> Http_svr.headers s (Http.http_200_ok ()) ; - let repo = - Repository_helpers.get_single_enabled_update_repository ~__context - in - match Db.Repository.get_origin ~__context ~self:repo with - | `bundle -> ( - let result = - Tar_ext.unpack_tar_file - ~dir:!Xapi_globs.bundle_repository_dir - ~ifd:s - ~max_size_limit:!Xapi_globs.bundle_max_size_limit + let repo_opt = + try + let repo = + Repository_helpers.get_single_enabled_update_repository ~__context in - match result with - | Ok () -> - TaskHelper.set_progress ~__context 0.8 ; - finally - (fun () -> - sync_repos ~__context ~self:pool ~repos:[repo] ~force:true - ~token:"" ~token_id:"" - |> ignore - ) - (fun () -> Unixext.rm_rec !Xapi_globs.bundle_repository_dir) - | Error e -> - error "%s: Failed to unpack bundle with error %s" __FUNCTION__ - (Tar_ext.unpack_error_to_string e) ; - TaskHelper.failed ~__context - Api_errors.( - Server_error - (bundle_unpack_failed, [Tar_ext.unpack_error_to_string e]) - ) ; - Http_svr.headers s (Http.http_400_badrequest ()) - ) - | `remote -> - raise Api_errors.(Server_error (bundle_repo_not_enabled, [])) + Some repo + with e -> + TaskHelper.failed ~__context e ; + Http_svr.headers s (Http.http_400_badrequest ()) ; + None + in + match repo_opt with + | Some repo -> ( + match Db.Repository.get_origin ~__context ~self:repo with + | `bundle -> ( + let result = + Tar_ext.unpack_tar_file + ~dir:!Xapi_globs.bundle_repository_dir + ~ifd:s + ~max_size_limit:!Xapi_globs.bundle_max_size_limit + in + match result with + | Ok () -> + TaskHelper.set_progress ~__context 0.8 ; + finally + (fun () -> + sync_repos ~__context ~self:pool ~repos:[repo] ~force:true + ~token:"" ~token_id:"" + |> ignore + ) + (fun () -> Unixext.rm_rec !Xapi_globs.bundle_repository_dir) + | Error e -> + error "%s: Failed to unpack bundle with error %s" __FUNCTION__ + (Tar_ext.unpack_error_to_string e) ; + TaskHelper.failed ~__context + Api_errors.( + Server_error + (bundle_unpack_failed, [Tar_ext.unpack_error_to_string e]) + ) ; + Http_svr.headers s (Http.http_400_badrequest ()) + ) + | `remote -> + error "%s: Bundle repo is not enabled" __FUNCTION__ ; + TaskHelper.failed ~__context + Api_errors.(Server_error (bundle_repo_not_enabled, [])) ; + Http_svr.headers s (Http.http_400_badrequest ()) + ) + | None -> + () ) From 65e35bc553e5cb771c5fcab1c9e40c5f605394fb Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Fri, 2 Aug 2024 09:48:31 +0100 Subject: [PATCH 087/157] CA-396540: Add API error for bundle syncing failure Add a new API error for bundle syncing failure: Syncing with bundle repository failed. Signed-off-by: Bengang Yuan --- ocaml/idl/datamodel_errors.ml | 2 ++ ocaml/xapi-consts/api_errors.ml | 2 ++ ocaml/xapi/xapi_pool.ml | 9 ++++++--- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 921a289f04d..3071a4add47 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1927,6 +1927,8 @@ let _ = () ; error Api_errors.reposync_failed [] ~doc:"Syncing with remote YUM repository failed." () ; + error Api_errors.bundle_sync_failed [] + ~doc:"Syncing with bundle repository failed." () ; error Api_errors.invalid_repomd_xml [] ~doc:"The repomd.xml is invalid." () ; error Api_errors.invalid_updateinfo_xml [] ~doc:"The updateinfo.xml is invalid." () ; diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 0ade8d9cdbf..53d9684561f 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1338,6 +1338,8 @@ let sync_bundle_in_progress = add_error "SYNC_BUNDLE_IN_PROGRESS" let reposync_failed = add_error "REPOSYNC_FAILED" +let bundle_sync_failed = add_error "BUNDLE_SYNC_FAILED" + let createrepo_failed = add_error "CREATEREPO_FAILED" let invalid_updateinfo_xml = add_error "INVALID_UPDATEINFO_XML" diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index dcf87d0b503..5eae8360b7d 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -3800,9 +3800,12 @@ let put_bundle_handler (req : Request.t) s _ = TaskHelper.set_progress ~__context 0.8 ; finally (fun () -> - sync_repos ~__context ~self:pool ~repos:[repo] ~force:true - ~token:"" ~token_id:"" - |> ignore + try + sync_repos ~__context ~self:pool ~repos:[repo] ~force:true + ~token:"" ~token_id:"" + |> ignore + with _ -> + raise Api_errors.(Server_error (bundle_sync_failed, [])) ) (fun () -> Unixext.rm_rec !Xapi_globs.bundle_repository_dir) | Error e -> From cb3cd2d7dd864c807825ee75c560867aaf9bdc5a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 5 Aug 2024 13:57:21 +0100 Subject: [PATCH 088/157] CI: use ubuntu-22.04 for SDK too MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit To better share caches with the main run. Once `feature/py3` is merged, we can move all this to 24.04. Signed-off-by: Edwin Török --- .github/workflows/generate-and-build-sdks.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/generate-and-build-sdks.yml b/.github/workflows/generate-and-build-sdks.yml index 87da4b1d8f5..53ada2588da 100644 --- a/.github/workflows/generate-and-build-sdks.yml +++ b/.github/workflows/generate-and-build-sdks.yml @@ -10,7 +10,7 @@ on: jobs: generate-sdk-sources: name: Generate SDK sources - runs-on: ubuntu-20.04 + runs-on: ubuntu-22.04 steps: - name: Checkout code uses: actions/checkout@v4 From aeeade16aa2c332a8b1976b75927f3b1bd3c27d4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 5 Aug 2024 13:48:53 +0100 Subject: [PATCH 089/157] CI: avoid mixing caches from different OSes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is a bug in setup-ocaml@v3 https://github.com/ocaml/setup-ocaml/issues/839 Work it around by defining our own cache prefix based on runner OS version. Unfortunately the version itself doesn't seem to be available as a variable in GH actions. There is 'runner.os', but that is just a generic Linux, there is 'matrix.os', but that is only present when using a matrix, and there is '..container' which is only present when containers are used. Use another GH action to determine the version, and now the cache-prefix looks like this: ``` cache-prefix: v3-Ubuntu-22.04 ``` Signed-off-by: Edwin Török --- .github/workflows/setup-xapi-environment/action.yml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/.github/workflows/setup-xapi-environment/action.yml b/.github/workflows/setup-xapi-environment/action.yml index 72700599cf2..541510bb8f8 100644 --- a/.github/workflows/setup-xapi-environment/action.yml +++ b/.github/workflows/setup-xapi-environment/action.yml @@ -12,6 +12,7 @@ runs: shell: bash run: | curl --fail --silent https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env | cut -f2 -d " " > .env + cat /etc/os-release - name: Download XE_SR_ERRORCODES.xml shell: bash @@ -42,6 +43,10 @@ runs: echo "TMPDIR=${TMPDIR}" >>"$GITHUB_ENV" echo "XDG_CACHE_HOME=${XDG_CACHE_HOME}" >>"$GITHUB_ENV" + - name: Get runner OS info + uses: kenchan0130/actions-system-info@master + id: system-info + # We set DUNE_CACHE_STORAGE_MODE, it is required for dune cache to work inside opam for now, # otherwise it gets EXDEV and considers it a cache miss - name: Use ocaml @@ -52,6 +57,7 @@ runs: xs-opam: ${{ steps.dotenv.outputs.repository }} dune-cache: true opam-pin: false + cache-prefix: v3-${{ steps.system-info.outputs.name }}-${{ steps.system-info.outputs.release }} env: DUNE_CACHE_STORAGE_MODE: copy From 6ebdd1422a0af4ef639e818394af8775fd283838 Mon Sep 17 00:00:00 2001 From: Yann Dirson Date: Wed, 7 Aug 2024 15:32:02 +0200 Subject: [PATCH 090/157] openvswitch-config-update: fix python2ism in python3 PR #5261 made the switch to python3 but missed a dict.itervalues() call, which causes a failure with python3. Signed-off-by: Yann Dirson --- scripts/plugins/openvswitch-config-update | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/plugins/openvswitch-config-update b/scripts/plugins/openvswitch-config-update index d97671b14b2..834788cf138 100755 --- a/scripts/plugins/openvswitch-config-update +++ b/scripts/plugins/openvswitch-config-update @@ -104,7 +104,7 @@ def update(session, args): if new_controller: query = 'field "management"="true"' recs = session.xenapi.PIF.get_all_records_where(query) - for rec in recs.itervalues(): + for rec in recs.values(): pool_mgmt_macs[rec.get("MAC")] = rec.get("device") dib_changed = False From 31e29c1b536951eb89cd96ebeb95620dac4b8963 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Fri, 2 Aug 2024 17:49:45 +0100 Subject: [PATCH 091/157] CA-396635: Wait for corosync to update its info Sometimes it takes the underlying cluster stack (corosync) some time to return a consistent view of the quorum. For example, it may be that the membership information correctly reflects the new members after a membership change, while the quorum field is still out of date. Add a delay here to make sure that the information from corosync represents a consistent snapshot of the current cluster state. Signed-off-by: Vincent Liu --- ocaml/xapi/xapi_clustering.ml | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index 545674e92e0..249efa74da1 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -545,6 +545,13 @@ module Watcher = struct is an update. *) let cluster_change_interval = Mtime.Span.(5 * min) + (* CA-396635: Sometimes it takes the underlying cluster stack (corosync) some time + to return a consistent view of the quorum. For example, it may be that the membership + information correctly reflects the new members after a membership change, while the + quorum field is still out of date. Add a delay here to make sure that the information + from corosync represents a consistent snapshot of the current cluster state. *) + let stabilising_period = Mtime.Span.(5 * s) + let cluster_stack_watcher : bool Atomic.t = Atomic.make false (* we handle unclean hosts join and leave in the watcher, i.e. hosts joining and leaving @@ -558,10 +565,12 @@ module Watcher = struct "cluster change watcher call" (Clock.Timer.span_to_s cluster_change_interval) in - let find_cluster_and_update updates = + let find_cluster_and_update ?(wait = false) updates = match find_cluster_host ~__context ~host with | Some ch -> let cluster = Db.Cluster_host.get_cluster ~__context ~self:ch in + if wait then + Thread.delay (Clock.Timer.span_to_s stabilising_period) ; on_corosync_update ~__context ~cluster updates | None -> () @@ -569,7 +578,7 @@ module Watcher = struct match Idl.IdM.run @@ Cluster_client.IDL.T.get m with | Ok updates -> (* Received updates from corosync-notifyd *) - find_cluster_and_update updates + find_cluster_and_update ~wait:true updates | Error (InternalError "UPDATES.Timeout") -> (* UPDATES.get timed out, this is normal. *) (* CA-395789: We send a query to xapi-clusterd to fetch the latest state From 714cd532adb34e48749479665d4b7b48529e7e97 Mon Sep 17 00:00:00 2001 From: Colin James Date: Tue, 6 Aug 2024 10:56:54 +0100 Subject: [PATCH 092/157] CP-50518: Add stub for crypt_r to ocaml/auth This change adds a binding stub for the crypt_r ("re-entrant crypt") function. The introduced external function is of type: unsafe_crypt_r : key:string -> setting:string -> string option The arguments are labelled to avoid mixup. In the case of failure, None is returned (no explicit error). Otherwise, the result is Some h, where h is the string containing the computed hash. The function is annotated as being unsafe (via [@@alert ...]). This is because it is simpler for it to be exposed for testing purposes. A safer API that wraps this is more preferable. The usage pattern that most are familiar with is: h = crypt_r(k, s) h' = crypt_r(k', s) equal = h == h' However, the following is also a valid way of expressing the same, and doesn't require extracting the salt (which is embedded in the resultant hash string): h = crypt_r(k, s) h' = crypt_r(k', h) equal = h == h' There is potential for more error handling, but the largest potential for error is in supplying well formed inputs. Different implementations support different errnos, which complicates how accurate any attempt at error reporting would be. The difficulty with over-specifying the requirements of this function at the API level is that different implementations may have different behaviour. To this end, any unit testis exercising this binding will need to explicitly test invariants we expect our specific implementation to have. The precise implementation of the function installed on the host is up to the shared library we link against (which, in practice, I've found to differ in behaviour from what is installed on my host Linux machine). Signed-off-by: Colin James --- ocaml/auth/pam.ml | 11 +++++++++++ ocaml/auth/xa_auth_stubs.c | 19 +++++++++++++++++++ 2 files changed, 30 insertions(+) diff --git a/ocaml/auth/pam.ml b/ocaml/auth/pam.ml index b2049580b59..98f1cd54a17 100644 --- a/ocaml/auth/pam.ml +++ b/ocaml/auth/pam.ml @@ -15,3 +15,14 @@ external authenticate : string -> string -> unit = "stub_XA_mh_authorize" external change_password : string -> string -> unit = "stub_XA_mh_chpasswd" + +include ( + struct + external unsafe_crypt_r : key:string -> setting:string -> string option + = "stub_XA_crypt_r" + end : + sig + val unsafe_crypt_r : key:string -> setting:string -> string option + [@@alert unsafe "Direct usage of this function is not recommended."] + end +) diff --git a/ocaml/auth/xa_auth_stubs.c b/ocaml/auth/xa_auth_stubs.c index 6c6c7a5b915..0d9f10a603f 100644 --- a/ocaml/auth/xa_auth_stubs.c +++ b/ocaml/auth/xa_auth_stubs.c @@ -95,6 +95,25 @@ void __attribute__((constructor)) stub_XA_workaround(void) crypt_r("", "$6$", &data); } +/* key:string -> setting:string -> string option */ +CAMLprim value stub_XA_crypt_r(value key, value setting) { + CAMLparam2(key, setting); + CAMLlocal1(result); + + struct crypt_data cd = {0}; + + caml_enter_blocking_section(); + const char* const hashed = + crypt_r(String_val(key), String_val(setting), &cd); + caml_leave_blocking_section(); + + if (!hashed || *hashed == '*') + CAMLreturn(Val_none); + + result = caml_copy_string(hashed); + CAMLreturn(caml_alloc_some(result)); +} + /* * Local variables: * mode: C From e40543115f9345c04eeae19e746879cd48d9fd56 Mon Sep 17 00:00:00 2001 From: Colin James Date: Tue, 6 Aug 2024 13:17:17 +0100 Subject: [PATCH 093/157] CP-50518: Add quicktests for crypt_r The following small tests are provided as a quicktest suite to run on hosts: - Valid salts: a few valid salts are confirmed to compute a hash. - Invalid salts: a few erronerous salts are confirmed to fail. - Implicit salt truncation: the behaviour that any salt longer than a specified maximum (at present, 16) does not cause hash computation to fail, but rather its value gets implicitly truncated by the algorithm. - Increasing string length: strings from language 'a'+ are tested in increasing length to ensure they compute to a set of hashes that are pairwise distinct. This test is really to ensure that the algorithm does not cap the maximum key length - which would be implicitly truncated on our behalf and cause lengths over a certain threshold to hash to equivalent values. This property is worth tracking, currently it would appear there is no limit to worry about. - C style termination: OCaml strings don't rely on a C-style null terminator character ('\0') to determine their length. Consequently, '\0' can appear anywhere in OCaml strings without impeding various computations on strings. This test exercises the property that the C API expectedly does stop reading after seeing '\0'. This property should not be relied upon and its behaviour is documented here as a test. - Multiple threads hashing simultaneously: this test exercises the property that crypt_r truly is re-entrant. The test spawns a few threads with a precomputed hash (and the inputs used to compute it) and then spends ~200ms iteratively attempting to compute the same hash. If any hash computed within this ~200ms window differs from the initial hash, or any hash fails to be computed, the test fails. This property must be tested because the C stub temporarily relinquishes the runtime lock when computing the hash, thus allowing the possibility that hashes are computed in parallel. It is not committed here but this test was shown to be well formed by using the non-reentrant "crypt" function in place of crypt_r, where the test reliably fails. Switching this test over crypt_r allows it to pass. It is important that the tests are actually executed on a host - as the implementation of crypt_r (from libcrypt.so) could differ across development and target machines, but also across updates to XenServer. Some of the tests are for regression purposes only, to ensure that certain expectations are retained from time of writing. Signed-off-by: Colin James --- ocaml/quicktest/dune | 1 + ocaml/quicktest/quicktest.ml | 1 + ocaml/quicktest/quicktest_crypt_r.ml | 221 +++++++++++++++++++++++++++ 3 files changed, 223 insertions(+) create mode 100644 ocaml/quicktest/quicktest_crypt_r.ml diff --git a/ocaml/quicktest/dune b/ocaml/quicktest/dune index c4044a7ebb7..390ccb9ae66 100644 --- a/ocaml/quicktest/dune +++ b/ocaml/quicktest/dune @@ -13,6 +13,7 @@ http_lib mtime mtime.clock.os + pam qcheck-alcotest result rresult diff --git a/ocaml/quicktest/quicktest.ml b/ocaml/quicktest/quicktest.ml index 09c7f89c7c9..563ba4a88ba 100644 --- a/ocaml/quicktest/quicktest.ml +++ b/ocaml/quicktest/quicktest.ml @@ -42,6 +42,7 @@ let () = ; ("Quicktest_max_vdi_size", Quicktest_max_vdi_size.tests ()) ; ("Quicktest_static_vdis", Quicktest_static_vdis.tests ()) ; ("Quicktest_date", Quicktest_date.tests ()) + ; ("Quicktest_crypt_r", Quicktest_crypt_r.tests ()) ] @ if not !Quicktest_args.using_unix_domain_socket then diff --git a/ocaml/quicktest/quicktest_crypt_r.ml b/ocaml/quicktest/quicktest_crypt_r.ml new file mode 100644 index 00000000000..cd68f95b98a --- /dev/null +++ b/ocaml/quicktest/quicktest_crypt_r.ml @@ -0,0 +1,221 @@ +(* + * Copyright (c) Cloud Software Group, Inc + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module Pam = struct + let unsafe_crypt_r = Pam.unsafe_crypt_r [@@alert "-unsafe"] + (* Suppress the alert the purpose of testing. *) +end + +let valid_salts = + [ + "salt" (* Don't need to specify algorithm, will default to something. *) + ; "$5$salt$" (* 5 = SHA-256 should work. *) + ; "$6$salt$" (* 6 = SHA-512 should work. *) + ] + +let invalid_salts = + [ + "" (* Salt cannot be empty. *) + ; "$" (* Salt cannot be $. *) + ; "$9$salt$" (* Salt must specify valid algorithm constant. *) + ; "$6,rounds=1000$salt$" (* Salt cannot specify iteration count. *) + ; "£6£salt£" (* Only American currency is legal tender. *) + ] + +let test_salts ~msg ~succeeds salts = + let test salt = + let actual = + Option.is_some (Pam.unsafe_crypt_r ~key:"password" ~setting:salt) + in + Alcotest.((check' bool) ~msg ~expected:succeeds ~actual) + in + List.iter test salts + +let test_valid_salts () = + test_salts ~msg:"Hash can be computed from valid salt" ~succeeds:true + valid_salts + +let test_invalid_salts () = + test_salts ~msg:"Hash cannot be computed from invalid salt" ~succeeds:false + invalid_salts + +let test_salt_truncation () = + let salt_max_length = 16 in + let salt = "a_salt_that_is_longer_than_is_actually_accepted" in + assert (String.length salt > salt_max_length) ; + let test prefix_length = + (* The C API accepts at most 16 chars for the salt, optionally + enclosed within $k$salt$ - anything else is ignored (implicitly + truncated). *) + let truncated_salt = String.sub salt 0 prefix_length in + let sha512 = Printf.sprintf "$6$%s$" in + let key = "password" in + let h = Pam.unsafe_crypt_r ~key ~setting:(sha512 salt) in + let h' = Pam.unsafe_crypt_r ~key ~setting:(sha512 truncated_salt) in + if Option.(is_none h || is_none h') then + failwith (Printf.sprintf "Failed to compute hash in %s" __FUNCTION__) + else + Option.equal ( = ) h h' + in + let msg = + Printf.sprintf + "Hash computed with implicitly truncated salt is the same as explicitly \ + truncated (len = %d)\n\ + ." + in + let expectation len = + (* We expect all lengths greater than max salt length to succeed, + as they are implicitly truncated. Any length < salt_max_length + should fail. *) + len >= salt_max_length + in + for len = 0 to String.length salt do + let msg = msg len in + let actual = test len in + let expected = expectation len in + Alcotest.(check' bool) ~msg ~expected ~actual + done + +(* Invalidate the following tests if any hash fails to be computed. *) +let unsafe_crypt_r ~key ~setting = + match Pam.unsafe_crypt_r ~key ~setting with + | Some hash -> + hash + | _ -> + failwith "Invalid input provided to crypt_r" + +let test_crypt_r_many_threads () = + Printexc.record_backtrace true ; + let settings = ["$6$salt$"; "$5$salt123$"; "$6$foobar$"; "salt"] in + (* Each test case is a 3-tuple (key, setting, hash). A thread is + spawned for each test case. The hash component stores the expected + result of hashing key with setting. These hashes are computed prior + to spawning the threads so they are guaranteed to have been computed + sequentially. *) + let test_cases = + let create_case setting = + let key = "password" in + let hash = unsafe_crypt_r ~key ~setting in + (key, setting, hash) + in + List.map create_case settings + in + let num_cases = List.length test_cases in + let thread_count = Atomic.make 0 in + let ready () = Atomic.get thread_count >= num_cases in + let m = Mutex.create () in + let c = Condition.create () in + (* Each thread will populate an entry in the results array. *) + let results : (unit, _) result array = Array.make num_cases (Ok ()) in + let spawn i (key, setting, expectation) = + let loop () = + let now = Unix.gettimeofday in + let start = now () in + while now () -. start < 0.2 do + let actual = unsafe_crypt_r ~key ~setting in + Printf.printf "thread %d computed %s\n" i actual ; + flush stdout ; + if actual <> expectation then + failwith (Printf.sprintf "%s <> %s" actual expectation) + done + in + (* Record that this thread has been started, then wait for the + main thread to broadcast that the others have also started. *) + Atomic.incr thread_count ; + Mutex.lock m ; + while not (ready ()) do + Condition.wait c m + done ; + Mutex.unlock m ; + (* Run the test, capturing any exception as a result to the + negative. *) + results.(i) <- Rresult.R.trap_exn loop () + in + (* Spawn a thread per valid test case. *) + let tids = List.mapi (fun i -> Thread.create (spawn i)) test_cases in + (* Wait for all threads to identify themselves as having started + before broadcasting that they should start hashing. *) + while not (ready ()) do + Unix.sleepf 0.1 + done ; + Mutex.lock m ; + Condition.broadcast c ; + Mutex.unlock m ; + List.iter Thread.join tids ; + (* Re-raise the first encountered trapped exception with its + backtrace to ensure the test fails if any thread reported + failure. *) + let reraise = function + | Error (`Exn_trap (exn, bt)) -> + Printexc.raise_with_backtrace exn bt + | _ -> + () + in + Array.iter reraise results + +(* This test hashes strings of language 'a'+ over a small range of lengths to + ensure no duplicates occur. A suitable cryptographic hash function should have + no collisions doing this. So, if a collision occurs, it is more likely because + the underlying algorithm has a maximum length key size (and is truncating our + input). *) +let test_increasing_length () = + let min, max = (50, 140) in + (* Records hash -> length, so colliding lengths can be reported. *) + let tbl = Hashtbl.create 127 in + let setting = "$6$salt$" in + let go len = + let key = String.make len 'a' in + let hash = + try unsafe_crypt_r ~key ~setting + with _ -> + failwith (Printf.sprintf "Failed to compute hash aa..a of length %d" len) + in + match Hashtbl.find_opt tbl hash with + | Some len' -> + failwith + (Printf.sprintf "Hash value a.. (len = %d) matches a.. (len %d)" len + len' + ) + | _ -> + Hashtbl.add tbl hash len + in + for i = min to max do + go i + done + +(* This test demonstrates the behaviour that the C API will + (expectedly) only read up to the null terminator character. OCaml + strings are stored as an array of words, with the final byte + specifying how many padding bytes precede it. Since the number of + words and number of padding bytes is used to determine string length, + there is no reliance on a C-style null terminator - so '\0' can appear + anywhere in an OCaml string. *) +let test_c_truncation () = + let key = "password" in + let key' = key ^ "\x00_arbitrary_data_here" in + let setting = "$6$salt$" in + let hash = unsafe_crypt_r ~key ~setting in + let hash' = unsafe_crypt_r ~key:key' ~setting in + if hash <> hash' then + failwith "Expected truncation using C-style null termination failed" + +let tests () = + [ + ("Valid salts", `Quick, test_valid_salts) + ; ("Invalid salts", `Quick, test_invalid_salts) + ; ("Implicit salt truncation", `Quick, test_salt_truncation) + ; ("Increasing string length", `Quick, test_increasing_length) + ; ("C-style termination", `Quick, test_c_truncation) + ; ("Multiple threads", `Quick, test_crypt_r_many_threads) + ] From 727592b6d03b4408ec4c5c5b40c175696a6993cd Mon Sep 17 00:00:00 2001 From: Colin James Date: Thu, 8 Aug 2024 11:17:15 +0100 Subject: [PATCH 094/157] CP-50518: Add safer crypt API to Pam The following function is added to the Pam module: val crypt : ~algo:crypt_algo ~key ~salt Simple tests are also provided for this function. Signed-off-by: Colin James --- ocaml/auth/pam.ml | 13 +++++++ ocaml/quicktest/quicktest_crypt_r.ml | 57 +++++++++++++++++++++++++++- 2 files changed, 68 insertions(+), 2 deletions(-) diff --git a/ocaml/auth/pam.ml b/ocaml/auth/pam.ml index 98f1cd54a17..6c86bb38c8f 100644 --- a/ocaml/auth/pam.ml +++ b/ocaml/auth/pam.ml @@ -26,3 +26,16 @@ include ( [@@alert unsafe "Direct usage of this function is not recommended."] end ) + +type crypt_algorithm = SHA256 | SHA512 + +type crypt_err = SaltTooLong | HashFailure + +let crypt ~algo ~key ~salt = + if String.length salt > 16 then + Error SaltTooLong + else + let crypt_r = unsafe_crypt_r [@@alert "-unsafe"] in + let algo_id = match algo with SHA256 -> 5 | SHA512 -> 6 in + let setting = Printf.sprintf "$%d$%s$" algo_id salt in + match crypt_r ~key ~setting with Some h -> Ok h | _ -> Error HashFailure diff --git a/ocaml/quicktest/quicktest_crypt_r.ml b/ocaml/quicktest/quicktest_crypt_r.ml index cd68f95b98a..14bcf6b06d1 100644 --- a/ocaml/quicktest/quicktest_crypt_r.ml +++ b/ocaml/quicktest/quicktest_crypt_r.ml @@ -13,6 +13,8 @@ *) module Pam = struct + include Pam + let unsafe_crypt_r = Pam.unsafe_crypt_r [@@alert "-unsafe"] (* Suppress the alert the purpose of testing. *) end @@ -124,8 +126,6 @@ let test_crypt_r_many_threads () = let start = now () in while now () -. start < 0.2 do let actual = unsafe_crypt_r ~key ~setting in - Printf.printf "thread %d computed %s\n" i actual ; - flush stdout ; if actual <> expectation then failwith (Printf.sprintf "%s <> %s" actual expectation) done @@ -210,6 +210,57 @@ let test_c_truncation () = if hash <> hash' then failwith "Expected truncation using C-style null termination failed" +(* Make following tests fail if the safe API fails to return a valid result. *) +let crypt ~algo ~key ~salt = + let open struct exception CryptException of Pam.crypt_err end in + match Pam.crypt ~algo ~key ~salt with + | Ok hash -> + hash + | Error e -> + raise (CryptException e) + +(* Test trivial correspondence between safe API invocation and unsafe calls. *) +let test_api_correspondence () = + let cases = + [ + ("$5$salt123$", Pam.SHA256, "salt123") + ; ("$6$salt456$", Pam.SHA512, "salt456") + ] + in + let go (setting, algo, salt) = + let key = "password" in + let h = unsafe_crypt_r ~key ~setting in + let h' = crypt ~algo ~key ~salt in + if h <> h' then + failwith + "Hashes differ between invocations of safe and unsafe crypt_r APIs" + in + List.iter go cases + +(** Ensure the safe API fails in the way you expect. *) +let test_safe_failures () = + let key = "password" in + let cases = + [ + (* Salt exceeding maximum length. *) + ( (fun () -> + Pam.crypt ~algo:SHA256 ~key ~salt:"asaltthatexceedsthemaximumlength" + ) + , Pam.SaltTooLong + ) + ] + in + let test (case, expected_error) = + match case () with + | Ok _ -> + failwith "Expected crypt error" + | Error e when e <> expected_error -> + failwith "Actual crypt error does not match expectation" + | Error _ -> + () + in + List.iter test cases + let tests () = [ ("Valid salts", `Quick, test_valid_salts) @@ -217,5 +268,7 @@ let tests () = ; ("Implicit salt truncation", `Quick, test_salt_truncation) ; ("Increasing string length", `Quick, test_increasing_length) ; ("C-style termination", `Quick, test_c_truncation) + ; ("Safe and unsafe API", `Quick, test_api_correspondence) + ; ("Safe API error reporting", `Quick, test_safe_failures) ; ("Multiple threads", `Quick, test_crypt_r_many_threads) ] From 07db59a72d47064d137a526e75ec4a84a7bfe46f Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Tue, 23 Jul 2024 15:19:47 +0100 Subject: [PATCH 095/157] CP-50444: Intrument `request_of_bio` Intruments the request reading loop. Adds new functionality to the tracing library to update a span with a new parent. This way we can retroactively set the parent span with the correnct one. Signed-off-by: Gabriel Buica --- ocaml/libs/http-lib/http_svr.ml | 20 ++++++++++++++++++++ ocaml/libs/tracing/tracing.ml | 26 ++++++++++++++++++++++++++ ocaml/libs/tracing/tracing.mli | 12 ++++++++++++ 3 files changed, 58 insertions(+) diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index 51b2beacba8..1802e1dd4c9 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -453,9 +453,28 @@ let request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length bio already sent back a suitable error code and response to the client. *) let request_of_bio ?proxy_seen ~read_timeout ~total_timeout ~max_length ic = try + let tracer = Tracing.Tracer.get_tracer ~name:"http_tracer" in + let loop_span = + match Tracing.Tracer.start ~tracer ~name:__FUNCTION__ ~parent:None () with + | Ok span -> + span + | Error _ -> + None + in let r, proxy = request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length ic in + let parent_span = traceparent_of_request r in + let loop_span = + Option.fold ~none:None + ~some:(fun span -> + Tracing.Tracer.update_span_with_parent span parent_span + ) + loop_span + in + let _ : (Tracing.Span.t option, exn) result = + Tracing.Tracer.finish loop_span + in (Some r, proxy) with e -> D.warn "%s (%s)" (Printexc.to_string e) __LOC__ ; @@ -583,6 +602,7 @@ let handle_connection ~header_read_timeout ~header_total_timeout request_of_bio ?proxy_seen ~read_timeout ~total_timeout ~max_length:max_header_length ic in + (* 2. now we attempt to process the request *) let finished = Option.fold ~none:true diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index 28a5b2f687b..2356168da32 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -151,6 +151,8 @@ end module SpanContext = struct type t = {trace_id: string; span_id: string} [@@deriving rpcty] + let context trace_id span_id = {trace_id; span_id} + let to_traceparent t = Printf.sprintf "00-%s-%s-01" t.trace_id t.span_id let of_traceparent traceparent = @@ -624,6 +626,30 @@ module Tracer = struct let span = Span.start ~attributes ~name ~parent ~span_kind () in Spans.add_to_spans ~span ; Ok (Some span) + let update_span_with_parent span (parent : Span.t option) = + if Atomic.get observe then + match parent with + | None -> + Some span + | Some parent -> + span + |> Spans.remove_from_spans + |> Option.map (fun existing_span -> + let old_context = Span.get_context existing_span in + let new_context : SpanContext.t = + SpanContext.context + (SpanContext.trace_id_of_span_context parent.context) + old_context.span_id + in + let updated_span = {existing_span with parent= Some parent} in + let updated_span = {updated_span with context= new_context} in + + let () = Spans.add_to_spans ~span:updated_span in + updated_span + ) + else + Some span + let finish ?error span = Ok (Option.map diff --git a/ocaml/libs/tracing/tracing.mli b/ocaml/libs/tracing/tracing.mli index cd6e4204602..42b700ebb51 100644 --- a/ocaml/libs/tracing/tracing.mli +++ b/ocaml/libs/tracing/tracing.mli @@ -57,6 +57,8 @@ end module SpanContext : sig type t + val context : string -> string -> t + val to_traceparent : t -> string val of_traceparent : string -> t option @@ -125,6 +127,16 @@ module Tracer : sig -> unit -> (Span.t option, exn) result + val update_span_with_parent : Span.t -> Span.t option -> Span.t option + (**[update_span_with_parent s p] returns [Some span] where [span] is an + updated verison of the span [s]. + If [p] is [Some parent], [span] is a child of [parent], otherwise it is the + original [s]. + + If the span [s] is finished or is no longer considered an on-going span, + returns [None]. + *) + val finish : ?error:exn * string -> Span.t option -> (Span.t option, exn) result From 3fbcfb1b97f28630e31fa067586740c06fcb4fae Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Mon, 29 Jul 2024 11:23:40 +0100 Subject: [PATCH 096/157] tracing: fix `make check` warnings Fixes warning of unused records fields. These fields are part of the opentelementry spec but we are currently not using them in `xapi`. Signed-off-by: Gabriel Buica --- dune | 2 +- ocaml/libs/tracing/tracing.ml | 24 ++++++++++++------------ 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/dune b/dune index 9cf03f02dfc..e2b4842adb5 100644 --- a/dune +++ b/dune @@ -3,7 +3,7 @@ (ocamlopt_flags (:standard -g -p -w -39)) (flags (:standard -w -39)) ) - (dev (flags (:standard -g -w -39 -warn-error -69))) + (dev (flags (:standard -g -w -39))) (release (flags (:standard -w -39-6@5)) (env-vars (ALCOTEST_COMPACT 1)) diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index 2356168da32..04512f45453 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -127,7 +127,7 @@ let ok_none = Ok None module Status = struct type status_code = Unset | Ok | Error [@@deriving rpcty] - type t = {status_code: status_code; description: string option} + type t = {status_code: status_code; _description: string option} end module Attributes = struct @@ -169,7 +169,7 @@ module SpanContext = struct end module SpanLink = struct - type t = {context: SpanContext.t; attributes: (string * string) list} + type t = {_context: SpanContext.t; _attributes: (string * string) list} end module Span = struct @@ -210,7 +210,7 @@ module Span = struct (* Using gettimeofday over Mtime as it is better for sharing timestamps between the systems *) let begin_time = Unix.gettimeofday () in let end_time = None in - let status : Status.t = {status_code= Status.Unset; description= None} in + let status : Status.t = {status_code= Status.Unset; _description= None} in let links = [] in let events = [] in { @@ -252,7 +252,7 @@ module Span = struct let set_span_kind span span_kind = {span with span_kind} let add_link span context attributes = - let link : SpanLink.t = {context; attributes} in + let link : SpanLink.t = {_context= context; _attributes= attributes} in {span with links= link :: span.links} let add_event span name attributes = @@ -265,7 +265,7 @@ module Span = struct | exn, stacktrace -> ( let msg = Printexc.to_string exn in let exn_type = Printexc.exn_slot_name exn in - let description = + let _description = Some (Printf.sprintf "Error: %s Type: %s Backtrace: %s" msg exn_type stacktrace @@ -288,17 +288,17 @@ module Span = struct span.attributes (Attributes.of_list exn_attributes) in - {span with status= {status_code; description}; attributes} + {span with status= {status_code; _description}; attributes} | _ -> span ) let set_ok span = - let description = None in + let _description = None in let status_code = Status.Ok in match span.status.status_code with | Unset -> - {span with status= {status_code; description}} + {span with status= {status_code; _description}} | _ -> span end @@ -566,9 +566,9 @@ module TracerProvider = struct end module Tracer = struct - type t = {name: string; provider: TracerProvider.t} + type t = {_name: string; provider: TracerProvider.t} - let create ~name ~provider = {name; provider} + let create ~name ~provider = {_name= name; provider} let no_op = let provider : TracerProvider.t = @@ -579,7 +579,7 @@ module Tracer = struct ; enabled= false } in - {name= ""; provider} + {_name= ""; provider} let get_tracer ~name = if Atomic.get observe then ( @@ -600,7 +600,7 @@ module Tracer = struct let span_of_span_context context name : Span.t = { context - ; status= {status_code= Status.Unset; description= None} + ; status= {status_code= Status.Unset; _description= None} ; name ; parent= None ; span_kind= SpanKind.Client (* This will be the span of the client call*) From fcb781867815cb9ae6501f3a27a270e64aad3f37 Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Tue, 30 Jul 2024 11:29:01 +0100 Subject: [PATCH 097/157] tracing: increase the default maximum number of spans in a trace Increases the default maximum number of spans inside a trace from `1000` to `2500`. Now that we instrumented the internal http calls, with all components enabled, the number of spans inside `xapi` component for a `vm-start` operations is slightly greater than `1000`. This causes spans to be leaked, they are removed from the ongoing span table but never added in the finished tabled. Therefore, they are lost unless the limit is change in `/etc/xapi.conf`. This should fix the issue until we implement a better abstraction for the span hashtables. Signed-off-by: Gabriel Buica --- ocaml/libs/tracing/tracing.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index 04512f45453..22d1e942288 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -313,7 +313,7 @@ module Spans = struct Hashtbl.length spans ) - let max_spans = Atomic.make 1000 + let max_spans = Atomic.make 2500 let set_max_spans x = Atomic.set max_spans x From 0fd7d6be3059b66b656988b3941ef457858c5ee9 Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Thu, 1 Aug 2024 11:20:46 +0100 Subject: [PATCH 098/157] CP-50444: Add specialized function for tracing http requests to `Http.Request` Like the title says, this commit adds `Http.Request.with_tracing` to `Http.Request`. This should enable updating the traceparent field of a request while we process it. Signed-off-by: Gabriel Buica --- ocaml/libs/http-lib/http.ml | 23 +++++++++++++++++++++++ ocaml/libs/http-lib/http.mli | 5 +++++ ocaml/libs/http-lib/http_svr.ml | 24 ++++-------------------- ocaml/libs/http-lib/http_svr.mli | 2 -- ocaml/xapi/api_server.ml | 12 +++++------- ocaml/xapi/server_helpers.ml | 3 +++ 6 files changed, 40 insertions(+), 29 deletions(-) diff --git a/ocaml/libs/http-lib/http.ml b/ocaml/libs/http-lib/http.ml index c2f7e2aeda8..1f1e790de24 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -694,6 +694,29 @@ module Request = struct let headers, body = to_headers_and_body x in let frame_header = if x.frame then make_frame_header headers else "" in frame_header ^ headers ^ body + + let traceparent_of req = + let open Tracing in + let ( let* ) = Option.bind in + let* traceparent = req.traceparent in + let* span_context = SpanContext.of_traceparent traceparent in + let span = Tracer.span_of_span_context span_context req.uri in + Some span + + let with_tracing ?attributes ~name req f = + let open Tracing in + let parent = traceparent_of req in + with_child_trace ?attributes parent ~name (fun (span : Span.t option) -> + match span with + | Some span -> + let traceparent = + Some (span |> Span.get_context |> SpanContext.to_traceparent) + in + let req = {req with traceparent} in + f req + | None -> + f req + ) end module Response = struct diff --git a/ocaml/libs/http-lib/http.mli b/ocaml/libs/http-lib/http.mli index 91590bcdcdd..3fbae8e4c6f 100644 --- a/ocaml/libs/http-lib/http.mli +++ b/ocaml/libs/http-lib/http.mli @@ -128,6 +128,11 @@ module Request : sig val to_wire_string : t -> string (** [to_wire_string t] returns a string which could be sent to a server *) + + val traceparent_of : t -> Tracing.Span.t option + + val with_tracing : + ?attributes:(string * string) list -> name:string -> t -> (t -> 'a) -> 'a end (** Parsed form of the HTTP response *) diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index 1802e1dd4c9..e04520d8567 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -101,18 +101,9 @@ let response_of_request req hdrs = ~headers:(connection :: cache :: hdrs) "200" "OK" -let traceparent_of_request req = - let open Tracing in - let ( let* ) = Option.bind in - let* traceparent = req.Http.Request.traceparent in - let* span_context = SpanContext.of_traceparent traceparent in - let span = Tracer.span_of_span_context span_context req.uri in - Some span - let response_fct req ?(hdrs = []) s (response_length : int64) (write_response_to_fd_fn : Unix.file_descr -> unit) = - let parent = traceparent_of_request req in - let@ _ = Tracing.with_child_trace parent ~name:__FUNCTION__ in + let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in let res = { (response_of_request req hdrs) with @@ -464,7 +455,7 @@ let request_of_bio ?proxy_seen ~read_timeout ~total_timeout ~max_length ic = let r, proxy = request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length ic in - let parent_span = traceparent_of_request r in + let parent_span = Http.Request.traceparent_of r in let loop_span = Option.fold ~none:None ~some:(fun span -> @@ -517,8 +508,8 @@ let request_of_bio ?proxy_seen ~read_timeout ~total_timeout ~max_length ic = (None, None) let handle_one (x : 'a Server.t) ss context req = - let parent = traceparent_of_request req in - let@ span = Tracing.with_child_trace parent ~name:__FUNCTION__ in + let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in + let span = Http.Request.traceparent_of req in let ic = Buf_io.of_fd ss in let finished = ref false in try @@ -533,13 +524,6 @@ let handle_one (x : 'a Server.t) ss context req = (Radix_tree.longest_prefix req.Request.uri method_map) in let@ _ = Tracing.with_child_trace span ~name:"handler" in - let traceparent = - let open Tracing in - Option.map - (fun span -> Span.get_context span |> SpanContext.to_traceparent) - span - in - let req = {req with traceparent} in ( match te.TE.handler with | BufIO handlerfn -> handlerfn req ic context diff --git a/ocaml/libs/http-lib/http_svr.mli b/ocaml/libs/http-lib/http_svr.mli index 8b76d6f66c6..d85ad28a2ec 100644 --- a/ocaml/libs/http-lib/http_svr.mli +++ b/ocaml/libs/http-lib/http_svr.mli @@ -143,5 +143,3 @@ val https_client_of_req : Http.Request.t -> Ipaddr.t option val client_of_req_and_fd : Http.Request.t -> Unix.file_descr -> client option val string_of_client : client -> string - -val traceparent_of_request : Http.Request.t -> Tracing.Span.t option diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index 7ac5da45e89..38f39e9b50f 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -5,8 +5,7 @@ let ( let@ ) f x = f x (* This bit is called directly by the fake_rpc callback *) let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call = - let parent = Http_svr.traceparent_of_request req in - let@ span = Tracing.with_child_trace parent ~name:__FUNCTION__ in + let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in (* We now have the body string, the xml and the call name, and can also tell *) (* if we're a master or slave and whether the call came in on the unix domain socket or the tcp socket *) (* If we're a slave, and the call is from the unix domain socket or from the HIMN, and the call *isn't* *) @@ -25,7 +24,7 @@ let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call = forward req call is_json else let response = - let@ _ = Tracing.with_child_trace span ~name:"Server.dispatch_call" in + let@ req = Http.Request.with_tracing ~name:"Server.dispatch_call" req in Server.dispatch_call req fd call in let translated = @@ -92,8 +91,8 @@ let create_thumbprint_header req response = (** HTML callback that dispatches an RPC and returns the response. *) let callback is_json req bio _ = - let parent = Http_svr.traceparent_of_request req in - let@ span = Tracing.with_child_trace parent ~name:__FUNCTION__ in + let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in + let span = Http.Request.traceparent_of req in let fd = Buf_io.fd_of bio in (* fd only used for writing *) let body = @@ -147,8 +146,7 @@ let callback is_json req bio _ = (** HTML callback that dispatches an RPC and returns the response. *) let jsoncallback req bio _ = - let parent = Http_svr.traceparent_of_request req in - let@ _ = Tracing.with_child_trace parent ~name:__FUNCTION__ in + let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in let fd = Buf_io.fd_of bio in (* fd only used for writing *) let body = diff --git a/ocaml/xapi/server_helpers.ml b/ocaml/xapi/server_helpers.ml index ad76e38e531..e4952769c2f 100644 --- a/ocaml/xapi/server_helpers.ml +++ b/ocaml/xapi/server_helpers.ml @@ -18,6 +18,8 @@ open D exception Dispatcher_FieldNotFound of string +let ( let@ ) f x = f x + let my_assoc fld assoc_list = try List.assoc fld assoc_list with Not_found -> raise (Dispatcher_FieldNotFound fld) @@ -120,6 +122,7 @@ let dispatch_exn_wrapper f = let do_dispatch ?session_id ?forward_op ?self:_ supports_async called_fn_name op_fn marshaller fd http_req label sync_ty generate_task_for = (* if the call has been forwarded to us, then they are responsible for completing the task, so we don't need to complete it *) + let@ http_req = Http.Request.with_tracing ~name:__FUNCTION__ http_req in let called_async = sync_ty <> `Sync in if called_async && not supports_async then API.response_of_fault From cc90d32f34c83c43549605b84fe26567ef2e5628 Mon Sep 17 00:00:00 2001 From: Colin James Date: Fri, 9 Aug 2024 13:27:36 +0100 Subject: [PATCH 099/157] Output if parameter is required in JSON backend This change augments all parameter structures emitted by the JSON backend to include a "required" member that specifies whether the parameter is optional or not. Parameters are considered optional in the IDL if a default value is provided for them. The simplest example is session.login_with_password. This message permits two extra parameters, "version" and "originator" - but these are not required to successfully invoke the function. Signed-off-by: Colin James --- ocaml/idl/json_backend/gen_json.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/ocaml/idl/json_backend/gen_json.ml b/ocaml/idl/json_backend/gen_json.ml index dd24c0f11cf..446eeb04b8f 100644 --- a/ocaml/idl/json_backend/gen_json.ml +++ b/ocaml/idl/json_backend/gen_json.ml @@ -197,6 +197,7 @@ end = struct ("type", `String t) ; ("name", `String p.param_name) ; ("doc", `String p.param_doc) + ; ("required", `Bool (Option.is_none p.param_default)) ] :: params , enums @ e From 15f2a17bf727cdc9f29505900a9111e6418d3e22 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Mon, 12 Aug 2024 07:45:47 +0100 Subject: [PATCH 100/157] CP-49217: Update datamodel_lifecycle Update the auto-generated changes in `datamodel_lifecycle.ml` before the code is merged into master. Signed-off-by: Bengang Yuan --- ocaml/idl/datamodel_lifecycle.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index bfb6ce0cf2c..1a101ead83b 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -25,6 +25,8 @@ let prototyped_of_field = function Some "23.14.0" | "Observer", "uuid" -> Some "23.14.0" + | "Repository", "origin" -> + Some "24.21.0-next" | "Repository", "gpgkey_path" -> Some "22.12.0" | "Certificate", "fingerprint_sha1" -> @@ -123,6 +125,8 @@ let prototyped_of_message = function Some "22.20.0" | "Repository", "set_gpgkey_path" -> Some "22.12.0" + | "Repository", "introduce_bundle" -> + Some "24.21.0-next" | "PCI", "get_dom0_access_status" -> Some "24.14.0" | "PCI", "enable_dom0_access" -> From a61b8532f02d5c785d90716fe62568c2dffc5081 Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Mon, 12 Aug 2024 07:54:29 +0100 Subject: [PATCH 101/157] CP-49217: Update schem in Cli_operations.pool_sync_bundle Update `scheme` to `https` in `Cli_operations.pool_sync_bundle` as `http` can't be used in newcli and will be executed on slave. Signed-off-by: Bengang Yuan --- ocaml/xapi-cli-server/cli_operations.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index a64b850df40..7c693a7a25c 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -6773,7 +6773,7 @@ let pool_sync_bundle fd _printer rpc session_id params = in let uri = Uri.( - make ~scheme:"http" ~host:master_address + make ~scheme:"https" ~host:master_address ~path:Constants.put_bundle_uri ~query: [ From 571832e00303bb3e6248b042de2be2774b8973d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 12 Aug 2024 13:15:21 +0100 Subject: [PATCH 102/157] Python SDK: Move "Packaging" section out of the public docs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This has ended up in our public PyPI package description: https://pypi.org/project/XenAPI/ However it is irrelevant to a user of the package on PyPI, because they'd already get the "built" version, that has the version number inside, so they don't need OCaml or 'make' to use it. Signed-off-by: Edwin Török --- scripts/examples/python/PACKAGING.md | 8 ++++++++ scripts/examples/python/README.md | 9 --------- 2 files changed, 8 insertions(+), 9 deletions(-) create mode 100644 scripts/examples/python/PACKAGING.md diff --git a/scripts/examples/python/PACKAGING.md b/scripts/examples/python/PACKAGING.md new file mode 100644 index 00000000000..caec95e5079 --- /dev/null +++ b/scripts/examples/python/PACKAGING.md @@ -0,0 +1,8 @@ +Packaging +========= + +`setup.py` is generated using an ocaml binary that fetches the api version string from xapi. An opam switch with the [xs-opam](https://github.com/xapi-project/xs-opam) repository is needed in order to build the binary. + +To build the package `setuptools>=38.6.0` and `wheel` need to be installed in the system or in the active python virtualenv. + +To build, use the command `make`. diff --git a/scripts/examples/python/README.md b/scripts/examples/python/README.md index 7761002ac70..08bebfdb61a 100644 --- a/scripts/examples/python/README.md +++ b/scripts/examples/python/README.md @@ -8,12 +8,3 @@ Examples -------- The [examples](https://github.com/xapi-project/xen-api/tree/master/scripts/examples/python) will not work unless they have been placed in the same directory as `XenAPI.py` or `XenAPI` package from PyPI has been installed (`pip install XenAPI`) - -Packaging -========= - -`setup.py` is generated using an ocaml binary that fetches the api version string from xapi. An opam switch with the [xs-opam](https://github.com/xapi-project/xs-opam) repository is needed in order to build the binary. - -To build the package `setuptools>=38.6.0` and `wheel` need to be installed in the system or in the active python virtualenv. - -To build, use the command `make`. From 6b85e87c98ccfe69acf3ec963186db01d1bf487c Mon Sep 17 00:00:00 2001 From: Colin James Date: Tue, 13 Aug 2024 09:56:00 +0100 Subject: [PATCH 103/157] Allow remediation commits for DCO Signed-off-by: Colin James --- .github/dco.yml | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 .github/dco.yml diff --git a/.github/dco.yml b/.github/dco.yml new file mode 100644 index 00000000000..1f94d940bd1 --- /dev/null +++ b/.github/dco.yml @@ -0,0 +1,3 @@ +allowRemediationCommits: + individual: true + thirdParty: true From 2b3a0a6cfeb537c28c7f14b0a8c475d906295ea6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 13 Aug 2024 10:06:38 +0100 Subject: [PATCH 104/157] CI: fix spurious failure on busy system MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ``` File "ocaml/libs/clock/dune", line 27, characters 19-33: 27 | (names test_date test_timer_run) ^^^^^^^^^^^^^^ qcheck random seed: 423397317 Testing `Timer'. This run has ID `D009HP55'. [<35;18;6M F............. ┌──────────────────────────────────────────────────────────────────────────────┐ │ [FAIL] Timer 0 Timer.remaining. │ └──────────────────────────────────────────────────────────────────────────────┘ Sleeping for 0.150000 seconds... Sleeping for 0.000500 seconds... test `Timer.remaining` failed on ≥ 1 cases: 1ms Expected to have spare time, but got excess: 1.91μs. Duration: 1ms, actual: 999μs, timer: elapsed: 1.03ms duration: 1ms ``` Here we asked for a sleep of 0.5ms, but got woken up twice as late. And the quickcheck property was expecting that the actual wake up time won't be twice as wrong. In reality it can wake up by arbitrary amounts of time later based on how busy the OS is, but we do need to check that the wakeups are not completely wrong. So skip the check on very short durations, but keep it on the longer 100ms and 300ms tests. Signed-off-by: Edwin Török --- ocaml/libs/clock/test_timer.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ocaml/libs/clock/test_timer.ml b/ocaml/libs/clock/test_timer.ml index 3729826cfa3..b94a3c470d2 100644 --- a/ocaml/libs/clock/test_timer.ml +++ b/ocaml/libs/clock/test_timer.ml @@ -25,6 +25,12 @@ let test_timer_remaining = (not (Timer.span_is_shorter Mtime.Span.(2 * actual) ~than:duration)) ; let () = match Timer.remaining timer with + | Expired _ when half < 0.05 -> + (* OS timer may not be accurate for very short sleeps, + or the system might be busy. + Skip the strict test on very short durations, we'll still test this on the 100ms+ ones. + *) + () | Expired t -> Test.fail_reportf "Expected to have spare time, but got excess: %a. Duration: %a, \ From f33d7f6a4bd7f98a57bef6538afe3cbb65216bec Mon Sep 17 00:00:00 2001 From: Stephen Cheng Date: Mon, 12 Aug 2024 03:56:45 +0100 Subject: [PATCH 105/157] CA-397171: Replace libjemalloc.so.1 with libjemalloc.so.2 jemalloc was updated to version 5.3.0: - Provides libjemalloc.so.2 instead of libjemalloc.so.1 - No longer supported `lg_dirty_mult` option Signed-off-by: Stephen Cheng --- ocaml/xenopsd/scripts/qemu-wrapper | 6 +++--- scripts/xapi-nbd.service | 4 ++-- scripts/xapi.service | 4 ++-- scripts/xcp-networkd.service | 4 ++-- 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/ocaml/xenopsd/scripts/qemu-wrapper b/ocaml/xenopsd/scripts/qemu-wrapper index 15930adab43..9d9fc9aef8d 100644 --- a/ocaml/xenopsd/scripts/qemu-wrapper +++ b/ocaml/xenopsd/scripts/qemu-wrapper @@ -302,10 +302,10 @@ def main(argv): # set up library preload path for qemu such that it can use jemalloc qemu_env = os.environ if "LD_PRELOAD" not in qemu_env: - qemu_env["LD_PRELOAD"] = "/usr/lib64/libjemalloc.so.1" + qemu_env["LD_PRELOAD"] = "/usr/lib64/libjemalloc.so.2" else: - qemu_env["LD_PRELOAD"] = "/usr/lib64/libjemalloc.so.1:" + qemu_env["LD_PRELOAD"] - qemu_env["MALLOC_CONF"] = "narenas:1,tcache:false,lg_dirty_mult:22" + qemu_env["LD_PRELOAD"] = "/usr/lib64/libjemalloc.so.2:" + qemu_env["LD_PRELOAD"] + qemu_env["MALLOC_CONF"] = "narenas:1,tcache:false" sys.stdout.flush() sys.stderr.flush() diff --git a/scripts/xapi-nbd.service b/scripts/xapi-nbd.service index 4290fe88dec..bca7b551a14 100644 --- a/scripts/xapi-nbd.service +++ b/scripts/xapi-nbd.service @@ -4,8 +4,8 @@ After=xapi.service message-switch.service syslog.target Wants=xapi.service message-switch.service syslog.target [Service] -Environment="LD_PRELOAD=/usr/lib64/libjemalloc.so.1" -Environment="MALLOC_CONF=narenas:1,tcache:false,lg_dirty_mult:22" +Environment="LD_PRELOAD=/usr/lib64/libjemalloc.so.2" +Environment="MALLOC_CONF=narenas:1,tcache:false" Environment=OCAMLRUNPARAM=b # The --certfile option must match the server-cert-path in xapi.conf # and the PathExists in xapi-nbd.path: any change must be made in all three files. diff --git a/scripts/xapi.service b/scripts/xapi.service index 58923c0a92c..e51c228989c 100644 --- a/scripts/xapi.service +++ b/scripts/xapi.service @@ -21,8 +21,8 @@ Conflicts=shutdown.target [Service] User=root -Environment="LD_PRELOAD=/usr/lib64/libjemalloc.so.1" -Environment="MALLOC_CONF=narenas:1,tcache:true,lg_dirty_mult:22" +Environment="LD_PRELOAD=/usr/lib64/libjemalloc.so.2" +Environment="MALLOC_CONF=narenas:1,tcache:true" Type=simple Restart=on-failure ExecStart=@LIBEXECDIR@/xapi-init start diff --git a/scripts/xcp-networkd.service b/scripts/xcp-networkd.service index e6aa2c5da93..eb49512cf24 100644 --- a/scripts/xcp-networkd.service +++ b/scripts/xcp-networkd.service @@ -6,8 +6,8 @@ Wants=forkexecd.service message-switch.service syslog.target [Service] Type=notify -Environment="LD_PRELOAD=/usr/lib64/libjemalloc.so.1" -Environment="MALLOC_CONF=narenas:1,tcache:false,lg_dirty_mult:22" +Environment="LD_PRELOAD=/usr/lib64/libjemalloc.so.2" +Environment="MALLOC_CONF=narenas:1,tcache:false" Environment=OCAMLRUNPARAM=b EnvironmentFile=-/etc/sysconfig/xcp-networkd ExecStart=/usr/sbin/xcp-networkd $XCP_NETWORKD_OPTIONS From 92561391840d9de31ad70249166ee43c2de9cb8d Mon Sep 17 00:00:00 2001 From: Ashwinh Date: Mon, 5 Aug 2024 15:09:38 +0000 Subject: [PATCH 106/157] CA-392685: Replace /tmp/network-reset with /var/tmp/network-reset to persist tmp file after reboot - Modified xapi_globs.ml to include this change. Signed-off-by: Ashwinh --- ocaml/xapi/xapi_globs.ml | 2 +- scripts/xe-reset-networking | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index f52dd8a2709..cdd6b8c16bb 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -639,7 +639,7 @@ let metrics_prefix_mem_vms = "xcp-rrdd-mem_vms" let metrics_prefix_pvs_proxy = "pvsproxy-" (** Path to trigger file for Network Reset. *) -let network_reset_trigger = "/tmp/network-reset" +let network_reset_trigger = "/var/tmp/network-reset" let first_boot_dir = "/etc/firstboot.d/" diff --git a/scripts/xe-reset-networking b/scripts/xe-reset-networking index 38f676a5aaa..a5bd437f9d3 100755 --- a/scripts/xe-reset-networking +++ b/scripts/xe-reset-networking @@ -24,7 +24,7 @@ from optparse import OptionParser pool_conf = '@ETCXENDIR@/pool.conf' inventory_file = '@INVENTORY@' management_conf = '/etc/firstboot.d/data/management.conf' -network_reset = '/tmp/network-reset' +network_reset = '/var/tmp/network-reset' def read_dict_file(fname): f = open(fname, 'r') From 69ee5b97e1f0cd26f83ac087c4962c82d65379f4 Mon Sep 17 00:00:00 2001 From: Colin James Date: Tue, 13 Aug 2024 12:24:23 +0100 Subject: [PATCH 107/157] Retroactively sign off 8337fa94b76097428621d1e1987 On behalf of Colin , I, Colin James , hereby add my Signed-off-by to this commit: 8337fa94b76097428621d1e1987c5d66c1b82095 Signed-off-by: Colin James From b33ceee9970b6447f1cd153e7678fda2615e6e83 Mon Sep 17 00:00:00 2001 From: Mark Syms Date: Tue, 6 Aug 2024 14:27:18 +0100 Subject: [PATCH 108/157] CA-396751: write updated RRDD data before headers Ensure that the updated data and metadata are written before the headers are updated otherwise xcp-rrdd might start reading the data block before all the data is populated and thus run off the end of the data. Signed-off-by: Mark Syms --- ocaml/xcp-rrdd/scripts/rrdd/rrdd.py | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/ocaml/xcp-rrdd/scripts/rrdd/rrdd.py b/ocaml/xcp-rrdd/scripts/rrdd/rrdd.py index a5dadf326c8..1132fa92b53 100644 --- a/ocaml/xcp-rrdd/scripts/rrdd/rrdd.py +++ b/ocaml/xcp-rrdd/scripts/rrdd/rrdd.py @@ -283,7 +283,8 @@ def wait_until_next_reading(self, neg_shift=1): self.lazy_complete_init() next_reading = self.register() wait_time = next_reading - neg_shift - if wait_time < 0: wait_time %= self.frequency_in_seconds + if wait_time < 0: + wait_time %= self.frequency_in_seconds time.sleep(wait_time) return except socket.error: @@ -310,13 +311,10 @@ def update(self): metadata_json = json.dumps(metadata, sort_keys=True).encode('utf-8') metadata_checksum = crc32(metadata_json) & 0xffffffff - self.dest.seek(0) - self.dest.write('DATASOURCES'.encode()) - self.dest.write(pack(">LLLQ", - data_checksum, - metadata_checksum, - len(self.datasources), - timestamp)) + # First write the updated data and metadata + encoded_datasource_header = 'DATASOURCES'.encode() + # DATASOURCES + 20 for 32 + 32 + 32 + 64 + self.dest.seek(len(encoded_datasource_header) + 20) for val in data_values: # This is already big endian encoded self.dest.write(val) @@ -324,6 +322,16 @@ def update(self): self.dest.write(pack(">L", len(metadata_json))) self.dest.write(metadata_json) self.dest.flush() + + # Now write the updated header + self.dest.seek(0) + self.dest.write(encoded_datasource_header) + self.dest.write(pack(">LLLQ", + data_checksum, + metadata_checksum, + len(self.datasources), + timestamp)) + self.dest.flush() self.datasources = [] time.sleep( 0.003) # wait a bit to ensure wait_until_next_reading will block From 1a1d5ce51519dcf5f8d9e3daac9d4ae0aecbf3bb Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Wed, 14 Aug 2024 07:05:04 +0100 Subject: [PATCH 109/157] CP-49217: Bump up schema vsn Bump `schema_minor_vsn` as this feature adds a new field repository.origin. Signed-off-by: Bengang Yuan --- ocaml/idl/datamodel_common.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/idl/datamodel_common.ml b/ocaml/idl/datamodel_common.ml index 9afd7bd37c0..ec7e2d7fdb2 100644 --- a/ocaml/idl/datamodel_common.ml +++ b/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 = 780 +let schema_minor_vsn = 781 (* Historical schema versions just in case this is useful later *) let rio_schema_major_vsn = 5 From ce24e0a8fbbab5e84a2c0a380ba22e1d6bdf67a3 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 13 Aug 2024 16:47:12 +0800 Subject: [PATCH 110/157] CA-397268: vbd.create failed: The device name is invalid In the commit 62db5cb, the device name validation was consolidated with the function which converts name to device number. Particularly, the function "Device_number.of_string" is used for both the validation and the conversion. But one issue was introduced in the validation is that the "None" value returned from "Device_number.of_string" is considered as valid. This causes the error "the device name is invalid". This commit just fixes this issue. Signed-off-by: Ming Lu --- ocaml/xapi/xapi_vbd_helpers.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/xapi/xapi_vbd_helpers.ml b/ocaml/xapi/xapi_vbd_helpers.ml index 1285c740c27..94471108e41 100644 --- a/ocaml/xapi/xapi_vbd_helpers.ml +++ b/ocaml/xapi/xapi_vbd_helpers.ml @@ -377,7 +377,7 @@ let clear_current_operations ~__context ~self = (** Check if the device string has the right form *) let valid_device dev ~_type = dev = "autodetect" - || Option.is_none (Device_number.of_string dev ~hvm:false) + || Option.is_some (Device_number.of_string dev ~hvm:false) || match _type with | `Floppy -> From d04ba273582d6572820661c04e0ea25145f32112 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 14 Aug 2024 14:10:03 +0800 Subject: [PATCH 111/157] CA-397268: Add unit test for valid_device Signed-off-by: Ming Lu --- ocaml/tests/test_xapi_vbd_helpers.ml | 29 ++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/ocaml/tests/test_xapi_vbd_helpers.ml b/ocaml/tests/test_xapi_vbd_helpers.ml index 0aa4ef0a6d1..101abf6dd82 100644 --- a/ocaml/tests/test_xapi_vbd_helpers.ml +++ b/ocaml/tests/test_xapi_vbd_helpers.ml @@ -85,6 +85,34 @@ let test_ca253933_valid_operations () = in List.iter operation_is_valid valid_operations +let test_valid_device () = + let valid_devices = + [ + ("autodetect", `Floppy) + ; ("sda", `Disk) + ; ("sda0", `Disk) + ; ("sdp", `Disk) + ; ("sdp99", `Disk) + ; ("xvda", `Disk) + ; ("xvda0", `Disk) + ; ("xvdp", `Disk) + ; ("xvdp99", `Disk) + ; ("hda", `Disk) + ; ("hda0", `Disk) + ; ("hdp", `Disk) + ; ("hdp99", `Disk) + ; ("fda", `Disk) + ; ("fdb", `Disk) + ; ("0", `CD) + ; ("1", `CD) + ] + in + let check (dev, _type) = + let f = Xapi_vbd_helpers.valid_device in + Alcotest.(check bool) "must be equal" true (f dev ~_type) + in + List.iter check valid_devices + let test = [ ( "test_ca253933_invalid_operations" @@ -92,4 +120,5 @@ let test = , test_ca253933_invalid_operations ) ; ("test_ca253933_valid_operations", `Quick, test_ca253933_valid_operations) + ; ("test_valid_device", `Quick, test_valid_device) ] From d5b362330bdd724efd9204fb490ec38c49432110 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 5 Aug 2024 13:21:56 +0100 Subject: [PATCH 112/157] Quicktest: actually run the quickcheck tests too MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Parenthesis were in the wrong place, so when you ran just the non-XAPI tests by hand it worked, but when running all tests automatically it skipped the qcheck tests. I'm fairly sure I fixed this bug previously, but must've gotten lost during a rebase. Signed-off-by: Edwin Török --- ocaml/quicktest/quicktest.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/ocaml/quicktest/quicktest.ml b/ocaml/quicktest/quicktest.ml index 563ba4a88ba..48bfc34c998 100644 --- a/ocaml/quicktest/quicktest.ml +++ b/ocaml/quicktest/quicktest.ml @@ -44,16 +44,16 @@ let () = ; ("Quicktest_date", Quicktest_date.tests ()) ; ("Quicktest_crypt_r", Quicktest_crypt_r.tests ()) ] + @ ( if not !Quicktest_args.using_unix_domain_socket then + [("http", Quicktest_http.tests)] + else + [] + ) @ - if not !Quicktest_args.using_unix_domain_socket then - [("http", Quicktest_http.tests)] + if not !Quicktest_args.skip_stress then + qchecks else [] - @ - if not !Quicktest_args.skip_stress then - qchecks - else - [] in (* Only list tests if asked, without running them *) if !Quicktest_args.list_tests then From ac485b4cc22646b004e771b7824496c6d6dee7f8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 5 Aug 2024 09:36:12 +0100 Subject: [PATCH 113/157] xapi-fd-test: fix compatibility with old losetup MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The version we have in Dom0 is too old and doesn't support these flags. We can only test 512 block size. Signed-off-by: Edwin Török --- .../lib/xapi-fd-test/observations.ml | 4 +--- .../xapi-stdext/lib/xapi-fdcaps/operations.ml | 14 ++----------- .../lib/xapi-fdcaps/operations.mli | 3 +-- .../lib/xapi-fdcaps/test/test_operations.ml | 21 +++---------------- 4 files changed, 7 insertions(+), 35 deletions(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml index d9320234c38..3129b06ce53 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml @@ -58,9 +58,7 @@ let with_kind_wo kind f = | Unix.S_LNK -> invalid_arg "S_LNK" (* O_NOFOLLOW not bound in OCaml *) | Unix.S_BLK -> - let@ name, out = with_tempfile () in - (* block device must have an initial size *) - ftruncate out 512L ; + let@ name, _out = with_tempfile ~size:512L () in let@ blkname, _ = with_temp_blk name in let@ fd_ro = with_fd @@ open_ro blkname in let@ fd = with_fd @@ open_wo blkname in diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml index bce25cdcd03..d5db8210aa4 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml @@ -229,18 +229,8 @@ let check_output cmd args = | _ -> failwith (Printf.sprintf "%s exited nonzero" cmd) -let with_temp_blk ?(sector_size = 512) name f = - let blkdev = - check_output "losetup" - [ - "--show" - ; "--sector-size" - ; string_of_int sector_size - ; "--direct-io=on" - ; "--find" - ; name - ] - in +let with_temp_blk name f = + let blkdev = check_output "losetup" ["--show"; "--find"; name] in let custom_ftruncate size = Unix.LargeFile.truncate name size ; let (_ : string) = check_output "losetup" ["--set-capacity"; name] in diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli index 6097f8cddf5..cf65b2aab68 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli @@ -246,8 +246,7 @@ val with_tempfile : (** [with_tempfile () f] calls [f (name, outfd)] with the name of a temporary file and a file descriptor opened for writing. Deletes the temporary file when [f] finishes. *) -val with_temp_blk : - ?sector_size:int -> string -> (string * ([> rdwr], [> blk]) make -> 'a) -> 'a +val with_temp_blk : string -> (string * ([> rdwr], [> blk]) make -> 'a) -> 'a (** [with_temp_blk ?sector_size path f] calls [f (name, fd)] with a name and file descriptor pointing to a block device. The block device is temporarily created on top of [path]. diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml index fa60e5f6682..bd8664e9c87 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml @@ -183,13 +183,13 @@ let test_sock_shutdown_all () = let@ () = Alcotest.check_raises "write after shutdown" exn in write_fd fd1 -let test_block sector_size = +let test_block () = let with_make () f = let@ name, fd = with_tempfile () in ftruncate fd 8192L ; let run () = try - let@ _blkname, fd = with_temp_blk ~sector_size name in + let@ _blkname, fd = with_temp_blk name in f fd with Failure _ -> let bt = Printexc.get_raw_backtrace () in @@ -204,19 +204,6 @@ let test_block sector_size = test_fd with_make [("read", read_fd); ("write", write_fd); ("lseek", test_lseek)] -let test_block_nest = - let with_make () f = - if Unix.geteuid () <> 0 then - Alcotest.skip () ; - let@ name, fd = with_tempfile () in - ftruncate fd 8192L ; - let@ blkname, _fd = with_temp_blk ~sector_size:4096 name in - let@ _blkname, fd = with_temp_blk ~sector_size:512 blkname in - f fd - in - test_fd with_make - [("read", read_fd); ("write", write_fd); ("lseek", test_lseek)] - let test_creat () = let name = Filename.temp_file __MODULE__ (Unix.getpid () |> string_of_int) in Unix.unlink name ; @@ -295,9 +282,7 @@ let () = ("pipe", test_pipe) ; ("socket", test_sock) ; ("regular", test_regular) - ; ("block 512", test_block 512) - ; ("block 4k", test_block 4096) - ; ("block 512 on 4k", test_block_nest) + ; ("block", test_block ()) ; ("xapi_fdcaps", tests) ; ("no fd leaks", [Alcotest.test_case "no leaks" `Quick test_no_leaks]) ] From 79b81dcebb055f6698a09c2f87e690e222c662c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 5 Aug 2024 09:36:55 +0100 Subject: [PATCH 114/157] xapi-fd-test: fix BLK tests MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit These only run when root. However certain combinations are not valid: we cannot insert delays when reading/writing, because the other side won't get any completion notifications, so we cannot check the usual way whether time_limited_{read,write} has completed. Skip BLK tests with delays. Signed-off-by: Edwin Török --- .../lib/xapi-stdext-unix/test/unixext_test.ml | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml index 656dcc1fe56..95d00f421d8 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml @@ -39,11 +39,23 @@ let pp_pair = ) *) +let skip_blk_timed behaviour = + let open Generate in + (* select/poll on block device returns immediately, + so we cannot apply any delays on the reads/writes: + they won't be reflected on the other side yet + *) + QCheck2.assume + (behaviour.kind <> Unix.S_BLK + || Option.is_none behaviour.delay_write + && Option.is_none behaviour.delay_read + ) + let test_time_limited_write = let gen = Gen.tup2 Generate.t Generate.timeouts and print = Print.tup2 Generate.print Print.float in Test.make ~name:__FUNCTION__ ~print gen @@ fun (behaviour, timeout) -> - skip_blk behaviour.kind ; + skip_blk_timed behaviour ; skip_dirlnk behaviour.kind ; try let test_elapsed = ref Mtime.Span.zero in @@ -108,6 +120,7 @@ let test_time_limited_read = (* Format.eprintf "Testing %s@." (print (behaviour, timeout)); *) skip_blk behaviour.kind ; skip_dirlnk behaviour.kind ; + skip_blk_timed behaviour ; let test_elapsed = ref Mtime.Span.zero in let test wrapped_fd = let fd = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd in From 8f89e63b1c28f4ad27a3030a84add4505466a37a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 5 Aug 2024 09:46:04 +0100 Subject: [PATCH 115/157] xapi-fd-test: fix BLK EBADF MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The file descriptor gets closed when the channel is closed, so we need to use Unix.dup here to avoid a double close and avoid an EBADF. Signed-off-by: Edwin Török --- ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml index d5db8210aa4..5e5ec0572dc 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml @@ -207,7 +207,7 @@ let with_tempfile ?size () f = try Unix.unlink name with Unix.Unix_error (_, _, _) -> () in let@ () = Fun.protect ~finally in - let t = ch |> Unix.descr_of_out_channel |> make_wo_exn `reg in + let t = ch |> Unix.descr_of_out_channel |> Unix.dup |> make_wo_exn `reg in let@ t = with_fd t in size |> Option.iter (fun size -> ftruncate t size) ; f (name, t) From 2bf0dd6c65be8285ec3a6999c7e1512684f71b16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 5 Aug 2024 10:28:41 +0100 Subject: [PATCH 116/157] Quicktest: add unixext_test MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit And increase ulimit when running quicktest, to cope with open-1024 on startup. Signed-off-by: Edwin Török --- ocaml/quicktest/dune | 1 + ocaml/quicktest/quicktest | 1 + ocaml/quicktest/quicktest.ml | 6 +++++- 3 files changed, 7 insertions(+), 1 deletion(-) diff --git a/ocaml/quicktest/dune b/ocaml/quicktest/dune index 390ccb9ae66..9a8a4a75043 100644 --- a/ocaml/quicktest/dune +++ b/ocaml/quicktest/dune @@ -20,6 +20,7 @@ rpclib.core rrdd_libs stunnel + unixext_test bufio_test test_timer threads.posix diff --git a/ocaml/quicktest/quicktest b/ocaml/quicktest/quicktest index c9e0d2de1f5..89fa7927fef 100644 --- a/ocaml/quicktest/quicktest +++ b/ocaml/quicktest/quicktest @@ -1,4 +1,5 @@ #!/bin/bash +ulimit -n 2048 # Run quicktest with support for exception backtraces. OCAMLRUNPARAM=b "@OPTDIR@/debug/quicktestbin" "$@" diff --git a/ocaml/quicktest/quicktest.ml b/ocaml/quicktest/quicktest.ml index 48bfc34c998..38a139666ae 100644 --- a/ocaml/quicktest/quicktest.ml +++ b/ocaml/quicktest/quicktest.ml @@ -15,7 +15,11 @@ (** The main entry point of the quicktest executable *) let qchecks = - [("bufio", Bufio_test.tests); ("Timer", Test_timer.tests)] + [ + ("unixext", Unixext_test.tests) + ; ("bufio", Bufio_test.tests) + ; ("Timer", Test_timer.tests) + ] |> List.map @@ fun (name, test) -> (name, List.map QCheck_alcotest.(to_alcotest ~long:true) test) From ccd819754bb1be0abd2711ca0b889420b59472c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 29 Jul 2024 22:26:41 +0100 Subject: [PATCH 117/157] xapi_fd_test: introduce testable_file_kind MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Like file_kind, but exclude file kinds that the current program cannot generate, e.g. exclude block devices when not root. Signed-off-by: Edwin Török --- .../xapi-stdext/lib/xapi-fd-test/generate.ml | 27 +++++++++++++++++-- .../xapi-stdext/lib/xapi-fd-test/generate.mli | 13 +++++++++ 2 files changed, 38 insertions(+), 2 deletions(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml index 96cd2a897e6..355f220e383 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml @@ -28,11 +28,30 @@ let make ~size ~delay_read ~delay_write kind = open QCheck2 +let all_file_kinds = Unix.[S_BLK; S_CHR; S_DIR; S_FIFO; S_LNK; S_REG; S_SOCK] + let file_kind = - ( Gen.oneofa Unix.[|S_BLK; S_CHR; S_DIR; S_FIFO; S_LNK; S_REG; S_SOCK|] + (* [Gen.oneofa] should be more efficient than [Gen.oneofl] *) + ( all_file_kinds |> Array.of_list |> Gen.oneofa , Print.contramap (Fmt.to_to_string Safefd.pp_kind) Print.string ) +let is_testable_kind = function + | Unix.(S_DIR | S_LNK) -> + (* unless you write a custom C binding, you cannot open these in OCaml *) + false + | Unix.S_BLK -> + Unix.geteuid () = 0 + | Unix.(S_CHR | S_FIFO | S_REG | S_SOCK) -> + (* We cannot create new [S_CHR], but there are preexisting [S_CHR], + like [/dev/null]. *) + true + +let testable_file_kind = + ( all_file_kinds |> List.filter is_testable_kind |> Array.of_list |> Gen.oneofa + , snd file_kind + ) + (* also coincidentally the pipe buffer size on Linux *) let ocaml_unix_buffer_size = 65536 @@ -72,8 +91,12 @@ let delay_of_size total_delay size = let t = let open Gen in (* order matters here for shrinking: shrink timeout first so that shrinking completes sooner! *) - let* total_delay = total_delays and* size = sizes and* kind = fst file_kind in + let* total_delay = total_delays + and* size = sizes + and* kind = fst testable_file_kind in + let size = if kind = Unix.S_BLK then 512 else size in let* delay = delay_of_size total_delay size in + (* see observations.ml, we can't easily change size afterwards *) return @@ make ~delay_read:delay ~delay_write:delay ~size kind let print t = diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli index 6aba67c7a6d..f403dc9d025 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli @@ -85,3 +85,16 @@ val run_rw : @returns observations about [f]'s actions the file descriptor *) + +val file_kind : Unix.file_kind QCheck2.Gen.t * Unix.file_kind QCheck2.Print.t +(** [file_kind] is a {!type:Unix.file_kind} generator and pretty printer. + It generates all file kinds, even ones that normally cannot be opened in OCaml, + like {!val:Unix.S_DIR}, or that require special privileges, like {!val:Unix.S_BLK} + + See also {!val:testable_file_kind}. + *) + +val testable_file_kind : + Unix.file_kind QCheck2.Gen.t * Unix.file_kind QCheck2.Print.t +(** [testable_file_kind] is like {!val:file_kind}, but only generates file kinds + that the current program can create. *) From aaec96d961de687f78fd401853f1b41f641d6b98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 29 Jul 2024 22:43:46 +0100 Subject: [PATCH 118/157] xapi-fd-test: introduce with kind list MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Generate a list of file descriptors, with nested try/finally closing. Signed-off-by: Edwin Török --- .../lib/xapi-fd-test/observations.ml | 15 +++++++++++++++ .../lib/xapi-fd-test/observations.mli | 19 +++++++++++++++++++ 2 files changed, 34 insertions(+) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml index 3129b06ce53..3e729551c99 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml @@ -307,3 +307,18 @@ let observe_rw read write ~f ~size kind expected = |> Option.map @@ fun write -> {write with data= Buffer.contents written} in ({read; write; elapsed}, res) + +let rec with_kind_list create aux f = function + | [] -> + f (List.rev aux) + | kind :: tl -> + create kind @@ fun fd1 fd2 -> + with_kind_list create ((fd1, fd2) :: aux) f tl + +let with_kind_list g lst f = with_kind_list g [] f lst + +let with_kinds_ro lst = with_kind_list with_kind_ro lst + +let with_kinds_wo lst = with_kind_list with_kind_wo lst + +let with_kinds_rw lst = with_kind_list with_kind_rw lst diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli index 4300f5d56d7..412e8fd8c07 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli @@ -28,6 +28,12 @@ val with_kind_ro : For character devices it receives a {!val:null} device. *) +val with_kinds_ro : + Unix.file_kind list + -> ((([> rdonly], kind) make * ([> writable], kind) make option) list -> 'a) + -> 'a +(** [with_kinds_ro kinds f] is like {!val:with_kind_ro} but for a list of file kinds. *) + val with_kind_wo : Unix.file_kind -> (([> wronly], kind) make -> ([> readable], kind) make option -> 'a) @@ -35,11 +41,24 @@ val with_kind_wo : (** [with_kind_wo kind f] is like {!val:with_kind_ro} but creates a write only file. *) +val with_kinds_wo : + Unix.file_kind list + -> ((([> wronly], kind) make * ([> readable], kind) make option) list -> 'a) + -> 'a +(** [with_kinds_wo kind f] is like {!val:with_kind_wo} but for a list of file kinds. *) + val with_kind_rw : Unix.file_kind -> (([> rdwr], kind) make -> ([> rdwr], kind) make -> 'a) -> 'a (** [with_kind_rw kind f] is like {!val:with_kind_ro} but creates a read-write file. *) +val with_kinds_rw : + Unix.file_kind list + -> ((([> rdwr], kind) make * ([> rdwr], kind) make) list -> 'a) + -> 'a +(** [with_kinds_rw kind f] is like {!val:with_kind_rw} but for a list of file kinds. +*) + (** {1 Observe operations} *) val observe_read : From 60a47d4a273547f554da98039f4f23e566defb50 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 5 Aug 2024 09:45:51 +0100 Subject: [PATCH 119/157] xapi-fd-test: introduce testable_file_kinds MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- .../xapi-stdext/lib/xapi-fd-test/generate.ml | 22 +++++++++++++++++++ .../xapi-stdext/lib/xapi-fd-test/generate.mli | 3 +++ 2 files changed, 25 insertions(+) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml index 355f220e383..3292296aa04 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml @@ -52,6 +52,28 @@ let testable_file_kind = , snd file_kind ) +let testable_file_kinds = + let f, _ = testable_file_kind in + let open Gen in + (* make sure we generate the empty list with ~50% probability, + and that we generate smaller lists more frequently + *) + let* size_bound = frequencya [|(4, 0); (4, 2); (2, 10); (1, 510)|] in + let size_gen = int_bound size_bound in + let repeated_list = + let* size = size_gen in + list_repeat size f + in + (* generates 2 kinds of lists: + - lists that contain only a single file kind + - lists that contain multiple file kinds + + This is important for testing [select], because a single + [Unix.S_REG] would cause it to return immediately, + making it unlikely that we're actually testing the behaviour for other file descriptors. + *) + oneof [repeated_list; list_size size_gen f] + (* also coincidentally the pipe buffer size on Linux *) let ocaml_unix_buffer_size = 65536 diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli index f403dc9d025..2186e83ae04 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli @@ -98,3 +98,6 @@ val testable_file_kind : Unix.file_kind QCheck2.Gen.t * Unix.file_kind QCheck2.Print.t (** [testable_file_kind] is like {!val:file_kind}, but only generates file kinds that the current program can create. *) + +val testable_file_kinds : Unix.file_kind list QCheck2.Gen.t +(** [testable_file_kinds] generates multiple file kinds, suitable for [select/poll/epoll]. *) From 592cc2d909068372974888eeca0170bf25674da5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 5 Aug 2024 09:48:35 +0100 Subject: [PATCH 120/157] xapi-fd-test: generate inputs for select MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Generate 3 sets of file descriptors and a timeout. Try to generate interesting combinations: * empty lists * lists with the same file kinds * lists with mixed file kinds * lists with common elements * bias towards generating very short lists Signed-off-by: Edwin Török --- ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune | 2 +- .../xapi-stdext/lib/xapi-fd-test/generate.ml | 59 +++++++- .../xapi-stdext/lib/xapi-fd-test/generate.mli | 8 +- .../lib/xapi-fd-test/observations.ml | 143 +++++++++++++++++- .../lib/xapi-fd-test/observations.mli | 29 +++- .../xapi-stdext/lib/xapi-fdcaps/operations.ml | 4 + .../lib/xapi-fdcaps/operations.mli | 8 + 7 files changed, 240 insertions(+), 13 deletions(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune index 146eadc9e0b..07ce09f8745 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune @@ -1,7 +1,7 @@ ; This will be used to test stdext itself, so do not depend on stdext here (library (name xapi_fd_test) - (libraries (re_export xapi-stdext-unix.fdcaps) unix qcheck-core logs fmt (re_export mtime) mtime.clock.os rresult threads.posix) + (libraries clock (re_export xapi-stdext-unix.fdcaps) unix qcheck-core logs fmt (re_export mtime) mtime.clock.os rresult threads.posix) ; off by default, enable with --instrument-with bisect_ppx (instrumentation (backend bisect_ppx)) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml index 3292296aa04..5b89f8d73aa 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml @@ -52,17 +52,16 @@ let testable_file_kind = , snd file_kind ) -let testable_file_kinds = - let f, _ = testable_file_kind in +let file_list gen = let open Gen in (* make sure we generate the empty list with ~50% probability, and that we generate smaller lists more frequently *) - let* size_bound = frequencya [|(4, 0); (4, 2); (2, 10); (1, 510)|] in + let* size_bound = frequencya [|(4, 0); (4, 2); (2, 10); (1, 100)|] in let size_gen = int_bound size_bound in let repeated_list = let* size = size_gen in - list_repeat size f + list_repeat size gen in (* generates 2 kinds of lists: - lists that contain only a single file kind @@ -72,7 +71,7 @@ let testable_file_kinds = [Unix.S_REG] would cause it to return immediately, making it unlikely that we're actually testing the behaviour for other file descriptors. *) - oneof [repeated_list; list_size size_gen f] + oneof [repeated_list; list_size size_gen gen] (* also coincidentally the pipe buffer size on Linux *) let ocaml_unix_buffer_size = 65536 @@ -185,3 +184,53 @@ let run_rw t data ~f = single_write_substring in observe_rw read write ~f t.kind ~size:t.size data + +let has_immediate_timeout = function + | Unix.S_FIFO | Unix.S_SOCK -> + false + | _ -> + true + +let select_fd_spec = + let open Gen in + let+ kind = fst testable_file_kind and+ wait = timeouts in + {kind; wait= (if has_immediate_timeout kind then 0. else wait)} + +let select_fd_spec_list = file_list select_fd_spec + +let is_rw_kind (t : select_fd_spec) = + match t.kind with Unix.S_SOCK | Unix.S_REG -> true | _ -> false + +let select_input_gen = + let open Gen in + let+ ro = select_fd_spec_list + and+ wo = select_fd_spec_list + and+ rw = select_fd_spec_list + and+ re = select_fd_spec_list + and+ we = select_fd_spec_list + and+ errors = select_fd_spec_list + and+ timeout = timeouts in + { + ro + ; wo + ; rw= List.filter is_rw_kind rw + ; re + ; we + ; errors= List.filter is_rw_kind errors + ; timeout + } + +let print_fd_spec = + let open Observations in + Print.contramap (fun t -> (t.kind, t.wait)) + @@ Print.tup2 (snd file_kind) Print.float + +let print_fd_spec_list = Print.list print_fd_spec + +let select_input_print = + let to_tup t = (t.ro, t.wo, t.rw, t.re, t.we, t.errors, t.timeout) in + Print.contramap to_tup + @@ Print.tup7 print_fd_spec_list print_fd_spec_list print_fd_spec_list + print_fd_spec_list print_fd_spec_list print_fd_spec_list Print.float + +let select_input = (select_input_gen, select_input_print) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli index 2186e83ae04..5fc4aedebdb 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli @@ -99,5 +99,9 @@ val testable_file_kind : (** [testable_file_kind] is like {!val:file_kind}, but only generates file kinds that the current program can create. *) -val testable_file_kinds : Unix.file_kind list QCheck2.Gen.t -(** [testable_file_kinds] generates multiple file kinds, suitable for [select/poll/epoll]. *) +val select_input : + Observations.select_input QCheck2.Gen.t + * Observations.select_input QCheck2.Print.t +(** [select_input] generates input for [select/(e)poll]. + See {!val:Observations.with_select_input} on how to use it to get actual file descriptors. + *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml index 3e729551c99..57ae4e72496 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml @@ -7,6 +7,8 @@ let open_ro name = openfile_ro `reg name [] let open_wo name = openfile_wo `reg name [] +let open_rw name = openfile_rw `reg name [] + let with_kind_ro kind f = let with2 t = let@ fd1, fd2 = with_fd2 t in @@ -72,9 +74,13 @@ let with_kind_rw kind f = | Unix.S_SOCK -> let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in f fd1 fd2 - | Unix.S_FIFO | Unix.S_DIR | Unix.S_LNK | Unix.S_BLK | Unix.S_REG | Unix.S_CHR - -> - invalid_arg "not a socket" + | Unix.S_REG -> + let@ name, _out = with_tempfile () in + let@ fd = with_fd @@ open_rw name in + let@ fd' = with_fd @@ open_rw name in + f fd fd' + | Unix.S_FIFO | Unix.S_DIR | Unix.S_LNK | Unix.S_BLK | Unix.S_CHR -> + invalid_arg "with_kind_rw: not a socket or reg" let observe_read observed op t dest off len = let amount = op t dest off len in @@ -321,4 +327,133 @@ let with_kinds_ro lst = with_kind_list with_kind_ro lst let with_kinds_wo lst = with_kind_list with_kind_wo lst -let with_kinds_rw lst = with_kind_list with_kind_rw lst +(* compatible with [with_kind_ro] and [with_kind_wo] *) +let with_kind_rw' kind f = with_kind_rw kind @@ fun fd1 fd2 -> f fd1 (Some fd2) + +let with_kinds_rw lst = with_kind_list with_kind_rw' lst + +type fd_set = Unix.file_descr list + +type select_fd_spec = {kind: Unix.file_kind; wait: float} + +type select_input = { + ro: select_fd_spec list + ; wo: select_fd_spec list + ; rw: select_fd_spec list + ; re: select_fd_spec list + ; we: select_fd_spec list + ; errors: select_fd_spec list + ; timeout: float +} + +let split_combine gen lst f = + let fds, waits = + lst |> List.map (fun {kind; wait} -> (kind, wait)) |> List.split + in + gen fds @@ fun fds -> + let fds1, fds2 = List.split fds in + f (fds1, List.combine fds2 waits) + +let ( let@ ) f x = f x + +type 'a fd_safe_set = ('a, kind) make list + +let with_fd_inputs f (ro : rdonly fd_safe_set) (wo : wronly fd_safe_set) + (rw : rdwr fd_safe_set) (re : rdonly fd_safe_set) (we : wronly fd_safe_set) + (errs : rdwr fd_safe_set) timeout = + let ro = List.map For_test.unsafe_fd_exn ro + and wo = List.map For_test.unsafe_fd_exn wo + and re = List.map For_test.unsafe_fd_exn re + and we = List.map For_test.unsafe_fd_exn we + and rw = List.map For_test.unsafe_fd_exn rw + and errs = List.map For_test.unsafe_fd_exn errs in + let call timeout = f (ro @ rw @ re) (wo @ rw @ we) (errs @ re @ we) timeout in + let r1 = call timeout in + let r2 = call 0. in + (r1, r2) + +let simulate f lst lst' = + List.combine lst lst' + |> List.map @@ fun (wrapped, (wrapped', wait)) -> + (wait, For_test.unsafe_fd_exn wrapped, f wrapped wrapped') + +let large = String.make 1_000_000 'x' + +let buf = Bytes.make (String.length large) 'x' + +let simulate_ro _ro ro' () = + ro' + |> Option.iter @@ fun ro' -> + as_spipe_opt ro' |> Option.iter set_nonblock ; + let (_ : int) = Operations.single_write_substring ro' "." 0 1 in + () + +let simulate_wo wo wo' = + let handle_pipe fd = + set_nonblock fd ; + (* fill buffers, to make write unavailable initially, but not on regular files/block devices, + to avoid ENOSPC errors + *) + let (_ : int) = + Operations.repeat_write Operations.single_write_substring fd large 0 + (String.length large) + in + () + in + as_spipe_opt wo |> Option.iter handle_pipe ; + fun () -> + wo' + |> Option.iter @@ fun wo' -> + as_spipe_opt wo' |> Option.iter set_nonblock ; + let (_ : int) = Operations.read wo' buf 0 (Bytes.length buf) in + () + +let simulate_rw rw rw' = + let f = simulate_ro rw rw' and g = simulate_wo rw rw' in + fun () -> f () ; g () + +let compare_wait (t1, _, _) (t2, _, _) = Float.compare t1 t2 + +let run_simulation (stop, actions) = + (* TODO: measure when we actually sent, also have an atomic to when to stop exactly *) + List.fold_left + (fun (prev, fds) (curr, fd, action) -> + let delta = curr -. prev in + assert (delta >= 0.) ; + if not (Atomic.get stop) then + if delta > 0. then + Unix.sleepf delta ; + (* check again, might've been set meanwhile *) + ( curr + , if (not (Atomic.get stop)) || curr < Float.epsilon then ( + action () ; fd :: fds + ) else + fds + ) + ) + (0., []) actions + |> snd + +let with_select_input t f = + let@ re, re' = split_combine with_kinds_ro t.re in + let@ we, we' = split_combine with_kinds_wo t.we in + let@ rw, rw' = split_combine with_kinds_rw t.rw in + let@ ro, ro' = split_combine with_kinds_ro t.ro in + let@ wo, wo' = split_combine with_kinds_wo t.wo in + let@ errs, errs' = split_combine with_kinds_rw t.errors in + let actions = + List.concat + [ + simulate simulate_ro (ro @ re) (ro' @ re') + ; simulate simulate_wo (wo @ we) (wo' @ we') + ; simulate simulate_rw rw rw' (* TODO: how to simulate errors *) + ; simulate simulate_rw errs errs' + ] + |> List.fast_sort compare_wait + in + let stop = Atomic.make false in + let finally () = Atomic.set stop true in + let run () = with_fd_inputs f ro wo rw re we errs t.timeout in + let run () = Fun.protect ~finally run in + let r1, r2 = concurrently (run, run_simulation) ((), (stop, actions)) in + (unwrap_exn r1, unwrap_exn r2) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli index 412e8fd8c07..5ba8a720251 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli @@ -54,7 +54,7 @@ val with_kind_rw : val with_kinds_rw : Unix.file_kind list - -> ((([> rdwr], kind) make * ([> rdwr], kind) make) list -> 'a) + -> ((([> rdwr], kind) make * ([> rdwr], kind) make option) list -> 'a) -> 'a (** [with_kinds_rw kind f] is like {!val:with_kind_rw} but for a list of file kinds. *) @@ -222,3 +222,30 @@ val observe_rw : @param expected the string to write to the file descriptor @returns an observation of [f]'s actions on the file descriptor and [f]'s result *) + +type fd_set = Unix.file_descr list + +(** [select_fd_spec] defines a behaviour for a select input: a file descriptor kind and how long before any event happens on it *) +type select_fd_spec = {kind: Unix.file_kind; wait: float} + +type select_input = { + ro: select_fd_spec list + ; wo: select_fd_spec list + ; rw: select_fd_spec list + ; re: select_fd_spec list + ; we: select_fd_spec list + ; errors: select_fd_spec list + ; timeout: float +} + +val with_select_input : + select_input + -> (fd_set -> fd_set -> fd_set -> float -> 'a) + -> ('a * 'a) * fd_set +(** [with_select_input behaviour f] creates file descriptors according to [behaviour] and calls [f] twice with it, + the 2nd time with a 0 timeout. + By the 2nd time it is called all the file descriptors from the available set should've been detected, + the 1st time you might run into a race condition where we've just sent the byte on the other end at the same time as the timeout. + + @returns the return value of [f], and a list of available file descriptors. + *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml index 5e5ec0572dc..f0f6e709e5e 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml @@ -58,6 +58,10 @@ let close t = Safefd.idempotent_close_exn t.fd let fsync t = Unix.fsync (Safefd.unsafe_to_file_descr_exn t.fd) +let as_readable t = {t with props= as_readable t.props} + +let as_writable t = {t with props= as_writable t.props} + let as_readable_opt t = match as_readable_opt t.props with | None -> diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli index cf65b2aab68..286e545321f 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli @@ -45,6 +45,14 @@ val setup : unit -> unit By default a SIGPIPE would kill the program, this makes it return [EPIPE] instead. *) +(** {1 Static property tests} *) + +val as_readable : (([< readable] as 'a), 'b) make -> ([> readable], 'b) make +(** [as_readable_opt t] returns [Some t] when [t] is readable, and [None] otherwise. *) + +val as_writable : ([< writable], 'b) make -> ([> writable], 'b) make +(** [as_writable_opt t] returns [Some t] when [t] is readable, and [None] otherwise. *) + (** {1 Runtime property tests} *) val as_readable_opt : From a5ce54d00934125d3bbfbc3be4d07d785de88bd4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 5 Aug 2024 09:49:54 +0100 Subject: [PATCH 121/157] unixext_test: add test for select MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Test Unix.select. This can be easily switched to test Unixext.select based on epoll. We disable the 'open 1024' fds on startup because we are testing regular select here. Signed-off-by: Edwin Török --- .../lib/xapi-stdext-unix/test/dune | 2 +- .../lib/xapi-stdext-unix/test/unixext_test.ml | 94 +++++++++++++++++-- 2 files changed, 89 insertions(+), 7 deletions(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune index 0eb42f9d114..3b116a07983 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune @@ -1,7 +1,7 @@ (library (name unixext_test) (modules unixext_test) - (libraries xapi_stdext_unix qcheck-core mtime.clock.os fmt xapi_fd_test mtime threads.posix rresult) + (libraries clock xapi_stdext_unix qcheck-core mtime.clock.os fmt xapi_fd_test mtime threads.posix rresult) ) (test diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml index 95d00f421d8..b3cd441c2ef 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml @@ -72,7 +72,6 @@ let test_time_limited_write = ) ; buf in - (*Printf.eprintf "testing write: %s\n%!" (print (behaviour, timeout)) ;*) let observations, result = Generate.run_wo behaviour ~f:test in let () = let open Observations in @@ -117,7 +116,6 @@ let test_time_limited_read = let gen = Gen.tup2 Generate.t Generate.timeouts and print = Print.tup2 Generate.print Print.float in Test.make ~name:__FUNCTION__ ~print gen @@ fun (behaviour, timeout) -> - (* Format.eprintf "Testing %s@." (print (behaviour, timeout)); *) skip_blk behaviour.kind ; skip_dirlnk behaviour.kind ; skip_blk_timed behaviour ; @@ -132,7 +130,6 @@ let test_time_limited_read = Unixext.time_limited_read fd behaviour.size deadline ) in - (*Printf.eprintf "testing: %s\n%!" (print (behaviour, timeout)) ;*) let observations, result = let buf = String.init behaviour.size (fun i -> Char.chr (i mod 255)) in Generate.run_ro behaviour buf ~f:test @@ -145,7 +142,6 @@ let test_time_limited_read = "Function duration significantly exceeds timeout: %f > %f; %s" elapsed_s timeout (Fmt.to_to_string Fmt.(option pp) observations.Observations.write) ; - (* Format.eprintf "Result: %a@." (Fmt.option Observations.pp) observations.write;*) match (observations, result) with | {write= Some write; _}, Ok actual -> expect_amount ~expected:(String.length actual) write ; @@ -200,9 +196,95 @@ let test_proxy = expect_string ~expected:write.data ~actual:read.data ; true -let tests = [test_proxy; test_time_limited_write; test_time_limited_read] +let run_select ro wo errs timeout = + let dt = Mtime_clock.counter () in + let r = Unix.select ro wo errs timeout in + (Mtime_clock.count dt, timeout, r) + +(* delays as long as 28.4ms were observed with epoll + (on an otherwise idle system with a single thread, and no Xen domains) + Be very conservative here and allow for a large difference +*) +let extra_timeout = Mtime.Span.(250 * ms) + +let check_timeout elapsed timeout = + let timeout_span = Clock.Timer.s_to_span timeout |> Option.get in + if + Clock.Timer.span_is_longer elapsed + ~than:(Mtime.Span.add Mtime.Span.(2 * timeout_span) extra_timeout) + then + Test.fail_reportf "Timed out too late: %a > %f" Mtime.Span.pp elapsed + timeout ; + timeout_span + +module FDSet = Set.Make (struct + type t = Unix.file_descr + + let compare = Stdlib.compare +end) + +let check_set lst = + let set = FDSet.of_list lst in + let n = List.length lst and n' = FDSet.cardinal set in + if n <> n' then + Test.fail_reportf + "File descriptor set contains duplicate elements: %d <> %d" n n' ; + set + +let check_sets (s1, s2, s3) = (check_set s1, check_set s2, check_set s3) + +let pp_fd = Fmt.using Unixext.int_of_file_descr Fmt.int + +let pp_fdset = Fmt.(using FDSet.to_seq @@ Dump.seq pp_fd) + +let check_subset msg msg' s1 s1' (r, w, e) (r', w', e') = + if not (FDSet.subset s1 s1') then + Test.fail_reportf + "%s %s: (%d and %d elements): %a and %a. output: %a,%a,%a; available: \ + %a,%a,%a" + msg msg' (FDSet.cardinal s1) (FDSet.cardinal s1') pp_fdset s1 pp_fdset s1' + pp_fdset r pp_fdset w pp_fdset e pp_fdset r' pp_fdset w' pp_fdset e' + +let check_subsets msg ((s1, s2, s3) as all) ((s1', s2', s3') as all') = + check_subset msg "read" s1 s1' all all' ; + check_subset msg "write" s2 s2' all all' ; + check_subset msg "error" s3 s3' all all' + +let test_select = + let gen, print = Generate.select_input in + Test.make ~long_factor:10 ~name:__FUNCTION__ ~print gen @@ fun t -> + (* epoll raised EEXIST, but none of the actual callers in XAPI need this, + so skip + *) + QCheck2.assume (t.rw = [] && t.re = [] && t.we = []) ; + let ((elapsed, timeout, ready), (elapsed', timeout', ready')), available = + Observations.with_select_input t run_select + in + let timeout_span = check_timeout elapsed timeout in + let (_ : Mtime.Span.t) = check_timeout elapsed' timeout' in + let () = + match ready with + | [], [], [] -> + if Clock.Timer.span_is_shorter elapsed ~than:timeout_span then + Test.fail_reportf "Timed out too early: %a < %f" Mtime.Span.pp elapsed + timeout + | _ -> + let ready = check_sets ready in + let ready' = check_sets ready' in + let available = check_set available in + let available = (available, available, available) in + check_subsets "1st call subset of 2nd" ready ready' ; + check_subsets "ready subset of available" ready available ; + check_subsets "ready' subset of available" ready' available ; + () + in + true + +let tests = + [test_select; test_proxy; test_time_limited_write; test_time_limited_read] let () = (* avoid SIGPIPE *) let (_ : Sys.signal_behavior) = Sys.signal Sys.sigpipe Sys.Signal_ignore in - Xapi_stdext_unix.Unixext.test_open 1024 + (* Reenable this on the epoll branch: Xapi_stdext_unix.Unixext.test_open 1024 *) + () From d9d30014e3d63813257cafe6ae972ebec1748810 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 18 Jul 2024 18:35:39 +0100 Subject: [PATCH 122/157] CP-32622: introduce select-as-epoll in Unixext MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A drop-in replacement for select that doesn't fail when a file descriptor number is >1024. This is bad for performance (it makes a lot more syscalls than select), and performance sensitive callers should instead use `SO_RCVTIMEO/SO_SNDTIMEO` on sockets, or move the polly instance creation out of loops. This will also use one additional file descriptor compared to 'select', so it will reach EMFILE sooner. When replacing `Unix.select` with `Unixext.select` you must also increase resource limits! Signed-off-by: Edwin Török --- .../lib/xapi-stdext-unix/unixext.ml | 71 +++++++++++++++++++ .../lib/xapi-stdext-unix/unixext.mli | 7 ++ 2 files changed, 78 insertions(+) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml index 5141e888fe8..7fee8112b4e 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -672,6 +672,77 @@ let time_limited_single_read filedesc length ~max_wait = in Bytes.sub_string buf 0 bytes +(** see [select(2)] "Correspondence between select() and poll() notifications". + Note that HUP and ERR are ignored in events and returned only in revents. + For simplicity we use the same event mask from the manual in both cases + *) +let pollin_set = Polly.Events.(rdnorm lor rdband lor inp lor hup lor err) + +let pollout_set = Polly.Events.(wrband lor wrnorm lor out lor err) + +let pollerr_set = Polly.Events.pri + +let to_milliseconds ms = ms *. 1e3 |> ceil |> int_of_float + +(* we could change lists to proper Sets once the Unix.select to Unixext.select conversion is done *) + +let readable fd (rd, wr, ex) = (fd :: rd, wr, ex) + +let writable fd (rd, wr, ex) = (rd, fd :: wr, ex) + +let error fd (rd, wr, ex) = (rd, wr, fd :: ex) + +let check_events fd mask event action state = + if Polly.Events.test mask event then + action fd state + else + state + +let no_events = ([], [], []) + +let fold_events _ fd event state = + state + |> check_events fd pollin_set event readable + |> check_events fd pollout_set event writable + |> check_events fd pollerr_set event error + +let polly_fold_add polly events action immediate fd = + try Polly.add polly fd events ; immediate + with Unix.Unix_error (Unix.EPERM, _, _) -> + (* matches the behaviour of select: file descriptors that cannot be watched + are returned as ready immediately *) + action fd immediate + +let polly_fold polly events fds action immediate = + List.fold_left (polly_fold_add polly events action) immediate fds + +let select ins outs errs timeout = + (* -1.0 is a special value used in forkexecd *) + if timeout < 0. && timeout <> -1.0 then + invalid_arg (Printf.sprintf "negative timeout would hang: %g" timeout) ; + match (ins, outs, errs) with + | [], [], [] -> + Unix.sleepf timeout ; no_events + | _ -> ( + with_polly @@ fun polly -> + (* file descriptors that cannot be watched by epoll *) + let immediate = + no_events + |> polly_fold polly pollin_set ins readable + |> polly_fold polly pollout_set outs writable + |> polly_fold polly pollerr_set errs error + in + match immediate with + | [], [], [] -> + Polly.wait_fold polly 1024 (to_milliseconds timeout) no_events + fold_events + | _ -> + (* we have some fds that are immediately available, but still poll the others + for any events that are available immediately + *) + Polly.wait_fold polly 1024 0 immediate fold_events + ) + (* --------------------------------------------------------------------------------------- *) (* Read a given number of bytes of data from the fd, or stop at EOF, whichever comes first. *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli index 176adc94cf8..0d3bc48abc9 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli @@ -156,6 +156,13 @@ val time_limited_read : Unix.file_descr -> int -> float -> string val time_limited_single_read : Unix.file_descr -> int -> max_wait:float -> string +val select : + Unix.file_descr list + -> Unix.file_descr list + -> Unix.file_descr list + -> float + -> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list + val read_data_in_string_chunks : (string -> int -> unit) -> ?block_size:int From 5b756b252f3c50414f3e76ac03864b89e78548a9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 5 Aug 2024 09:56:06 +0100 Subject: [PATCH 123/157] xapi-fd-test: switch to testing Unixext.select MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- .../xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml index b3cd441c2ef..83bc7f00bd2 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml @@ -198,7 +198,7 @@ let test_proxy = let run_select ro wo errs timeout = let dt = Mtime_clock.counter () in - let r = Unix.select ro wo errs timeout in + let r = Unixext.select ro wo errs timeout in (Mtime_clock.count dt, timeout, r) (* delays as long as 28.4ms were observed with epoll @@ -286,5 +286,4 @@ let tests = let () = (* avoid SIGPIPE *) let (_ : Sys.signal_behavior) = Sys.signal Sys.sigpipe Sys.Signal_ignore in - (* Reenable this on the epoll branch: Xapi_stdext_unix.Unixext.test_open 1024 *) - () + Xapi_stdext_unix.Unixext.test_open 1024 From 9208739bcc40db3ad9d8b6e6032d36393a59ad1d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Jul 2024 13:14:46 +0100 Subject: [PATCH 124/157] CP-32622: Thread.wait_timed_read/wait_timed_write MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- .../lib/xapi-stdext-threads/threadext.ml | 20 +++++++++++++++++++ .../lib/xapi-stdext-threads/threadext.mli | 4 ++++ 2 files changed, 24 insertions(+) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml index b255239dd4d..1ca5e916ef4 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml @@ -111,3 +111,23 @@ module Delay = struct (* If the wait hasn't happened yet then store up the signal *) ) end + +let wait_timed_read fd timeout = + match Xapi_stdext_unix.Unixext.select [fd] [] [] timeout with + | [], _, _ -> + false + | [fd'], _, _ -> + assert (fd' = fd) ; + true + | _ -> + assert false + +let wait_timed_write fd timeout = + match Xapi_stdext_unix.Unixext.select [] [fd] [] timeout with + | _, [], _ -> + false + | _, [fd'], _ -> + assert (fd' = fd) ; + true + | _ -> + assert false diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.mli index 8349ab71366..057aedfa700 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.mli @@ -33,3 +33,7 @@ module Delay : sig val signal : t -> unit (** Sends a signal to a waiting thread. See 'wait' *) end + +val wait_timed_read : Unix.file_descr -> float -> bool + +val wait_timed_write : Unix.file_descr -> float -> bool From 0fbc9d55e33e1930df937f2693f97d4daae8702e Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Fri, 9 Aug 2024 16:44:52 +0100 Subject: [PATCH 125/157] CP-51042: Raise error in sr-scan when SR.stat finds an unhealthy SR Previously sr-scan first performs an SR.ls followed by an SR.stat, which will fail when the SR is not healthy. Now that we included more health messages in SR.stat, we can give perform SR.stat first and fail the operation if SR.stat gives unhealthy state, and tell the user about the unhealthy state. Signed-off-by: Vincent Liu --- ocaml/xapi-idl/storage/storage_interface.ml | 1 + ocaml/xapi/xapi_sr.ml | 47 ++++++++++++--------- 2 files changed, 28 insertions(+), 20 deletions(-) diff --git a/ocaml/xapi-idl/storage/storage_interface.ml b/ocaml/xapi-idl/storage/storage_interface.ml index 698997ac0cd..e66be1c18a7 100644 --- a/ocaml/xapi-idl/storage/storage_interface.ml +++ b/ocaml/xapi-idl/storage/storage_interface.ml @@ -361,6 +361,7 @@ module Errors = struct | Content_ids_do_not_match of (string * string) | Missing_configuration_parameter of string | Internal_error of string + | Sr_unhealthy of sr_health | Unknown_error [@@default Unknown_error] [@@deriving rpcty] end diff --git a/ocaml/xapi/xapi_sr.ml b/ocaml/xapi/xapi_sr.ml index 7b5186d5195..1645088deaf 100644 --- a/ocaml/xapi/xapi_sr.ml +++ b/ocaml/xapi/xapi_sr.ml @@ -787,30 +787,37 @@ let scan ~__context ~sr = SRScanThrottle.execute (fun () -> transform_storage_exn (fun () -> let sr_uuid = Db.SR.get_uuid ~__context ~self:sr in - let vs = - C.SR.scan (Ref.string_of task) - (Storage_interface.Sr.of_string sr_uuid) - in - let db_vdis = - Db.VDI.get_records_where ~__context - ~expr:(Eq (Field "SR", Literal sr')) - in - update_vdis ~__context ~sr db_vdis vs ; + let sr_info = C.SR.stat (Ref.string_of task) (Storage_interface.Sr.of_string sr_uuid) in - let virtual_allocation = - List.fold_left Int64.add 0L - (List.map (fun v -> v.Storage_interface.virtual_size) vs) - in - Db.SR.set_virtual_allocation ~__context ~self:sr - ~value:virtual_allocation ; - Db.SR.set_physical_size ~__context ~self:sr ~value:sr_info.total_space ; - Db.SR.set_physical_utilisation ~__context ~self:sr - ~value:(Int64.sub sr_info.total_space sr_info.free_space) ; - Db.SR.remove_from_other_config ~__context ~self:sr ~key:"dirty" ; - Db.SR.set_clustered ~__context ~self:sr ~value:sr_info.clustered + match sr_info with + | {health; _} when health <> Healthy -> + raise Storage_interface.(Storage_error (Sr_unhealthy health)) + | _ -> + let vs = + C.SR.scan (Ref.string_of task) + (Storage_interface.Sr.of_string sr_uuid) + in + let db_vdis = + Db.VDI.get_records_where ~__context + ~expr:(Eq (Field "SR", Literal sr')) + in + update_vdis ~__context ~sr db_vdis vs ; + let virtual_allocation = + List.fold_left + (fun acc v -> Int64.add v.Storage_interface.virtual_size acc) + 0L vs + in + Db.SR.set_virtual_allocation ~__context ~self:sr + ~value:virtual_allocation ; + Db.SR.set_physical_size ~__context ~self:sr + ~value:sr_info.total_space ; + Db.SR.set_physical_utilisation ~__context ~self:sr + ~value:(Int64.sub sr_info.total_space sr_info.free_space) ; + Db.SR.remove_from_other_config ~__context ~self:sr ~key:"dirty" ; + Db.SR.set_clustered ~__context ~self:sr ~value:sr_info.clustered ) ) From d8ff15b3d42986424bacae041d1bee052d754efc Mon Sep 17 00:00:00 2001 From: Bengang Yuan Date: Mon, 19 Aug 2024 12:16:53 +0100 Subject: [PATCH 126/157] CP-49217: Refine test_tar_ext and add copyright 1. Refine test_tar_ext for integer format and add some comments to describe the relationship of the 'max_size_limit' between UT and 'gen_tar_ext_test_file.sh'. 2. Add copyright in 'gen_tar_ext_test_file.sh'. Signed-off-by: Bengang Yuan --- ocaml/tests/test_data/gen_tar_ext_test_file.sh | 12 ++++++++++++ ocaml/tests/test_tar_ext.ml | 12 ++++++++---- 2 files changed, 20 insertions(+), 4 deletions(-) diff --git a/ocaml/tests/test_data/gen_tar_ext_test_file.sh b/ocaml/tests/test_data/gen_tar_ext_test_file.sh index 673013a5c31..39c0deaba2a 100755 --- a/ocaml/tests/test_data/gen_tar_ext_test_file.sh +++ b/ocaml/tests/test_data/gen_tar_ext_test_file.sh @@ -1,4 +1,16 @@ #!/bin/bash +# +# Copyright (c) Cloud Software Group, Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU Lesser General Public License as published +# by the Free Software Foundation; version 2.1 only. with the special +# exception on linking described in file LICENSE. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Lesser General Public License for more details. test_file_dir=$1 mkdir -p "${test_file_dir}" diff --git a/ocaml/tests/test_tar_ext.ml b/ocaml/tests/test_tar_ext.ml index 49cb0edb63f..cb16410126c 100644 --- a/ocaml/tests/test_tar_ext.ml +++ b/ocaml/tests/test_tar_ext.ml @@ -20,7 +20,11 @@ let ( // ) = Filename.concat let gen_test_file_script = "test_data" // "gen_tar_ext_test_file.sh" -let max_size_limit = 2000000L +(* The test file generating script 'gen_tar_ext_test_file.sh' will create a tar + file 'test_tar_ext_unpacked_exceeds_max_size.tar' of 3MB. Setting + 'max_size_limit' to 2MB will trigger the error 'Unpacked_exceeds_max_size_limit'. +*) +let max_size_limit = 2 * 1024 * 1024 |> Int64.of_int let create_temp_dir () = let mktemp = Cmd.v "mktemp" in @@ -74,7 +78,7 @@ let test_cases = ; { description= "Test unpacked exceeds max size limit" ; test_file= "test_tar_ext_unpacked_exceeds_max_size.tar" - ; expected= Error (Unpacked_exceeds_max_size_limit 2000000L) + ; expected= Error (Unpacked_exceeds_max_size_limit max_size_limit) } ; { description= "Test unpacked file size mismatch" @@ -84,8 +88,8 @@ let test_cases = (File_size_mismatch { path= unpack_dir // "file1" - ; expected_size= 1048576L - ; actual_size= 99488L + ; expected_size= 1_048_576L + ; actual_size= 99_488L } ) } From 9dab8fa4412f1302c38ef36cecb9a65e91f3c449 Mon Sep 17 00:00:00 2001 From: Danilo Del Busso Date: Wed, 21 Aug 2024 09:10:56 +0100 Subject: [PATCH 127/157] Add temporary exception for deprecation of `xmlStringDecodeEntities` Signed-off-by: Danilo Del Busso --- ocaml/sdk-gen/c/autogen/src/xen_common.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ocaml/sdk-gen/c/autogen/src/xen_common.c b/ocaml/sdk-gen/c/autogen/src/xen_common.c index 9178d3fd43f..43b039db6f3 100644 --- a/ocaml/sdk-gen/c/autogen/src/xen_common.c +++ b/ocaml/sdk-gen/c/autogen/src/xen_common.c @@ -1706,7 +1706,10 @@ get_val_as_string(const struct abstract_type *type, void *value) { xmlChar *encoded_value = *(xmlChar **)value; xmlParserCtxtPtr ctxt = xmlCreateDocParserCtxt(encoded_value); + #pragma GCC diagnostic push + #pragma GCC diagnostic ignored "-Wdeprecated-declarations" char *res = (char*)xmlStringDecodeEntities(ctxt, encoded_value, 1, 0, 0, 0); + #pragma GCC diagnostic pop xmlFreeParserCtxt(ctxt); return res; } From f91e90de81b23ee8fe9511168c36960ac4a0279b Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 21 Aug 2024 13:06:35 +0100 Subject: [PATCH 128/157] new-docs: Toggle hidden documentation only on header clicks Allows to copy the documentation, since clicking on the function details no longer hides the
Signed-off-by: Andrii Sultanov --- doc/layouts/xenapi/class.html | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/doc/layouts/xenapi/class.html b/doc/layouts/xenapi/class.html index e9e3c6cbe8b..2c8f67f4c79 100644 --- a/doc/layouts/xenapi/class.html +++ b/doc/layouts/xenapi/class.html @@ -66,8 +66,8 @@

-
{{ $x.name }}
+
+
{{ $x.name }}