From 172392f2369fc01e442abb05fb7d542e7c89f7a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 1 Jun 2022 18:39:16 +0100 Subject: [PATCH 01/65] xe-xentrace: fix binary location MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It is in /usr/sbin not /usr/bin Signed-off-by: Edwin Török --- scripts/xe-xentrace | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/xe-xentrace b/scripts/xe-xentrace index 5fe06888f88..a16e81da3fc 100755 --- a/scripts/xe-xentrace +++ b/scripts/xe-xentrace @@ -118,7 +118,7 @@ fi echo "done" echo "Xentrace: starting" -/usr/bin/xentrace -D -e all -r 1 ${mnt}/trace -T ${TIME} +/usr/sbin/xentrace -D -e all -r 1 ${mnt}/trace -T ${TIME} echo "Xentrace: compressing" bzip2 -9 ${mnt}/trace From d324e6ca73749aa86f965a718d0fa5fca52db0a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 1 Jun 2022 19:01:21 +0100 Subject: [PATCH 02/65] scripts/xentrace: detect host CPU spikes and dump xentrace MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Run xentrace in continuous tracing mode to a circular buffer (of fixed size). When a CPU spike is detected xentrace is sent a SIGTERM with `killall` to get it to dump the xentrace buffer to disk. The trace is compressed and another xentrace started. This repeats until we run out of the space on the VDI set up for tracing. CPU spikes are detected by using `rrd2csv` and watching the host `cpu_avg` which should be the average of the CPU usage of all the host's pCPUs. New flags: * -c to enable circular tracing mode (default is a -T time one-off trace) * -p e.g. -p 98 the detection point for CPU spike * -r repeat count - how many high cpu usage measurements in a row before triggerring the xentrace dump * -M to set the size of the circular buffer in MiB (default: 400MiB) There is also a (hardcoded for now) sleep 60 between the traces just so we don't continuously measure a very long spike. To stop circular tracing mode you have to Ctrl-C on the running xe-xentrace (e.g. under `screen`), or `killall xe-xentrace` (but this seems to prevent automatic cleanup) Signed-off-by: Edwin Török --- scripts/xe-xentrace | 75 +++++++++++++++++++++++++++++++++++++++------ 1 file changed, 65 insertions(+), 10 deletions(-) diff --git a/scripts/xe-xentrace b/scripts/xe-xentrace index a16e81da3fc..c8ff4f8ccdd 100755 --- a/scripts/xe-xentrace +++ b/scripts/xe-xentrace @@ -10,10 +10,14 @@ # The VDI has the other_config:xentrace flag set to 1, so these can be # identified later on as xentrace records. # The VDI contains a ext3 fs (no partition table) and single file "trace.bz2" - +set -euo pipefail TIME=5 SIZE_GB=1 -while getopts "ht:s:" opt ; do +CIRCULAR=0 +MEMORY_MB=400 # 400 MiB +DUMP_ON_CPUAVG= + +while getopts "hct:s:M:p:r:" opt ; do case $opt in h) echo "Usage: $0 [-t time (sec)] [-s size (GB)]" @@ -23,12 +27,28 @@ while getopts "ht:s:" opt ; do ;; s) SIZE_GB=$OPTARG ;; + + c) CIRCULAR=1 + ;; + + M) MEMORY_MB=$OPTARG + ;; + + p) CIRCULAR=1 + DUMP_ON_CPUAVG=$OPTARG + REPEAT=6 + ;; + + r) REPEAT=$OPTARG + ;; + *) echo "Invalid option"; exit 1 ;; esac done SIZE=$((${SIZE_GB} * 1024 * 1024 * 1024)) +MEMORY=$((${MEMORY_MB} * 1024 * 1024)) if [ ! -e @INVENTORY@ ]; then echo Must run on a Citrix Hypervisor host. @@ -62,6 +82,8 @@ ${XE} vdi-param-set uuid=${vdi_uuid} other-config:xentrace=1 mnt= function cleanup { + killall xentrace + if [ ! -z "${vdi_uuid}" ]; then ${XE} vdi-destroy uuid=${vdi_uuid} fi @@ -116,15 +138,48 @@ if [ $? -ne 0 ]; then fi echo "done" +echo "Trace recording to VDI: ${vdi_uuid}" +trap cleanup EXIT + +if [ -n "${DUMP_ON_CPUAVG}" ]; then + echo "Xentrace: will dump when host cpu usage >= ${DUMP_ON_CPUAVG}" + echo "Xentrace: will dump when triggered for ${REPEAT}*5s intervals in a row" + (rrd2csv "AVERAGE:host:${INSTALLATION_UUID}:cpu_avg" \ + | (TRIGGER=0 + read IGNORE + while IFS=, read -r time value; do + if (( $(echo "${value} > ${DUMP_ON_CPUAVG}/100" | bc -l) )); then + TRIGGER=$((${TRIGGER} + 1)) + else + TRIGGER=0 + fi + if [ "${TRIGGER}" -gt "${REPEAT}" ]; then + TRIGGER=0 + echo "Killing xentrace to dump trace" + killall xentrace || true + echo "Waiting for 1m" + sleep 60 + fi + done))& +fi -echo "Xentrace: starting" -/usr/sbin/xentrace -D -e all -r 1 ${mnt}/trace -T ${TIME} +while : ; do + echo "Xentrace: starting" + TRACE="${mnt}/trace.$(date +%s)" + if [ "${CIRCULAR}" = 1 ]; then + echo "Xentrace: in circular mode, waiting for 'killall xentrace'" + /usr/sbin/xentrace -D -e all -r 1 "${TRACE}" -M "${MEMORY}" + else + /usr/sbin/xentrace -D -e all -r 1 "${TRACE}" -T ${TIME} + fi -echo "Xentrace: compressing" -bzip2 -9 ${mnt}/trace + # do not destroy the VDI anymore, we've got useful data on it + vdi_uuid="" -echo "Xentrace: done" -echo "Trace recorded to VDI: ${vdi_uuid}" + echo "Xentrace: compressing ${TRACE}" + bzip2 -9 "${TRACE}" + + [ "${CIRCULAR}" = 1 ] || break +done -vdi_uuid="" -cleanup +echo "Xentrace: done" From bfe78bdf03ef508bc3f56428dcb252793bd700df Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 7 Feb 2024 15:15:44 +0000 Subject: [PATCH 03/65] CA_388624: fix(C SDK): fix build failure with recent GCC MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The C SDK build was failing with a recent GCC on Fedora39 like this: ``` src/xen_common.c: In function ‘xen_session_logout’: src/xen_common.c:298:5: error: ‘xen_call_’ accessing 16 bytes in a region of size 0 [-Werror=stringop-overflow=] 298 | xen_call_(session, "session.logout", params, 0, NULL, NULL); | ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ``` Use `NULL` instead of a VLA of size 0. Signed-off-by: Edwin Török --- ocaml/sdk-gen/c/autogen/src/xen_common.c | 21 ++++----------------- ocaml/sdk-gen/c/gen_c_binding.ml | 4 +++- 2 files changed, 7 insertions(+), 18 deletions(-) diff --git a/ocaml/sdk-gen/c/autogen/src/xen_common.c b/ocaml/sdk-gen/c/autogen/src/xen_common.c index 9081f9bd725..9178d3fd43f 100644 --- a/ocaml/sdk-gen/c/autogen/src/xen_common.c +++ b/ocaml/sdk-gen/c/autogen/src/xen_common.c @@ -292,10 +292,7 @@ set_api_version(xen_session *session) void xen_session_logout(xen_session *session) { - abstract_value params[] = - { - }; - xen_call_(session, "session.logout", params, 0, NULL, NULL); + xen_call_(session, "session.logout", NULL, 0, NULL, NULL); if (session->error_description != NULL) { @@ -314,10 +311,7 @@ xen_session_logout(xen_session *session) void xen_session_local_logout(xen_session *session) { - abstract_value params[] = - { - }; - xen_call_(session, "session.local_logout", params, 0, NULL, NULL); + xen_call_(session, "session.local_logout", NULL, 0, NULL, NULL); if (session->error_description != NULL) { @@ -336,14 +330,11 @@ xen_session_local_logout(xen_session *session) bool xen_session_get_all_subject_identifiers(xen_session *session, struct xen_string_set **result) { - abstract_value params[] = - { - }; abstract_type result_type = abstract_type_string_set; *result = NULL; - xen_call_(session, "session.get_all_subject_identifiers", params, 0, &result_type, result); + xen_call_(session, "session.get_all_subject_identifiers", NULL, 0, &result_type, result); return session->ok; } @@ -351,14 +342,10 @@ bool bool xen_session_get_all_subject_identifiers_async(xen_session *session, xen_task *result) { - abstract_value params[] = - { - }; - abstract_type result_type = abstract_type_string; *result = NULL; - xen_call_(session, "Async.session.get_all_subject_identifiers", params, 0, &result_type, result); + xen_call_(session, "Async.session.get_all_subject_identifiers", NULL, 0, &result_type, result); return session->ok; } diff --git a/ocaml/sdk-gen/c/gen_c_binding.ml b/ocaml/sdk-gen/c/gen_c_binding.ml index 0c84af4ac93..fac079fb9b0 100644 --- a/ocaml/sdk-gen/c/gen_c_binding.ml +++ b/ocaml/sdk-gen/c/gen_c_binding.ml @@ -387,7 +387,9 @@ and impl_message needed classname message = sprintf " xen_call_(session, \"%s.%s\", %s, %d, NULL, NULL);\n\ \ return session->ok;\n" - classname message.msg_name param_call param_count + classname message.msg_name + (if param_count = 0 then "NULL" else param_call) + param_count in let messageAsyncImpl = impl_message_async needed classname message in From 000839541a4d1c266aad5222f5c1520ddb28ac2e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 7 Feb 2024 16:28:59 +0000 Subject: [PATCH 04/65] build: add sdk-build-c Makefile rule to test building C SDK locally MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Requires libxml2-devel installed. Signed-off-by: Edwin Török --- Makefile | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/Makefile b/Makefile index 58127ceef2f..0564b3b8da3 100644 --- a/Makefile +++ b/Makefile @@ -112,6 +112,11 @@ sdk: sh ocaml/sdk-gen/windows-line-endings.sh $(XAPISDK)/csharp sh ocaml/sdk-gen/windows-line-endings.sh $(XAPISDK)/powershell +.PHONY: sdk-build-c sdk sdksanity + +sdk-build-c: sdk + cd _build/install/default/xapi/sdk/c && make -j $(JOBS) + # workaround for no .resx generation, just for compilation testing sdksanity: sdk sed -i 's/FriendlyErrorNames.ResourceManager/null/g' ./_build/install/default/xapi/sdk/csharp/src/Failure.cs From ed13f125b81367859410175d49a7b472c16d9424 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 4 Jan 2024 17:47:15 +0000 Subject: [PATCH 05/65] gen_api: generate an all_ for enum types MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This will be useful for testing record_util.ml Signed-off-by: Edwin Török --- ocaml/idl/ocaml_backend/gen_api.ml | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/ocaml/idl/ocaml_backend/gen_api.ml b/ocaml/idl/ocaml_backend/gen_api.ml index 01c49bdbe88..0bceed12255 100644 --- a/ocaml/idl/ocaml_backend/gen_api.ml +++ b/ocaml/idl/ocaml_backend/gen_api.ml @@ -95,6 +95,19 @@ let gen_non_record_type tys = t | ty :: t -> let alias = OU.alias_of_ty ty in + let accu = + match ty with + | DT.Enum (name, cs) -> + sprintf "let all_%s = [%s]" name + (cs + |> List.map fst + |> List.map OU.constructor_of + |> String.concat "; " + ) + :: accu + | _ -> + accu + in if List.mem_assoc alias overrides then aux (sprintf "type %s = %s\n%s\n" alias (OU.ocaml_of_ty ty) From 5bcbd3bdaee4cf06230f9378263691e48ec5ea20 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 11 Jan 2024 10:53:32 +0000 Subject: [PATCH 06/65] fix(Host.set_numa_affinity_policy): be consistent about accepting mixed case MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Other enums here accept mixed case, not just lower case. Fixes: 638f58e64 ("CP-38020: add HOST.set_numa_affinity_policy") Signed-off-by: Edwin Török --- ocaml/xapi-cli-server/record_util.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml index 5332c2aee16..bacf9177698 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -724,7 +724,8 @@ let host_numa_affinity_policy_to_string = function | `default_policy -> "default_policy" -let host_numa_affinity_policy_of_string = function +let host_numa_affinity_policy_of_string a = + match String.lowercase_ascii a with | "any" -> `any | "best_effort" -> From 36dfce68be819dd3c344934730b223eb0f568817 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 16 Feb 2024 11:04:01 +0000 Subject: [PATCH 07/65] test(record_util): make a copy to test for backwards compatibility MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit There are some inconsistencies between enum string values and their declarations, e.g. `balance-slb` (which has special handling in the API generator), or `depth-first` (which does not). We want to automatically generate record_util.ml, but we must ensure backwards compatibility, and the only way to do that is to exhaustively test all the old values in a unit test. This test won't need to be updated when new enum values are introduced: we'll use the automatically generated ones for those already. The `old*` files were created using the following command: ``` cp ocaml/xapi-cli-server/record_util.ml ocaml/tests/record_util/old_record_util.ml && dune build @check --profile=release && grep 'let all_' _build/o\default/ocaml/xapi-types/aPI.ml >|ocaml/tests/record_util/old_enum_all.ml && dune fmt --auto-promote ``` Signed-off-by: Edwin Török --- ocaml/tests/record_util/dune | 4 + ocaml/tests/record_util/old_enum_all.ml | 291 +++++ ocaml/tests/record_util/old_record_util.ml | 1181 +++++++++++++++++++ ocaml/tests/record_util/test_record_util.ml | 1 + 4 files changed, 1477 insertions(+) create mode 100644 ocaml/tests/record_util/dune create mode 100644 ocaml/tests/record_util/old_enum_all.ml create mode 100644 ocaml/tests/record_util/old_record_util.ml create mode 100644 ocaml/tests/record_util/test_record_util.ml diff --git a/ocaml/tests/record_util/dune b/ocaml/tests/record_util/dune new file mode 100644 index 00000000000..7be34344458 --- /dev/null +++ b/ocaml/tests/record_util/dune @@ -0,0 +1,4 @@ +(test + (name test_record_util) + (libraries alcotest xapi_cli_server rpclib.core xapi_consts xapi_types astring fmt) +) diff --git a/ocaml/tests/record_util/old_enum_all.ml b/ocaml/tests/record_util/old_enum_all.ml new file mode 100644 index 00000000000..8c5b422365c --- /dev/null +++ b/ocaml/tests/record_util/old_enum_all.ml @@ -0,0 +1,291 @@ +let all_certificate_type = [`ca; `host; `host_internal] + +let all_cluster_host_operation = [`enable; `disable; `destroy] + +let all_cluster_operation = [`add; `remove; `enable; `disable; `destroy] + +let all_vusb_operations = [`attach; `plug; `unplug] + +let all_sdn_controller_protocol = [`ssl; `pssl] + +let all_pvs_proxy_status = + [ + `stopped + ; `initialised + ; `caching + ; `incompatible_write_cache_mode + ; `incompatible_protocol_version + ] + +let all_vgpu_type_implementation = + [`passthrough; `nvidia; `nvidia_sriov; `gvt_g; `mxgpu] + +let all_allocation_algorithm = [`breadth_first; `depth_first] + +let all_pgpu_dom0_access = + [`enabled; `disable_on_reboot; `disabled; `enable_on_reboot] + +let all_sriov_configuration_mode = [`sysfs; `modprobe; `manual; `unknown] + +let all_tunnel_protocol = [`gre; `vxlan] + +let all_cls = + [`VM; `Host; `SR; `Pool; `VMPP; `VMSS; `PVS_proxy; `VDI; `Certificate] + +let all_console_protocol = [`vt100; `rfb; `rdp] + +let all_persistence_backend = [`xapi] + +let all_vtpm_operations = [`destroy] + +let all_vbd_mode = [`RO; `RW] + +let all_vbd_type = [`CD; `Disk; `Floppy] + +let all_vbd_operations = + [`attach; `eject; `insert; `plug; `unplug; `unplug_force; `pause; `unpause] + +let all_on_boot = [`reset; `persist] + +let all_vdi_type = + [ + `system + ; `user + ; `ephemeral + ; `suspend + ; `crashdump + ; `ha_statefile + ; `metadata + ; `redo_log + ; `rrd + ; `pvs_cache + ; `cbt_metadata + ] + +let all_vdi_operations = + [ + `clone + ; `copy + ; `resize + ; `resize_online + ; `snapshot + ; `mirror + ; `destroy + ; `forget + ; `update + ; `force_unlock + ; `generate_config + ; `enable_cbt + ; `disable_cbt + ; `data_destroy + ; `list_changed_blocks + ; `set_on_boot + ; `blocked + ] + +let all_storage_operations = + [ + `scan + ; `destroy + ; `forget + ; `plug + ; `unplug + ; `update + ; `vdi_create + ; `vdi_introduce + ; `vdi_destroy + ; `vdi_resize + ; `vdi_clone + ; `vdi_snapshot + ; `vdi_mirror + ; `vdi_enable_cbt + ; `vdi_disable_cbt + ; `vdi_data_destroy + ; `vdi_list_changed_blocks + ; `vdi_set_on_boot + ; `pbd_create + ; `pbd_destroy + ] + +let all_bond_mode = [`balanceslb; `activebackup; `lacp] + +let all_primary_address_type = [`IPv4; `IPv6] + +let all_ipv6_configuration_mode = [`None; `DHCP; `Static; `Autoconf] + +let all_ip_configuration_mode = [`None; `DHCP; `Static] + +let all_pif_igmp_status = [`enabled; `disabled; `unknown] + +let all_vif_ipv6_configuration_mode = [`None; `Static] + +let all_vif_ipv4_configuration_mode = [`None; `Static] + +let all_vif_locking_mode = [`network_default; `locked; `unlocked; `disabled] + +let all_vif_operations = [`attach; `plug; `unplug] + +let all_network_purpose = [`nbd; `insecure_nbd] + +let all_network_default_locking_mode = [`unlocked; `disabled] + +let all_network_operations = [`attaching] + +let all_host_numa_affinity_policy = [`any; `best_effort; `default_policy] + +let all_host_sched_gran = [`core; `cpu; `socket] + +let all_latest_synced_updates_applied_state = [`yes; `no; `unknown] + +let all_update_guidances = + [ + `reboot_host + ; `reboot_host_on_livepatch_failure + ; `restart_toolstack + ; `restart_device_model + ] + +let all_host_display = + [`enabled; `disable_on_reboot; `disabled; `enable_on_reboot] + +let all_host_allowed_operations = + [ + `provision + ; `evacuate + ; `shutdown + ; `reboot + ; `power_on + ; `vm_start + ; `vm_resume + ; `vm_migrate + ; `apply_updates + ] + +let all_vm_appliance_operation = + [`start; `clean_shutdown; `hard_shutdown; `shutdown] + +let all_vmss_type = [`snapshot; `checkpoint; `snapshot_with_quiesce] + +let all_vmss_frequency = [`hourly; `daily; `weekly] + +let all_vmpp_archive_target_type = [`none; `cifs; `nfs] + +let all_vmpp_archive_frequency = [`never; `always_after_backup; `daily; `weekly] + +let all_vmpp_backup_frequency = [`hourly; `daily; `weekly] + +let all_vmpp_backup_type = [`snapshot; `checkpoint] + +let all_tristate_type = [`yes; `no; `unspecified] + +let all_domain_type = [`hvm; `pv; `pv_in_pvh; `pvh; `unspecified] + +let all_on_crash_behaviour = + [ + `destroy + ; `coredump_and_destroy + ; `restart + ; `coredump_and_restart + ; `preserve + ; `rename_restart + ] + +let all_vm_operations = + [ + `snapshot + ; `clone + ; `copy + ; `create_template + ; `revert + ; `checkpoint + ; `snapshot_with_quiesce + ; `provision + ; `start + ; `start_on + ; `pause + ; `unpause + ; `clean_shutdown + ; `clean_reboot + ; `hard_shutdown + ; `power_state_reset + ; `hard_reboot + ; `suspend + ; `csvm + ; `resume + ; `resume_on + ; `pool_migrate + ; `migrate_send + ; `get_boot_record + ; `send_sysrq + ; `send_trigger + ; `query_services + ; `shutdown + ; `call_plugin + ; `changing_memory_live + ; `awaiting_memory_live + ; `changing_dynamic_range + ; `changing_static_range + ; `changing_memory_limits + ; `changing_shadow_memory + ; `changing_shadow_memory_live + ; `changing_VCPUs + ; `changing_VCPUs_live + ; `changing_NVRAM + ; `assert_operation_valid + ; `data_source_op + ; `update_allowed_operations + ; `make_into_template + ; `import + ; `export + ; `metadata_export + ; `reverting + ; `destroy + ; `create_vtpm + ] + +let all_on_normal_exit = [`destroy; `restart] + +let all_on_softreboot_behavior = [`soft_reboot; `destroy; `restart; `preserve] + +let all_vm_power_state = [`Halted; `Paused; `Running; `Suspended] + +let all_update_after_apply_guidance = + [`restartHVM; `restartPV; `restartHost; `restartXAPI] + +let all_after_apply_guidance = + [`restartHVM; `restartPV; `restartHost; `restartXAPI] + +let all_update_sync_frequency = [`daily; `weekly] + +let all_telemetry_frequency = [`daily; `weekly; `monthly] + +let all_pool_allowed_operations = + [ + `ha_enable + ; `ha_disable + ; `cluster_create + ; `designate_new_master + ; `configure_repositories + ; `sync_updates + ; `get_updates + ; `apply_updates + ; `tls_verification_enable + ; `cert_refresh + ; `exchange_certificates_on_join + ; `exchange_ca_certificates_on_join + ; `copy_primary_host_certs + ] + +let all_task_status_type = + [`pending; `success; `failure; `cancelling; `cancelled] + +let all_task_allowed_operations = [`cancel; `destroy] + +let all_hello_return = [`ok; `unknown_host; `cannot_talk_back] + +let all_livepatch_status = + [`ok_livepatch_complete; `ok_livepatch_incomplete; `ok] + +let all_sr_health = [`healthy; `recovering] + +let all_event_operation = [`add; `del; `_mod] diff --git a/ocaml/tests/record_util/old_record_util.ml b/ocaml/tests/record_util/old_record_util.ml new file mode 100644 index 00000000000..be84179d744 --- /dev/null +++ b/ocaml/tests/record_util/old_record_util.ml @@ -0,0 +1,1181 @@ +(* + * 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. + *) +(* conversion utils *) + +exception Record_failure of string + +let to_str = function Rpc.String x -> x | _ -> failwith "Invalid" + +let certificate_type_to_string = function + | `host -> + "host" + | `host_internal -> + "host_internal" + | `ca -> + "ca" + +let class_to_string cls = + match cls with + | `VM -> + "VM" + | `Host -> + "Host" + | `SR -> + "SR" + | `Pool -> + "Pool" + | `VMPP -> + "VMPP" + | `VMSS -> + "VMSS" + | `PVS_proxy -> + "PVS_proxy" + | `VDI -> + "VDI" + | `Certificate -> + "Certificate" + | _ -> + "unknown" + +let string_to_class str = + match str with + | "VM" -> + `VM + | "Host" -> + `Host + | "SR" -> + `SR + | "Pool" -> + `Pool + | "VMPP" -> + `VMPP + | "VMSS" -> + `VMSS + | "PVS_proxy" -> + `PVS_proxy + | "VDI" -> + `VDI + | "Certificate" -> + `Certificate + | _ -> + failwith "Bad type" + +let power_state_to_string state = + match state with + | `Halted -> + "Halted" + | `Paused -> + "Paused" + | `Running -> + "Running" + | `Suspended -> + "Suspended" + | `ShuttingDown -> + "Shutting down" + | `Migrating -> + "Migrating" + +let vm_operation_table = + [ + (`assert_operation_valid, "assertoperationvalid") + ; (`changing_dynamic_range, "changing_dynamic_range") + ; (`changing_static_range, "changing_static_range") + ; (`changing_shadow_memory, "changing_shadow_memory") + ; (`clean_reboot, "clean_reboot") + ; (`clean_shutdown, "clean_shutdown") + ; (`clone, "clone") + ; (`snapshot, "snapshot") + ; (`checkpoint, "checkpoint") + ; (`snapshot_with_quiesce, "snapshot_with_quiesce") + ; (`copy, "copy") + ; (`revert, "revert") + ; (`reverting, "reverting") + ; (`provision, "provision") + ; (`destroy, "destroy") + ; (`export, "export") + ; (`metadata_export, "metadata_export") + ; (`import, "import") + ; (`get_boot_record, "get_boot_record") + ; (`data_source_op, "data_sources_op") + ; (`hard_reboot, "hard_reboot") + ; (`hard_shutdown, "hard_shutdown") + ; (`migrate_send, "migrate_send") + ; (`pause, "pause") + ; (`resume, "resume") + ; (`resume_on, "resume_on") + ; (`changing_VCPUs_live, "changing_VCPUs_live") + ; (`changing_NVRAM, "changing_NVRAM") + ; (`start, "start") + ; (`start_on, "start_on") + ; (`suspend, "suspend") + ; (`unpause, "unpause") + ; (`update_allowed_operations, "update_allowed_operations") + ; (`make_into_template, "make_into_template") + ; (`send_sysrq, "send_sysrq") + ; (`send_trigger, "send_trigger") + ; (`changing_memory_live, "changing_memory_live") + ; (`awaiting_memory_live, "awaiting_memory_live") + ; (`changing_shadow_memory_live, "changing_shadow_memory_live") + ; (`pool_migrate, "pool_migrate") + ; (`power_state_reset, "power_state_reset") + ; (`csvm, "csvm") + ; (`call_plugin, "call_plugin") + ; (`create_vtpm, "create_vtpm") + ] + +let vm_operation_to_string x = + if not (List.mem_assoc x vm_operation_table) then + "(unknown operation)" + else + List.assoc x vm_operation_table + +let string_to_vm_operation x = + let table = List.map (fun (a, b) -> (b, a)) vm_operation_table in + if not (List.mem_assoc x table) then + raise + (Api_errors.Server_error + (Api_errors.invalid_value, ["blocked_operation"; x]) + ) + else + List.assoc x table + +let pool_operation_to_string = function + | `ha_enable -> + "ha_enable" + | `ha_disable -> + "ha_disable" + | `cluster_create -> + "cluster_create" + | `designate_new_master -> + "designate_new_master" + | `tls_verification_enable -> + "tls_verification_enable" + | `configure_repositories -> + "configure_repositories" + | `sync_updates -> + "sync_updates" + | `get_updates -> + "get_updates" + | `apply_updates -> + "apply_updates" + | `cert_refresh -> + "cert_refresh" + | `exchange_certificates_on_join -> + "exchange_certificates_on_join" + | `exchange_ca_certificates_on_join -> + "exchange_ca_certificates_on_join" + | `copy_primary_host_certs -> + "copy_primary_host_certs" + +let host_operation_to_string = function + | `provision -> + "provision" + | `evacuate -> + "evacuate" + | `shutdown -> + "shutdown" + | `reboot -> + "reboot" + | `power_on -> + "power_on" + | `vm_start -> + "VM.start" + | `vm_resume -> + "VM.resume" + | `vm_migrate -> + "VM.migrate" + | `apply_updates -> + "apply_updates" + +let update_guidance_to_string = function + | `reboot_host -> + "reboot_host" + | `reboot_host_on_livepatch_failure -> + "reboot_host_on_livepatch_failure" + | `restart_toolstack -> + "restart_toolstack" + | `restart_device_model -> + "restart_device_model" + +let latest_synced_updates_applied_state_to_string = function + | `yes -> + "yes" + | `no -> + "no" + | `unknown -> + "unknown" + +let vdi_operation_to_string : API.vdi_operations -> string = function + | `clone -> + "clone" + | `copy -> + "copy" + | `resize -> + "resize" + | `resize_online -> + "resize_online" + | `destroy -> + "destroy" + | `force_unlock -> + "force_unlock" + | `snapshot -> + "snapshot" + | `mirror -> + "mirror" + | `forget -> + "forget" + | `update -> + "update" + | `generate_config -> + "generate_config" + | `enable_cbt -> + "enable_cbt" + | `disable_cbt -> + "disable_cbt" + | `data_destroy -> + "data_destroy" + | `list_changed_blocks -> + "list_changed_blocks" + | `set_on_boot -> + "set_on_boot" + | `blocked -> + "blocked" + +let sr_operation_to_string : API.storage_operations -> string = function + | `scan -> + "scan" + | `destroy -> + "destroy" + | `forget -> + "forget" + | `plug -> + "plug" + | `unplug -> + "unplug" + | `update -> + "update" + | `vdi_create -> + "VDI.create" + | `vdi_introduce -> + "VDI.introduce" + | `vdi_destroy -> + "VDI.destroy" + | `vdi_resize -> + "VDI.resize" + | `vdi_clone -> + "VDI.clone" + | `vdi_snapshot -> + "VDI.snapshot" + | `vdi_mirror -> + "VDI.mirror" + | `vdi_enable_cbt -> + "VDI.enable_cbt" + | `vdi_disable_cbt -> + "VDI.disable_cbt" + | `vdi_set_on_boot -> + "VDI.set_on_boot" + | `vdi_data_destroy -> + "VDI.data_destroy" + | `vdi_list_changed_blocks -> + "VDI.list_changed_blocks" + | `pbd_create -> + "PBD.create" + | `pbd_destroy -> + "PBD.destroy" + +let vbd_operation_to_string = function + | `attach -> + "attach" + | `eject -> + "eject" + | `insert -> + "insert" + | `plug -> + "plug" + | `unplug -> + "unplug" + | `unplug_force -> + "unplug_force" + | `pause -> + "pause" + | `unpause -> + "unpause" + +let vif_operation_to_string = function + | `attach -> + "attach" + | `plug -> + "plug" + | `unplug -> + "unplug" + | `unplug_force -> + "unplug_force" + +let vif_locking_mode_to_string = function + | `network_default -> + "network_default" + | `locked -> + "locked" + | `unlocked -> + "unlocked" + | `disabled -> + "disabled" + +let string_to_vif_locking_mode = function + | "network_default" -> + `network_default + | "locked" -> + `locked + | "unlocked" -> + `unlocked + | "disabled" -> + `disabled + | s -> + raise + (Record_failure + ("Expected 'network_default', 'locked', 'unlocked', 'disabled', got " + ^ s + ) + ) + +let vmss_type_to_string = function + | `snapshot -> + "snapshot" + | `checkpoint -> + "checkpoint" + | `snapshot_with_quiesce -> + "snapshot_with_quiesce" + +let string_to_vmss_type = function + | "snapshot" -> + `snapshot + | "checkpoint" -> + `checkpoint + | "snapshot_with_quiesce" -> + `snapshot_with_quiesce + | s -> + raise + (Record_failure + ("Expected 'snapshot', 'checkpoint', 'snapshot_with_quiesce', got " + ^ s + ) + ) + +let vmss_frequency_to_string = function + | `hourly -> + "hourly" + | `daily -> + "daily" + | `weekly -> + "weekly" + +let string_to_vmss_frequency = function + | "hourly" -> + `hourly + | "daily" -> + `daily + | "weekly" -> + `weekly + | s -> + raise (Record_failure ("Expected 'hourly', 'daily', 'weekly', got " ^ s)) + +let network_default_locking_mode_to_string = function + | `unlocked -> + "unlocked" + | `disabled -> + "disabled" + +let string_to_network_default_locking_mode = function + | "unlocked" -> + `unlocked + | "disabled" -> + `disabled + | s -> + raise (Record_failure ("Expected 'unlocked' or 'disabled', got " ^ s)) + +let network_purpose_to_string : API.network_purpose -> string = function + | `nbd -> + "nbd" + | `insecure_nbd -> + "insecure_nbd" + +let string_to_network_purpose : string -> API.network_purpose = function + | "nbd" -> + `nbd + | "insecure_nbd" -> + `insecure_nbd + | s -> + raise (Record_failure ("Expected a network purpose string; got " ^ s)) + +let vm_appliance_operation_to_string = function + | `start -> + "start" + | `clean_shutdown -> + "clean_shutdown" + | `hard_shutdown -> + "hard_shutdown" + | `shutdown -> + "shutdown" + +let cpu_feature_to_string f = + match f with + | `FPU -> + "FPU" + | `VME -> + "VME" + | `DE -> + "DE" + | `PSE -> + "PSE" + | `TSC -> + "TSC" + | `MSR -> + "MSR" + | `PAE -> + "PAE" + | `MCE -> + "MCE" + | `CX8 -> + "CX8" + | `APIC -> + "APIC" + | `SEP -> + "SEP" + | `MTRR -> + "MTRR" + | `PGE -> + "PGE" + | `MCA -> + "MCA" + | `CMOV -> + "CMOV" + | `PAT -> + "PAT" + | `PSE36 -> + "PSE36" + | `PN -> + "PN" + | `CLFLSH -> + "CLFLSH" + | `DTES -> + "DTES" + | `ACPI -> + "ACPI" + | `MMX -> + "MMX" + | `FXSR -> + "FXSR" + | `XMM -> + "XMM" + | `XMM2 -> + "XMM2" + | `SELFSNOOP -> + "SELFSNOOP" + | `HT -> + "HT" + | `ACC -> + "ACC" + | `IA64 -> + "IA64" + | `SYSCALL -> + "SYSCALL" + | `MP -> + "MP" + | `NX -> + "NX" + | `MMXEXT -> + "MMXEXT" + | `LM -> + "LM" + | `THREEDNOWEXT -> + "3DNOWEXT" + | `THREEDNOW -> + "3DNOW" + | `RECOVERY -> + "RECOVERY" + | `LONGRUN -> + "LONGRUN" + | `LRTI -> + "LRTI" + | `CXMMX -> + "CXMMX" + | `K6MTRR -> + "K6MTRR" + | `CYRIXARR -> + "CYRIXARR" + | `CENTAURMCR -> + "CENTAURMCR" + | `K8 -> + "K8" + | `K7 -> + "K7" + | `P3 -> + "P3" + | `P4 -> + "P4" + | `CONSTANTTSC -> + "CONSTANTTSC" + | `FXSAVELEAK -> + "FXSAVELEAK" + | `XMM3 -> + "XMM3" + | `MWAIT -> + "MWAIT" + | `DSCPL -> + "DSCPL" + | `EST -> + "EST" + | `TM2 -> + "TM2" + | `CID -> + "CID" + | `CX16 -> + "CX16" + | `XTPR -> + "XTPR" + | `XSTORE -> + "XSTORE" + | `XSTOREEN -> + "XSTOREEN" + | `XCRYPT -> + "XCRYPT" + | `XCRYPTEN -> + "XCRYPTEN" + | `LAHFLM -> + "LAHFLM" + | `CMPLEGACY -> + "CMPLEGACY" + | `VMX -> + "VMX" + +let task_status_type_to_string s = + match s with + | `pending -> + "pending" + | `success -> + "success" + | `failure -> + "failure" + | `cancelling -> + "cancelling" + | `cancelled -> + "cancelled" + +let protocol_to_string = function + | `vt100 -> + "VT100" + | `rfb -> + "RFB" + | `rdp -> + "RDP" + +let telemetry_frequency_to_string = function + | `daily -> + "daily" + | `weekly -> + "weekly" + | `monthly -> + "monthly" + +let task_allowed_operations_to_string s = + match s with `cancel -> "Cancel" | `destroy -> "Destroy" + +let alert_level_to_string s = + match s with `Info -> "info" | `Warn -> "warning" | `Error -> "error" + +let on_normal_exit_to_string x = + match x with `destroy -> "Destroy" | `restart -> "Restart" + +let string_to_on_normal_exit s = + match String.lowercase_ascii s with + | "destroy" -> + `destroy + | "restart" -> + `restart + | _ -> + raise (Record_failure ("Expected 'destroy' or 'restart', got " ^ s)) + +let on_crash_behaviour_to_string x = + match x with + | `destroy -> + "Destroy" + | `coredump_and_destroy -> + "Core dump and destroy" + | `restart -> + "Restart" + | `coredump_and_restart -> + "Core dump and restart" + | `preserve -> + "Preserve" + | `rename_restart -> + "Rename restart" + +let string_to_on_crash_behaviour s = + match String.lowercase_ascii s with + | "destroy" -> + `destroy + | "coredump_and_destroy" -> + `coredump_and_destroy + | "restart" -> + `restart + | "coredump_and_restart" -> + `coredump_and_restart + | "preserve" -> + `preserve + | "rename_restart" -> + `rename_restart + | _ -> + raise + (Record_failure + ("Expected 'destroy', 'coredump_and_destroy'," + ^ "'restart', 'coredump_and_restart', 'preserve' or \ + 'rename_restart', got " + ^ s + ) + ) + +let on_softreboot_behaviour_to_string x = + match x with + | `destroy -> + "Destroy" + | `restart -> + "Restart" + | `preserve -> + "Preserve" + | `soft_reboot -> + "Soft reboot" + +let string_to_on_softreboot_behaviour s = + match String.lowercase_ascii s with + | "destroy" -> + `destroy + | "restart" -> + `restart + | "preserve" -> + `preserve + | "soft_reboot" -> + `soft_reboot + | _ -> + raise + (Record_failure + ("Expected 'destroy', 'coredump_and_destroy'," + ^ "'restart', 'coredump_and_restart', 'preserve', 'soft_reboot' or \ + 'rename_restart', got " + ^ s + ) + ) + +let host_display_to_string h = + match h with + | `enabled -> + "enabled" + | `enable_on_reboot -> + "enable_on_reboot" + | `disabled -> + "disabled" + | `disable_on_reboot -> + "disable_on_reboot" + +let host_sched_gran_of_string s = + match String.lowercase_ascii s with + | "core" -> + `core + | "cpu" -> + `cpu + | "socket" -> + `socket + | _ -> + raise (Record_failure ("Expected 'core','cpu', 'socket', got " ^ s)) + +let host_sched_gran_to_string = function + | `core -> + "core" + | `cpu -> + "cpu" + | `socket -> + "socket" + +let host_numa_affinity_policy_to_string = function + | `any -> + "any" + | `best_effort -> + "best_effort" + | `default_policy -> + "default_policy" + +let host_numa_affinity_policy_of_string a = + match String.lowercase_ascii a with + | "any" -> + `any + | "best_effort" -> + `best_effort + | "default_policy" -> + `default_policy + | s -> + raise + (Record_failure + ("Expected 'any', 'best_effort' or 'default_policy', got " ^ s) + ) + +let pgpu_dom0_access_to_string x = host_display_to_string x + +let string_to_vdi_onboot s = + match String.lowercase_ascii s with + | "persist" -> + `persist + | "reset" -> + `reset + | _ -> + raise (Record_failure ("Expected 'persist' or 'reset', got " ^ s)) + +let string_to_vbd_mode s = + match String.lowercase_ascii s with + | "ro" -> + `RO + | "rw" -> + `RW + | _ -> + raise (Record_failure ("Expected 'RO' or 'RW', got " ^ s)) + +let vbd_mode_to_string = function `RO -> "ro" | `RW -> "rw" + +let string_to_vbd_type s = + match String.lowercase_ascii s with + | "cd" -> + `CD + | "disk" -> + `Disk + | "floppy" -> + `Floppy + | _ -> + raise (Record_failure ("Expected 'CD' or 'Disk', got " ^ s)) + +let power_to_string h = + match h with + | `Halted -> + "halted" + | `Paused -> + "paused" + | `Running -> + "running" + | `Suspended -> + "suspended" + | `ShuttingDown -> + "shutting down" + | `Migrating -> + "migrating" + +let vdi_type_to_string t = + match t with + | `system -> + "System" + | `user -> + "User" + | `ephemeral -> + "Ephemeral" + | `suspend -> + "Suspend" + | `crashdump -> + "Crashdump" + | `ha_statefile -> + "HA statefile" + | `metadata -> + "Metadata" + | `redo_log -> + "Redo log" + | `rrd -> + "rrd" + | `pvs_cache -> + "PVS cache" + | `cbt_metadata -> + "CBT metadata" + +let ip_configuration_mode_to_string = function + | `None -> + "None" + | `DHCP -> + "DHCP" + | `Static -> + "Static" + +let ip_configuration_mode_of_string m = + match String.lowercase_ascii m with + | "dhcp" -> + `DHCP + | "none" -> + `None + | "static" -> + `Static + | s -> + raise (Record_failure ("Expected 'dhcp','none' or 'static', got " ^ s)) + +let vif_ipv4_configuration_mode_to_string = function + | `None -> + "None" + | `Static -> + "Static" + +let vif_ipv4_configuration_mode_of_string m = + match String.lowercase_ascii m with + | "none" -> + `None + | "static" -> + `Static + | s -> + raise (Record_failure ("Expected 'none' or 'static', got " ^ s)) + +let ipv6_configuration_mode_to_string = function + | `None -> + "None" + | `DHCP -> + "DHCP" + | `Static -> + "Static" + | `Autoconf -> + "Autoconf" + +let ipv6_configuration_mode_of_string m = + match String.lowercase_ascii m with + | "dhcp" -> + `DHCP + | "none" -> + `None + | "static" -> + `Static + | "autoconf" -> + `Autoconf + | s -> + raise + (Record_failure + ("Expected 'dhcp','none' 'autoconf' or 'static', got " ^ s) + ) + +let vif_ipv6_configuration_mode_to_string = function + | `None -> + "None" + | `Static -> + "Static" + +let vif_ipv6_configuration_mode_of_string m = + match String.lowercase_ascii m with + | "none" -> + `None + | "static" -> + `Static + | s -> + raise (Record_failure ("Expected 'none' or 'static', got " ^ s)) + +let primary_address_type_to_string = function + | `IPv4 -> + "IPv4" + | `IPv6 -> + "IPv6" + +let primary_address_type_of_string m = + match String.lowercase_ascii m with + | "ipv4" -> + `IPv4 + | "ipv6" -> + `IPv6 + | s -> + raise (Record_failure ("Expected 'ipv4' or 'ipv6', got " ^ s)) + +let bond_mode_to_string = function + | `balanceslb -> + "balance-slb" + | `activebackup -> + "active-backup" + | `lacp -> + "lacp" + +let bond_mode_of_string m = + match String.lowercase_ascii m with + | "balance-slb" | "" -> + `balanceslb + | "active-backup" -> + `activebackup + | "lacp" -> + `lacp + | s -> + raise (Record_failure ("Invalid bond mode. Got " ^ s)) + +let allocation_algorithm_to_string = function + | `depth_first -> + "depth-first" + | `breadth_first -> + "breadth-first" + +let allocation_algorithm_of_string a = + match String.lowercase_ascii a with + | "depth-first" -> + `depth_first + | "breadth-first" -> + `breadth_first + | s -> + raise (Record_failure ("Invalid allocation algorithm. Got " ^ s)) + +let pvs_proxy_status_to_string = function + | `stopped -> + "stopped" + | `initialised -> + "initialised" + | `caching -> + "caching" + | `incompatible_write_cache_mode -> + "incompatible-write-cache-mode" + | `incompatible_protocol_version -> + "incompatible-protocol-version" + +let cluster_operation_to_string op = API.rpc_of_cluster_operation op |> to_str + +let cluster_host_operation_to_string op = + API.rpc_of_cluster_host_operation op |> to_str + +let bool_of_string s = + match String.lowercase_ascii s with + | "true" | "yes" -> + true + | "false" | "no" -> + false + | _ -> + raise (Record_failure ("Expected 'true','yes','false','no', got " ^ s)) + +let sdn_protocol_of_string s = + match String.lowercase_ascii s with + | "ssl" -> + `ssl + | "pssl" -> + `pssl + | _ -> + raise (Record_failure ("Expected 'ssl','pssl', got " ^ s)) + +let sdn_protocol_to_string = function `ssl -> "ssl" | `pssl -> "pssl" + +let tunnel_protocol_of_string s = + match String.lowercase_ascii s with + | "gre" -> + `gre + | "vxlan" -> + `vxlan + | _ -> + raise (Record_failure ("Expected 'gre','vxlan', got " ^ s)) + +let tunnel_protocol_to_string = function `gre -> "gre" | `vxlan -> "vxlan" + +let pif_igmp_status_to_string = function + | `enabled -> + "enabled" + | `disabled -> + "disabled" + | `unknown -> + "unknown" + +let vusb_operation_to_string = function + | `attach -> + "attach" + | `plug -> + "plug" + | `unplug -> + "unplug" + +let network_sriov_configuration_mode_to_string = function + | `sysfs -> + "sysfs" + | `modprobe -> + "modprobe" + | `manual -> + "manual" + | `unknown -> + "unknown" + +(* string_to_string_map_to_string *) +let s2sm_to_string sep x = + String.concat sep (List.map (fun (a, b) -> a ^ ": " ^ b) x) + +(* string to blob ref map to string *) +let s2brm_to_string get_uuid_from_ref sep x = + String.concat sep (List.map (fun (n, r) -> n ^ ": " ^ get_uuid_from_ref r) x) + +let on_boot_to_string onboot = + match onboot with `reset -> "reset" | `persist -> "persist" + +let tristate_to_string tristate = + match tristate with + | `yes -> + "true" + | `no -> + "false" + | `unspecified -> + "unspecified" + +let domain_type_to_string = function + | `hvm -> + "hvm" + | `pv -> + "pv" + | `pv_in_pvh -> + "pv-in-pvh" + | `pvh -> + "pvh" + | `unspecified -> + "unspecified" + +let domain_type_of_string x = + match String.lowercase_ascii x with + | "hvm" -> + `hvm + | "pv" -> + `pv + | "pv-in-pvh" -> + `pv_in_pvh + | "pvh" -> + `pvh + | s -> + raise (Record_failure ("Invalid domain type. Got " ^ s)) + +let vtpm_operation_to_string (op : API.vtpm_operations) = + match op with `destroy -> "destroy" + +(** Parse a string which might have a units suffix on the end *) +let bytes_of_string field x = + let ( ** ) a b = Int64.mul a b in + let max_size_TiB = + Int64.div Int64.max_int (1024L ** 1024L ** 1024L ** 1024L) + in + (* detect big number that cannot be represented by Int64. *) + let int64_of_string s = + try Int64.of_string s + with _ -> + if s = "" then + raise + (Record_failure + (Printf.sprintf + "Failed to parse field '%s': expecting an integer (possibly \ + with suffix)" + field + ) + ) ; + let alldigit = ref true and i = ref (String.length s - 1) in + while !alldigit && !i > 0 do + alldigit := Astring.Char.Ascii.is_digit s.[!i] ; + decr i + done ; + if !alldigit then + raise + (Record_failure + (Printf.sprintf + "Failed to parse field '%s': number too big (maximum = %Ld TiB)" + field max_size_TiB + ) + ) + else + raise + (Record_failure + (Printf.sprintf + "Failed to parse field '%s': expecting an integer (possibly \ + with suffix)" + field + ) + ) + in + match + Astring.( + String.fields ~empty:false ~is_sep:(fun c -> + Char.Ascii.(is_white c || is_digit c) + ) + ) + x + with + | [] -> + (* no suffix on the end *) + int64_of_string x + | [suffix] -> + let number = + match + Astring.( + String.fields ~empty:false ~is_sep:(Fun.negate Char.Ascii.is_digit) + ) + x + with + | [number] -> + int64_of_string number + | _ -> + raise + (Record_failure + (Printf.sprintf + "Failed to parse field '%s': expecting an integer \ + (possibly with suffix)" + field + ) + ) + in + let multiplier = + match suffix with + | "bytes" -> + 1L + | "KiB" -> + 1024L + | "MiB" -> + 1024L ** 1024L + | "GiB" -> + 1024L ** 1024L ** 1024L + | "TiB" -> + 1024L ** 1024L ** 1024L ** 1024L + | x -> + raise + (Record_failure + (Printf.sprintf + "Failed to parse field '%s': Unknown suffix: '%s' (try \ + KiB, MiB, GiB or TiB)" + field x + ) + ) + in + (* FIXME: detect overflow *) + number ** multiplier + | _ -> + raise + (Record_failure + (Printf.sprintf + "Failed to parse field '%s': expecting an integer (possibly with \ + suffix)" + field + ) + ) + +(* Vincent's random mac utils *) + +let mac_from_int_array macs = + (* make sure bit 1 (local) is set and bit 0 (unicast) is clear *) + macs.(0) <- macs.(0) lor 0x2 land lnot 0x1 ; + Printf.sprintf "%02x:%02x:%02x:%02x:%02x:%02x" macs.(0) macs.(1) macs.(2) + macs.(3) macs.(4) macs.(5) + +(* generate a random mac that is locally administered *) +let random_mac_local () = mac_from_int_array (Array.make 6 (Random.int 0x100)) + +let update_sync_frequency_to_string = function + | `daily -> + "daily" + | `weekly -> + "weekly" + +let update_sync_frequency_of_string s = + match String.lowercase_ascii s with + | "daily" -> + `daily + | "weekly" -> + `weekly + | _ -> + raise (Record_failure ("Expected 'daily', 'weekly', got " ^ s)) diff --git a/ocaml/tests/record_util/test_record_util.ml b/ocaml/tests/record_util/test_record_util.ml new file mode 100644 index 00000000000..8b137891791 --- /dev/null +++ b/ocaml/tests/record_util/test_record_util.ml @@ -0,0 +1 @@ + From f209e3ebc0563ce3fc3229a74cdafb10563e2b57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 4 Jan 2024 18:45:41 +0000 Subject: [PATCH 08/65] test(record_util): add tests for all enums MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/tests/record_util/dune | 1 + ocaml/tests/record_util/test_record_util.ml | 269 ++++++++++++++++++++ 2 files changed, 270 insertions(+) diff --git a/ocaml/tests/record_util/dune b/ocaml/tests/record_util/dune index 7be34344458..ec5847bc3e8 100644 --- a/ocaml/tests/record_util/dune +++ b/ocaml/tests/record_util/dune @@ -1,4 +1,5 @@ (test (name test_record_util) (libraries alcotest xapi_cli_server rpclib.core xapi_consts xapi_types astring fmt) + (action (run %{test} --show-errors)) ) diff --git a/ocaml/tests/record_util/test_record_util.ml b/ocaml/tests/record_util/test_record_util.ml index 8b137891791..e560904366b 100644 --- a/ocaml/tests/record_util/test_record_util.ml +++ b/ocaml/tests/record_util/test_record_util.ml @@ -1 +1,270 @@ +module O = Old_record_util +module N = Record_util +open Old_enum_all +open Printf +open Alcotest +let test_compat enum old_conv new_conv testable () = + let expected = old_conv enum and actual = new_conv enum in + V1.(check' ~msg:"compatible" ~expected ~actual) testable + +let make_conv_test ~desc all conv_opt line testable = + conv_opt + |> Option.map (fun (old_conv, new_conv) -> + let name = sprintf "line%d:%s" line desc in + [ + ( name + , all + |> List.map @@ fun enum -> + V1.test_case enum `Quick + @@ test_compat enum old_conv new_conv testable + ) + ] + ) + |> Option.value ~default:[] + +let test_to_string ~name all_enum (old_to_string, new_to_string) = + ( name ^ "to_string" + , all_enum + |> List.map @@ fun enum -> + let expected = old_to_string enum in + V1.test_case expected `Quick @@ fun () -> + let actual = new_to_string enum in + V1.(check' ~msg:"compatible" ~expected ~actual string) + ) + +(* If record_util raises on of_string of a valid enum, it should raise the same exception. + Currently this only happens on 'unspecified' VM domain type. +*) +let wrap f x = try Ok (f x) with e -> Error e + +let drop_module_prefix s = + match Astring.String.cut ~sep:"." s with + | Some (_module, rest) -> + rest + | None -> + s + +let drop_exn_arguments s = + match Astring.String.cut ~sep:"(" s with + | Some (typ, _args) -> + typ + | None -> + s + +let exn_to_string_strip e = + (* Drop the module prefix: that is expected to be different. + We'll only look at the exception type and not its string arguments, + to allow improving the error message in the future. + *) + e |> Printexc.to_string |> drop_module_prefix |> drop_exn_arguments + +let exn_equal_strip a b = + String.equal (exn_to_string_strip a) (exn_to_string_strip b) + +let exn = V1.testable (Fmt.of_to_string exn_to_string_strip) exn_equal_strip + +let test_of_string ~name all_enum old_to_string of_string_opt = + of_string_opt + |> Option.map (fun (old_of_string, new_of_string) -> + let make input = + V1.test_case input `Quick @@ fun () -> + let expected = wrap old_of_string input in + let actual = wrap new_of_string input in + let pp_enum = Fmt.of_to_string old_to_string in + V1.( + check' ~msg:"compatible" ~expected ~actual + @@ result (testable pp_enum ( = )) exn + ) + in + ( name ^ "of_string" + , make "bad-BaD-BAD" + :: (all_enum + |> List.concat_map @@ fun enum -> + let input = old_to_string enum in + [ + make input + ; make (String.capitalize_ascii input) + ; make (String.uppercase_ascii input) + ] + ) + ) + ) + |> Option.to_list + +let mk line of_string_opt all_enum (old_to_string, new_to_string) = + let name = sprintf "line%d:" line in + test_to_string ~name all_enum (old_to_string, new_to_string) + :: test_of_string ~name all_enum old_to_string of_string_opt + +(* +Created by: +``` +grep 'let.*to_string' old_record_util.ml | sed -re 's/^let ([^ ]+)_to_string.*/\1/' | while read ENUM; do if grep "${ENUM}_of_string" old_record_util.ml >/dev/null; then echo "; mk __LINE__ (Some (O.${ENUM}_of_string, N.${ENUM}_of_string)) all_${ENUM} (O.${ENUM}_to_string, N.${ENUM}_to_string)"; else echo "; mk __LINE__ None all_${ENUM} (O.${ENUM}_to_string, N.${ENUM}_to_string)"; fi; done +``` +and then tweaked to compile using LSP hints where the names were not consistent (e.g. singular vs plural, etc.) +*) +let tests = + [ + mk __LINE__ None all_certificate_type + (O.certificate_type_to_string, N.certificate_type_to_string) + ; mk __LINE__ None all_cls (O.class_to_string, N.class_to_string) + ; mk __LINE__ None all_vm_power_state + (O.power_state_to_string, N.power_state_to_string) + ; mk __LINE__ None all_vm_operations + (O.vm_operation_to_string, N.vm_operation_to_string) + ; mk __LINE__ None all_pool_allowed_operations + (O.pool_operation_to_string, N.pool_operation_to_string) + ; mk __LINE__ None all_host_allowed_operations + (O.host_operation_to_string, N.host_operation_to_string) + ; mk __LINE__ None all_update_guidances + (O.update_guidance_to_string, N.update_guidance_to_string) + ; mk __LINE__ None all_latest_synced_updates_applied_state + ( O.latest_synced_updates_applied_state_to_string + , N.latest_synced_updates_applied_state_to_string + ) + ; mk __LINE__ None all_vdi_operations + (O.vdi_operation_to_string, N.vdi_operation_to_string) + ; mk __LINE__ None all_storage_operations + (O.sr_operation_to_string, N.sr_operation_to_string) + ; mk __LINE__ None all_vbd_operations + (O.vbd_operation_to_string, N.vbd_operation_to_string) + ; mk __LINE__ None all_vif_operations + (O.vif_operation_to_string, N.vif_operation_to_string) + ; mk __LINE__ None all_vif_locking_mode + (O.vif_locking_mode_to_string, N.vif_locking_mode_to_string) + ; mk __LINE__ None all_vmss_type (O.vmss_type_to_string, N.vmss_type_to_string) + ; mk __LINE__ None all_vmss_frequency + (O.vmss_frequency_to_string, N.vmss_frequency_to_string) + ; mk __LINE__ None all_network_default_locking_mode + ( O.network_default_locking_mode_to_string + , N.network_default_locking_mode_to_string + ) + ; mk __LINE__ None all_network_purpose + (O.network_purpose_to_string, N.network_purpose_to_string) + ; mk __LINE__ None all_vm_appliance_operation + (O.vm_appliance_operation_to_string, N.vm_appliance_operation_to_string) + (*; mk __LINE__ None all_cpu_feature (O.cpu_feature_to_string, N.cpu_feature_to_string)*) + ; mk __LINE__ None all_task_status_type + (O.task_status_type_to_string, N.task_status_type_to_string) + ; mk __LINE__ None all_console_protocol + (O.protocol_to_string, N.protocol_to_string) + ; mk __LINE__ None all_telemetry_frequency + (O.telemetry_frequency_to_string, N.telemetry_frequency_to_string) + ; mk __LINE__ None all_task_allowed_operations + (O.task_allowed_operations_to_string, N.task_allowed_operations_to_string) + (*; mk __LINE__ None all_alert_level (O.alert_level_to_string, N.alert_level_to_string)*) + ; mk __LINE__ None all_on_normal_exit + (O.on_normal_exit_to_string, N.on_normal_exit_to_string) + ; mk __LINE__ None all_on_crash_behaviour + (O.on_crash_behaviour_to_string, N.on_crash_behaviour_to_string) + ; mk __LINE__ None all_on_softreboot_behavior + (O.on_softreboot_behaviour_to_string, N.on_softreboot_behaviour_to_string) + ; mk __LINE__ None all_host_display + (O.host_display_to_string, N.host_display_to_string) + ; mk __LINE__ + (Some (O.host_sched_gran_of_string, N.host_sched_gran_of_string)) + all_host_sched_gran + (O.host_sched_gran_to_string, N.host_sched_gran_to_string) + ; mk __LINE__ + (Some + ( O.host_numa_affinity_policy_of_string + , N.host_numa_affinity_policy_of_string + ) + ) + all_host_numa_affinity_policy + ( O.host_numa_affinity_policy_to_string + , N.host_numa_affinity_policy_to_string + ) + ; mk __LINE__ None all_pgpu_dom0_access + (O.pgpu_dom0_access_to_string, N.pgpu_dom0_access_to_string) + ; mk __LINE__ None all_vbd_mode (O.vbd_mode_to_string, N.vbd_mode_to_string) + (*; mk __LINE__ None all_power (O.power_to_string, N.power_to_string)*) + ; mk __LINE__ None all_vdi_type (O.vdi_type_to_string, N.vdi_type_to_string) + ; mk __LINE__ + (Some + (O.ip_configuration_mode_of_string, N.ip_configuration_mode_of_string) + ) + all_ip_configuration_mode + (O.ip_configuration_mode_to_string, N.ip_configuration_mode_to_string) + ; mk __LINE__ + (Some + ( O.vif_ipv4_configuration_mode_of_string + , N.vif_ipv4_configuration_mode_of_string + ) + ) + all_vif_ipv4_configuration_mode + ( O.vif_ipv4_configuration_mode_to_string + , N.vif_ipv4_configuration_mode_to_string + ) + ; mk __LINE__ + (Some + ( O.ipv6_configuration_mode_of_string + , N.ipv6_configuration_mode_of_string + ) + ) + all_ipv6_configuration_mode + (O.ipv6_configuration_mode_to_string, N.ipv6_configuration_mode_to_string) + ; mk __LINE__ + (Some + ( O.vif_ipv6_configuration_mode_of_string + , N.vif_ipv6_configuration_mode_of_string + ) + ) + all_vif_ipv6_configuration_mode + ( O.vif_ipv6_configuration_mode_to_string + , N.vif_ipv6_configuration_mode_to_string + ) + ; mk __LINE__ + (Some (O.primary_address_type_of_string, N.primary_address_type_of_string)) + all_primary_address_type + (O.primary_address_type_to_string, N.primary_address_type_to_string) + ; mk __LINE__ + (Some (O.bond_mode_of_string, N.bond_mode_of_string)) + all_bond_mode + (O.bond_mode_to_string, N.bond_mode_to_string) + ; mk __LINE__ + (Some (O.allocation_algorithm_of_string, N.allocation_algorithm_of_string)) + all_allocation_algorithm + (O.allocation_algorithm_to_string, N.allocation_algorithm_to_string) + ; mk __LINE__ None all_pvs_proxy_status + (O.pvs_proxy_status_to_string, N.pvs_proxy_status_to_string) + ; mk __LINE__ None all_cluster_operation + (O.cluster_operation_to_string, N.cluster_operation_to_string) + ; mk __LINE__ None all_cluster_host_operation + (O.cluster_host_operation_to_string, N.cluster_host_operation_to_string) + ; mk __LINE__ + (Some (O.sdn_protocol_of_string, N.sdn_protocol_of_string)) + all_sdn_controller_protocol + (O.sdn_protocol_to_string, N.sdn_protocol_to_string) + ; mk __LINE__ + (Some (O.tunnel_protocol_of_string, N.tunnel_protocol_of_string)) + all_tunnel_protocol + (O.tunnel_protocol_to_string, N.tunnel_protocol_to_string) + ; mk __LINE__ None all_pif_igmp_status + (O.pif_igmp_status_to_string, N.pif_igmp_status_to_string) + ; mk __LINE__ None all_vusb_operations + (O.vusb_operation_to_string, N.vusb_operation_to_string) + ; mk __LINE__ None all_sriov_configuration_mode + ( O.network_sriov_configuration_mode_to_string + , N.network_sriov_configuration_mode_to_string + ) + ; mk __LINE__ None all_on_boot (O.on_boot_to_string, N.on_boot_to_string) + ; mk __LINE__ None all_tristate_type + (O.tristate_to_string, N.tristate_to_string) + ; mk __LINE__ + (Some (O.domain_type_of_string, N.domain_type_of_string)) + all_domain_type + (O.domain_type_to_string, N.domain_type_to_string) + ; mk __LINE__ None all_vtpm_operations + (O.vtpm_operation_to_string, N.vtpm_operation_to_string) + ; mk __LINE__ + (Some + (O.update_sync_frequency_of_string, N.update_sync_frequency_of_string) + ) + all_update_sync_frequency + (O.update_sync_frequency_to_string, N.update_sync_frequency_to_string) + ] + |> List.concat + +let () = V1.run "record_util" tests From 1fdb4bae071b3143d358cc93d8e17387bd392746 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 16 Feb 2024 13:45:30 +0000 Subject: [PATCH 09/65] redo_log: report redo log as broken if we cannot find the block device MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit XAPI was just retrying endlessly in a loop saying "Could not find block device", but didn't raise any alerts that XenRT could detect. Report the redo log broken the first time we fail due to the lack of a bloc k device (which would indicate something going wrong in SM). Signed-off-by: Edwin Török --- ocaml/database/redo_log.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ocaml/database/redo_log.ml b/ocaml/database/redo_log.ml index 3f20e32dfac..429646dcce7 100644 --- a/ocaml/database/redo_log.ml +++ b/ocaml/database/redo_log.ml @@ -642,7 +642,8 @@ let startup log = ) ; match !(log.device) with | None -> - D.info "Could not find block device" + D.info "Could not find block device" ; + broken log | Some device -> D.info "Using block device at %s" device ; (* Check that the block device exists *) From 5d3d7a9bbbb9463bc190730e1b5ff0f52d83ee81 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 5 Mar 2024 09:55:23 +0000 Subject: [PATCH 10/65] CA-389506: fix platform:nested_virt typo MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Nested virt is not a supported feature yet, but when moving the setting from Xen to toolstack as part of the Xen-4.17 update I typoed the name of the setting. It was platform/nested-virt in xenguest.patch before Fixes: 664de7608d ("Xen-4.15+: CDF_NESTED_VIRT") Signed-off-by: Edwin Török --- ocaml/xenopsd/xc/domain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/xenopsd/xc/domain.ml b/ocaml/xenopsd/xc/domain.ml index bd17e5d284a..935027aabea 100644 --- a/ocaml/xenopsd/xc/domain.ml +++ b/ocaml/xenopsd/xc/domain.ml @@ -351,7 +351,7 @@ let make ~xc ~xs vm_info vcpus domain_config uuid final_uuid no_sharept = if iommu then assert_capability CAP_DirectIO ~on_error:(fun () -> "IOMMU unavailable") ; let nested_virt = - get_platform_key ~key:"nested_virt" ~default:false require_hvm + get_platform_key ~key:"nested-virt" ~default:false require_hvm in let vpmu = get_platform_key ~key:"vpmu" ~default:false (fun _ -> Ok ()) in From 6381d72af204e52d31c7ffd53da2c5f3b78f6939 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 20 Mar 2024 17:33:46 +0000 Subject: [PATCH 11/65] CA-381119: use JsonRPC V2 for error replies MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit For regular replies we look at the request and reply with a matching version. However when we fail to parse the JsonRPC request itself then we don't know what version to use. XenCenter uses JsonRPC v2 by default, and JsonRPC v2 has been supported in XAPI for a long time. Signed-off-by: Edwin Török --- ocaml/xapi/api_server.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index b7209ec323e..42ea7816b5c 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -345,7 +345,7 @@ let jsoncallback req bio _ = Http_svr.response_str req ~hdrs:[(Http.Hdr.content_type, "application/json")] fd - (Jsonrpc.string_of_response + (Jsonrpc.string_of_response ~version:Jsonrpc.V2 (Rpc.failure (Rpc.Enum (List.map (fun s -> Rpc.String s) (err :: params))) ) From 91529cf32288c45358cb9a4c4f67e18a164ce0fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 27 Mar 2024 15:34:58 +0000 Subject: [PATCH 12/65] XenAPI.py: use correct type for 'verbose' and 'allow_none' with Python3 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes this pytype report: ``` pytype_reporter: Expected: (self, uri, transport, encoding, verbose: bool = ..., ...) pytype_reporter: Actually passed: (self, uri, transport, encoding, verbose: int, ...) pytype_reporter: Expected: (self, uri, transport, encoding, verbose, allow_none: bool = ..., ...) pytype_reporter: Actually passed: (self, uri, transport, encoding, verbose, allow_none: int) ``` Signed-off-by: Edwin Török --- scripts/examples/python/XenAPI/XenAPI.py | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/scripts/examples/python/XenAPI/XenAPI.py b/scripts/examples/python/XenAPI/XenAPI.py index ab868e92188..7559970d662 100644 --- a/scripts/examples/python/XenAPI/XenAPI.py +++ b/scripts/examples/python/XenAPI/XenAPI.py @@ -122,6 +122,11 @@ class Session(xmlrpclib.ServerProxy): def __init__(self, uri, transport=None, encoding=None, verbose=0, allow_none=1, ignore_ssl=False): + if sys.version_info[0] > 2: + # this changed to be a 'bool' in Python3 + verbose = bool(verbose) + allow_none = bool(allow_none) + # Fix for CA-172901 (+ Python 2.4 compatibility) # Fix for context=ctx ( < Python 2.7.9 compatibility) if not (sys.version_info[0] <= 2 and sys.version_info[1] <= 7 and sys.version_info[2] <= 9 ) \ From 500a1f70a65e2b1bd0a276a202597db2a4c654d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 27 Mar 2024 15:55:51 +0000 Subject: [PATCH 13/65] XenAPI: suppress pytype false positives MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit pytype claims that there is no 'errno' in the socket module, but there is: ``` Python 3.6.8 (default, Nov 16 2020, 16:55:22) [GCC 4.8.5 20150623 (Red Hat 4.8.5-44)] on linux Type "help", "copyright", "credits" or "license" for more information. >>> import socket >>> socket.errno.ETIMEDOUT 110 ``` Also `session.local_logout` is a remote method that is proxied by `__getattr__`, I don't know why `pytype` complains about that one, and not about `logout`, but suppress it. Signed-off-by: Edwin Török --- scripts/examples/python/XenAPI/XenAPI.py | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/scripts/examples/python/XenAPI/XenAPI.py b/scripts/examples/python/XenAPI/XenAPI.py index 7559970d662..939e0432438 100644 --- a/scripts/examples/python/XenAPI/XenAPI.py +++ b/scripts/examples/python/XenAPI/XenAPI.py @@ -181,7 +181,8 @@ def _login(self, method, params): self.last_login_params = params self.API_version = self._get_api_version() except socket.error as e: - if e.errno == socket.errno.ETIMEDOUT: + # pytype false positive: there is a socket.errno in both py2 and py3 + if e.errno == socket.errno.ETIMEDOUT: # pytype: disable=module-attr raise xmlrpclib.Fault(504, 'The connection timed out') else: raise e @@ -189,7 +190,8 @@ def _login(self, method, params): def _logout(self): try: if self.last_login_method.startswith("slave_local"): - return _parse_result(self.session.local_logout(self._session)) + # Proxied function, pytype can't see it + return _parse_result(self.session.local_logout(self._session)) # pytype: disable=attribute-error else: return _parse_result(self.session.logout(self._session)) finally: From 53a7a155413e855259cd22bd4cbf6f3d93a9f900 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 26 Mar 2024 19:08:30 +0000 Subject: [PATCH 14/65] remove XenAPI.py from pytype expected to fail list MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- pyproject.toml | 1 - 1 file changed, 1 deletion(-) diff --git a/pyproject.toml b/pyproject.toml index 505f16e430c..71344c5a264 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -83,7 +83,6 @@ expected_to_fail = [ "scripts/examples/python/exportimport.py", # Other fixes needed: "scripts/examples/python/mini-xenrt.py", - "scripts/examples/python/XenAPI/XenAPI.py", "scripts/examples/python/monitor-unwanted-domains.py", "scripts/examples/python/shell.py", "scripts/examples/smapiv2.py", From 0254e536641b682290c91b996fa0e437f525f079 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 26 Mar 2024 18:05:29 +0000 Subject: [PATCH 15/65] CP-48623: use persistent unix socket connection for SM to XAPI communication MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is already the case for HTTP(S) connections, but XenAPI overrides the xmlrpclib implementation to provide a Unix socket transport, and it lacks this optimization. Otherwise we've noticed that SM makes at least 4 separate connections to XAPI to query the version number for example. On a busy system each of those connections can get delayed by 100ms: * OCaml's tick thread switches threads every 50ms, and you might need 2 switches when XAPI is busy with CPU-bound workloads: * one to accept the connection * another to handle the request on the newly spawned thread See: https://github.com/python/cpython/blob/v2.7.5/Lib/xmlrpclib.py#L1361-L1371 https://github.com/python/cpython/blob/v3.6.8/Lib/xmlrpc/client.py#L1237-L1245 Signed-off-by: Edwin Török --- scripts/examples/python/XenAPI/XenAPI.py | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/scripts/examples/python/XenAPI/XenAPI.py b/scripts/examples/python/XenAPI/XenAPI.py index 939e0432438..75ffac8c769 100644 --- a/scripts/examples/python/XenAPI/XenAPI.py +++ b/scripts/examples/python/XenAPI/XenAPI.py @@ -102,7 +102,12 @@ class UDSTransport(xmlrpclib.Transport): def add_extra_header(self, key, value): self._extra_headers += [ (key,value) ] def make_connection(self, host): - return UDSHTTPConnection(host) + # compatibility with parent xmlrpclib.Transport HTTP/1.1 support + if self._connection and host == self._connection[0]: + return self._connection[1] + + self._connection = host, UDSHTTPConnection(host) + return self._connection[1] def notimplemented(name, *args, **kwargs): raise NotImplementedError("XMLRPC proxies do not support python magic methods", name, *args, **kwargs) From db19b102226306ab9106608d4f4136edb73ea87e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 26 Mar 2024 18:27:35 +0000 Subject: [PATCH 16/65] CP-48623: avoid querying the API version, it is not used MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Old version of XenAPI.py used to look at the API version to implement a compatibility layer, but that code got dropped and the API version is now completely unused: df9b539d41 ("CA-35286: Remove forward compatability code from the python XenAPI module in favour of the compatability layer in xapi") Remove the unused argument, this will allow us to avoid making 4 additional API calls after every login. Signed-off-by: Edwin Török --- scripts/examples/python/XenAPI/XenAPI.py | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/scripts/examples/python/XenAPI/XenAPI.py b/scripts/examples/python/XenAPI/XenAPI.py index 75ffac8c769..24c618ed07f 100644 --- a/scripts/examples/python/XenAPI/XenAPI.py +++ b/scripts/examples/python/XenAPI/XenAPI.py @@ -216,11 +216,11 @@ def __getattr__(self, name): if name == 'handle': return self._session elif name == 'xenapi': - return _Dispatcher(self.API_version, self.xenapi_request, None) + return _Dispatcher(self.xenapi_request, None) elif name.startswith('login') or name.startswith('slave_local'): return lambda *params: self._login(name, params) elif name == 'logout': - return _Dispatcher(self.API_version, self.xenapi_request, "logout") + return _Dispatcher(self.xenapi_request, "logout") elif name.startswith('__') and name.endswith('__'): return lambda *args, **kwargs: notimplemented(name, args, kwargs) else: @@ -251,8 +251,7 @@ def _parse_result(result): # Based upon _Method from xmlrpclib. class _Dispatcher: - def __init__(self, API_version, send, name): - self.__API_version = API_version + def __init__(self, send, name): self.__send = send self.__name = name @@ -264,9 +263,9 @@ def __repr__(self): def __getattr__(self, name): if self.__name is None: - return _Dispatcher(self.__API_version, self.__send, name) + return _Dispatcher(self.__send, name) else: - return _Dispatcher(self.__API_version, self.__send, "%s.%s" % (self.__name, name)) + return _Dispatcher(self.__send, "%s.%s" % (self.__name, name)) def __call__(self, *args): return self.__send(self.__name, args) From 81fb164e14a35bb9e06b35fee9452b4e1a005af3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 26 Mar 2024 18:30:36 +0000 Subject: [PATCH 17/65] CP-48623: avoid 4 additional API calls after each SM login MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The API version is not used anymore, so remove the 4 additional queries it'd make. For backward compatibility retain the field as a cached property: should a client of this code want to access the API version, then it'll make the 4 queries at that time, and cache the result for the duration of the API object. Cached properties are writable, so the fallback that writes the API version to 1.1 should keep working too Signed-off-by: Edwin Török --- scripts/examples/python/XenAPI/XenAPI.py | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/scripts/examples/python/XenAPI/XenAPI.py b/scripts/examples/python/XenAPI/XenAPI.py index 24c618ed07f..957ead1935b 100644 --- a/scripts/examples/python/XenAPI/XenAPI.py +++ b/scripts/examples/python/XenAPI/XenAPI.py @@ -147,7 +147,7 @@ def __init__(self, uri, transport=None, encoding=None, verbose=0, self._session = None self.last_login_method = None self.last_login_params = None - self.API_version = API_VERSION_1_1 + self._API_version = API_VERSION_1_1 def xenapi_request(self, methodname, params): @@ -184,7 +184,12 @@ def _login(self, method, params): self._session = result self.last_login_method = method self.last_login_params = params - self.API_version = self._get_api_version() + + # This was initialized to 1.1 in the constructor. + # Now that we are logged in, the next time API_version() is run + # it can fetch the real version. + # However nothing in this script actually needs that, so don't call it immediately. + self._API_version = None except socket.error as e: # pytype false positive: there is a socket.errno in both py2 and py3 if e.errno == socket.errno.ETIMEDOUT: # pytype: disable=module-attr @@ -203,7 +208,7 @@ def _logout(self): self._session = None self.last_login_method = None self.last_login_params = None - self.API_version = API_VERSION_1_1 + self._API_version = API_VERSION_1_1 def _get_api_version(self): pool = self.xenapi.pool.get_all()[0] @@ -212,6 +217,12 @@ def _get_api_version(self): minor = self.xenapi.host.get_API_version_minor(host) return "%s.%s"%(major,minor) + @property + def API_version(self): + if not self._API_version: + self._API_version = self._get_api_version() + return self._API_version + def __getattr__(self, name): if name == 'handle': return self._session From 4c29a1e1b75e6880412fdecb1bb066992c650a1d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 15 Feb 2024 17:23:11 +0000 Subject: [PATCH 18/65] [maintenance]: disable implicit transitive deps MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This forces us to fully declare the dependencies of our code, and not rely on libraries that are brought in only as transitive dependencies of other libraries we happen to link to. E.g. if our module A depends on library X, which itself depends on library Y, then currently by linking X we also get Y linked and accessible from A directly. If code in module A uses both module X and Y *directly* then it needs to declare a dependency on both when implicit transitive deps are off or it gets a link failure (typically an error about a module or type being abstract). If the code in module A only uses module X then no change is needed (X can still use Y and the final executable will link both, it is just a question of what is visible and callable from A directly). This is especially useful when writing new code to get dependencies correct from the beginning. Signed-off-by: Edwin Török (cherry picked from commit 72034304327870c263485f9aa78c47d8023c6098) --- dune-project | 1 + ocaml/database/dune | 1 + ocaml/forkexecd/lib/dune | 1 + ocaml/libs/ezxenstore/core/dune | 6 ++++-- ocaml/libs/ezxenstore/lib/dune | 4 ++-- ocaml/libs/ezxenstore/lib_test/dune | 2 +- ocaml/libs/ezxenstore/watch/dune | 5 ++++- ocaml/libs/http-lib/dune | 3 +++ ocaml/libs/tracing/dune | 5 +++++ ocaml/libs/uuid/dune | 2 +- ocaml/libs/vhd/cli/dune | 2 +- ocaml/libs/vhd/vhd_format/dune | 2 +- ocaml/libs/vhd/vhd_format_lwt/dune | 2 +- ocaml/libs/xapi-inventory/lib/dune | 2 +- ocaml/libs/xapi-rrd/lib/dune | 1 + ocaml/libs/xapi-rrd/lib_test/dune | 2 ++ ocaml/message-switch/async/dune | 1 + ocaml/message-switch/core_test/async/dune | 2 ++ ocaml/squeezed/src/dune | 1 + ocaml/tests/alerts/dune | 2 ++ ocaml/tests/dune | 18 ++++++++++++++---- ocaml/xapi-cli-server/dune | 1 + ocaml/xapi-client/dune | 2 +- ocaml/xapi-guard/lib/dune | 17 +++++++++++++++++ ocaml/xapi-guard/src/dune | 1 + ocaml/xapi-guard/test/dune | 2 ++ ocaml/xapi-idl/guard/varstored/dune | 2 +- ocaml/xapi-idl/lib/dune | 1 + ocaml/xapi-idl/lib_test/dune | 4 +++- ocaml/xapi-storage-script/dune | 1 - ocaml/xapi/dune | 7 +++++-- ocaml/xcp-rrdd/bin/rrdd/dune | 2 ++ ocaml/xcp-rrdd/bin/rrdp-iostat/dune | 1 + ocaml/xe-cli/dune | 1 + ocaml/xen-api-client/async/dune | 2 ++ ocaml/xenopsd/dbgring/dune | 1 + ocaml/xenopsd/lib/dune | 1 + ocaml/xenopsd/pvs/dune | 2 +- ocaml/xenopsd/xc/dune | 1 + ocaml/xs-trace/dune | 2 ++ ocaml/xxhash/lib/dune | 1 + 41 files changed, 95 insertions(+), 22 deletions(-) diff --git a/dune-project b/dune-project index 747fc62b133..177eeeb7a79 100644 --- a/dune-project +++ b/dune-project @@ -1,6 +1,7 @@ (lang dune 2.0) (formatting (enabled_for ocaml)) +(implicit_transitive_deps false) (generate_opam_files true) (source (github xapi-project/xen-api)) diff --git a/ocaml/database/dune b/ocaml/database/dune index 0b0c71425ff..9d5f1fac7ef 100644 --- a/ocaml/database/dune +++ b/ocaml/database/dune @@ -40,6 +40,7 @@ xapi-datamodel xapi-log (re_export xapi-schema) + xapi-idl.updates xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std diff --git a/ocaml/forkexecd/lib/dune b/ocaml/forkexecd/lib/dune index 3ed1d4eb891..2830cd13937 100644 --- a/ocaml/forkexecd/lib/dune +++ b/ocaml/forkexecd/lib/dune @@ -12,6 +12,7 @@ xapi-log xapi-stdext-pervasives xapi-stdext-unix + rpclib.xml ) (preprocess (pps ppx_deriving_rpc))) diff --git a/ocaml/libs/ezxenstore/core/dune b/ocaml/libs/ezxenstore/core/dune index 2eabd6bea12..2b101fc43b3 100644 --- a/ocaml/libs/ezxenstore/core/dune +++ b/ocaml/libs/ezxenstore/core/dune @@ -7,6 +7,8 @@ logs threads uuidm - xenstore_transport - xenstore.unix) + (re_export xenstore) + (re_export xenstore_transport) + threads.posix + (re_export xenstore.unix)) ) diff --git a/ocaml/libs/ezxenstore/lib/dune b/ocaml/libs/ezxenstore/lib/dune index 65da96cc42b..874bd7e6e7f 100644 --- a/ocaml/libs/ezxenstore/lib/dune +++ b/ocaml/libs/ezxenstore/lib/dune @@ -3,7 +3,7 @@ (public_name ezxenstore) (wrapped false) (libraries - ezxenstore_core - ezxenstore_watch + (re_export ezxenstore_core) + (re_export ezxenstore_watch) ) ) diff --git a/ocaml/libs/ezxenstore/lib_test/dune b/ocaml/libs/ezxenstore/lib_test/dune index 01280a545ca..da843bf3b11 100644 --- a/ocaml/libs/ezxenstore/lib_test/dune +++ b/ocaml/libs/ezxenstore/lib_test/dune @@ -2,5 +2,5 @@ (name main) (package ezxenstore) (deps main.exe) - (libraries cmdliner ezxenstore xenstore_transport) + (libraries cmdliner ezxenstore xenstore_transport xenstore xenstore.unix) ) diff --git a/ocaml/libs/ezxenstore/watch/dune b/ocaml/libs/ezxenstore/watch/dune index 17e081a37ee..dfd2f3020cb 100644 --- a/ocaml/libs/ezxenstore/watch/dune +++ b/ocaml/libs/ezxenstore/watch/dune @@ -4,5 +4,8 @@ (wrapped false) (libraries ezxenstore_core - xenctrl) + xenctrl + uuidm + threads.posix + ) ) diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index dfc10dccb15..be0043e519a 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -8,6 +8,7 @@ (libraries astring base64 + fmt ipaddr mtime mtime.clock.os @@ -39,6 +40,7 @@ (libraries astring http_lib + ipaddr polly threads.posix xapi-log @@ -55,6 +57,7 @@ (libraries alcotest dune-build-info + fmt http_lib ) ) diff --git a/ocaml/libs/tracing/dune b/ocaml/libs/tracing/dune index 05a0ba27fda..bd2d8fd768b 100644 --- a/ocaml/libs/tracing/dune +++ b/ocaml/libs/tracing/dune @@ -6,8 +6,13 @@ cohttp-posix ptime ptime.clock.os + re rpclib.core rpclib.json + result + rresult + uri + threads.posix xapi-log xapi-open-uri xapi-stdext-threads diff --git a/ocaml/libs/uuid/dune b/ocaml/libs/uuid/dune index d9266c021f8..5f7c5c25b95 100644 --- a/ocaml/libs/uuid/dune +++ b/ocaml/libs/uuid/dune @@ -3,7 +3,7 @@ (public_name uuid) (modules uuidx) (libraries - unix uuidm + unix (re_export uuidm) ) (wrapped false) ) diff --git a/ocaml/libs/vhd/cli/dune b/ocaml/libs/vhd/cli/dune index 303f72e0d91..f871b3d2f8c 100644 --- a/ocaml/libs/vhd/cli/dune +++ b/ocaml/libs/vhd/cli/dune @@ -2,4 +2,4 @@ (name disk_to_ocaml) (public_name disk_to_ocaml) (package vhd-format-lwt) - (libraries disk lwt)) + (libraries disk lwt lwt.unix)) diff --git a/ocaml/libs/vhd/vhd_format/dune b/ocaml/libs/vhd/vhd_format/dune index f2fd63b464f..5478cb41a48 100644 --- a/ocaml/libs/vhd/vhd_format/dune +++ b/ocaml/libs/vhd/vhd_format/dune @@ -2,5 +2,5 @@ (name vhd_format) (public_name vhd-format) (flags :standard -w -32-34-37) - (libraries stdlib-shims cstruct io-page rresult uuidm) + (libraries stdlib-shims (re_export bigarray-compat) cstruct io-page rresult uuidm) (preprocess (pps ppx_cstruct))) diff --git a/ocaml/libs/vhd/vhd_format_lwt/dune b/ocaml/libs/vhd/vhd_format_lwt/dune index 9faf463f409..06f37079439 100644 --- a/ocaml/libs/vhd/vhd_format_lwt/dune +++ b/ocaml/libs/vhd/vhd_format_lwt/dune @@ -1,7 +1,7 @@ (library (name vhd_format_lwt) (public_name vhd-format-lwt) - (libraries cstruct lwt lwt.unix mirage-block vhd-format) + (libraries bigarray-compat cstruct-lwt cstruct lwt lwt.unix mirage-block vhd-format rresult) (foreign_stubs (language c) (names blkgetsize64_stubs lseek64_stubs odirect_stubs))) diff --git a/ocaml/libs/xapi-inventory/lib/dune b/ocaml/libs/xapi-inventory/lib/dune index 7fb4aa7e40b..905b47bfceb 100644 --- a/ocaml/libs/xapi-inventory/lib/dune +++ b/ocaml/libs/xapi-inventory/lib/dune @@ -7,6 +7,6 @@ astring xapi-stdext-unix xapi-stdext-threads - threads + threads.posix ) ) diff --git a/ocaml/libs/xapi-rrd/lib/dune b/ocaml/libs/xapi-rrd/lib/dune index 00b4bedfc3d..2f90e3e2f45 100644 --- a/ocaml/libs/xapi-rrd/lib/dune +++ b/ocaml/libs/xapi-rrd/lib/dune @@ -6,6 +6,7 @@ (libraries bigarray rpclib.json + rpclib.core xmlm yojson ) diff --git a/ocaml/libs/xapi-rrd/lib_test/dune b/ocaml/libs/xapi-rrd/lib_test/dune index b565d445d49..7a66380a63e 100644 --- a/ocaml/libs/xapi-rrd/lib_test/dune +++ b/ocaml/libs/xapi-rrd/lib_test/dune @@ -9,6 +9,8 @@ unix xapi-rrd xapi-stdext-unix + rpclib.xml + xmlm ) ) diff --git a/ocaml/message-switch/async/dune b/ocaml/message-switch/async/dune index a0a1beb8c19..28ee31ecfa5 100644 --- a/ocaml/message-switch/async/dune +++ b/ocaml/message-switch/async/dune @@ -10,6 +10,7 @@ core core_unix core_kernel + core_unix.time_unix message-switch-core ) ) diff --git a/ocaml/message-switch/core_test/async/dune b/ocaml/message-switch/core_test/async/dune index 2891908317e..6e690c35e1d 100644 --- a/ocaml/message-switch/core_test/async/dune +++ b/ocaml/message-switch/core_test/async/dune @@ -13,6 +13,8 @@ cohttp-async core core_kernel + core_unix + core_unix.time_unix message-switch-async ) ) diff --git a/ocaml/squeezed/src/dune b/ocaml/squeezed/src/dune index cbdf62e39c8..c5d6683ad92 100644 --- a/ocaml/squeezed/src/dune +++ b/ocaml/squeezed/src/dune @@ -8,6 +8,7 @@ xapi-stdext-threads xapi-stdext-pervasives xapi-stdext-unix + xapi_version astring dune-build-info rpclib.core diff --git a/ocaml/tests/alerts/dune b/ocaml/tests/alerts/dune index 3e932d190f3..613f4077eaa 100644 --- a/ocaml/tests/alerts/dune +++ b/ocaml/tests/alerts/dune @@ -6,11 +6,13 @@ certificate_check daily_license_check dune-build-info + expiry_alert fmt xapi-consts xapi-log xapi-stdext-date xapi-types + uuid ) (action (run %{test} --color=always)) ) diff --git a/ocaml/tests/dune b/ocaml/tests/dune index 93bf4b66ddf..1379bcc8a78 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -17,6 +17,7 @@ dune-build-info fmt http_lib + httpsvr ipaddr mirage-crypto pam @@ -70,6 +71,7 @@ (libraries alcotest fmt + ptime result rpclib.core rpclib.json @@ -90,7 +92,9 @@ xapi-test-utils xapi-tracing xapi-types + xapi-stdext-date xapi-stdext-threads + xapi-stdext-unix xml-light2 yojson ) @@ -101,27 +105,33 @@ (modes exe) (package xapi) (modules test_storage_smapiv1_wrapper) -(libraries alcotest xapi_internal fmt)) +(libraries alcotest xapi_internal fmt xapi-idl.storage.interface xapi-idl.storage.interface.types)) (test (name test_storage_quicktest) (modes exe) (package xapi) (modules test_storage_quicktest) -(libraries xapi_internal crowbar)) +(libraries xapi_internal crowbar xapi-idl.storage.interface.types)) (test (name test_ref) (modes exe) (package xapi) (modules test_ref) -(libraries xapi_internal crowbar)) +(libraries + crowbar + fmt + uuidm + xapi-types + xapi_internal +)) (test (name test_observer) (package xapi) (modules test_observer) -(libraries alcotest tracing xapi_internal tests_common yojson)) +(libraries alcotest fmt tracing xapi_internal tests_common yojson log uri xapi-stdext-unix re ppx_deriving.runtime xapi-stdext-std)) (rule (alias runtest) diff --git a/ocaml/xapi-cli-server/dune b/ocaml/xapi-cli-server/dune index 6814d74fd56..b81c0c2e607 100644 --- a/ocaml/xapi-cli-server/dune +++ b/ocaml/xapi-cli-server/dune @@ -12,6 +12,7 @@ rresult sexplib sexplib0 + uri tar threads.posix xapi-backtrace diff --git a/ocaml/xapi-client/dune b/ocaml/xapi-client/dune index 9951eb6cfbc..d85c2af74af 100644 --- a/ocaml/xapi-client/dune +++ b/ocaml/xapi-client/dune @@ -15,7 +15,7 @@ (libraries mtime mtime.clock.os - rpclib.core + (re_export rpclib.core) xapi-consts xapi-log xapi-types diff --git a/ocaml/xapi-guard/lib/dune b/ocaml/xapi-guard/lib/dune index 052810ead5f..dd35baf40cb 100644 --- a/ocaml/xapi-guard/lib/dune +++ b/ocaml/xapi-guard/lib/dune @@ -6,13 +6,22 @@ cohttp-lwt cohttp-lwt-unix conduit-lwt-unix + fmt + log lwt lwt.unix + mtime + mtime.clock + mtime.clock.os result rpclib.core rpclib-lwt + rpclib.xml + uuidm + uri xapi_guard xapi-idl.xen.interface + xapi-idl.guard.varstored xapi-log xapi-types xen-api-client-lwt @@ -23,10 +32,18 @@ (modules dorpc types disk_cache lwt_bounded_stream) (libraries rpclib.core + fmt inotify inotify.lwt + rresult + result + log lwt lwt.unix + mtime + mtime.clock + mtime.clock.os + uuidm uri xapi-backtrace xapi-consts diff --git a/ocaml/xapi-guard/src/dune b/ocaml/xapi-guard/src/dune index baac1d24101..ac7a6665c1a 100644 --- a/ocaml/xapi-guard/src/dune +++ b/ocaml/xapi-guard/src/dune @@ -20,6 +20,7 @@ xapi-idl.guard.privileged xapi-log xapi-types + xapi_version xen-api-client-lwt) (preprocess (pps ppx_deriving_rpc))) diff --git a/ocaml/xapi-guard/test/dune b/ocaml/xapi-guard/test/dune index e082a47a690..88e9d6887d9 100644 --- a/ocaml/xapi-guard/test/dune +++ b/ocaml/xapi-guard/test/dune @@ -15,6 +15,7 @@ xapi_guard_server xapi-log xapi-types + xapi_version xen-api-client-lwt) (package varstored-guard) ) @@ -23,6 +24,7 @@ (name cache_test) (modules cache_test) (libraries + fmt logs logs.fmt logs.lwt diff --git a/ocaml/xapi-idl/guard/varstored/dune b/ocaml/xapi-idl/guard/varstored/dune index 0e6bd85b627..a54af22988a 100644 --- a/ocaml/xapi-idl/guard/varstored/dune +++ b/ocaml/xapi-idl/guard/varstored/dune @@ -3,7 +3,7 @@ (public_name xapi-idl.guard.varstored) (modules (:standard \ varstored_cli)) (libraries - rpclib.core + (re_export rpclib.core) threads xapi-idl.xen xapi-idl.xen.interface diff --git a/ocaml/xapi-idl/lib/dune b/ocaml/xapi-idl/lib/dune index 91c72783c42..c8feec1ff1a 100644 --- a/ocaml/xapi-idl/lib/dune +++ b/ocaml/xapi-idl/lib/dune @@ -51,6 +51,7 @@ rpclib.json sexplib sexplib0 + tracing threads.posix xapi-backtrace xapi-idl diff --git a/ocaml/xapi-idl/lib_test/dune b/ocaml/xapi-idl/lib_test/dune index de6906fdfcd..57c8c95e592 100644 --- a/ocaml/xapi-idl/lib_test/dune +++ b/ocaml/xapi-idl/lib_test/dune @@ -2,7 +2,7 @@ (name test_lib) (modules idl_test_common) (libraries - alcotest xapi-idl) + (re_export alcotest) xapi-idl (re_export rpclib.core) rpclib.json rpclib.xml result) (wrapped false) ) @@ -26,6 +26,7 @@ (deps (source_tree test_data)) (libraries alcotest + cohttp_posix fmt result rpclib.core @@ -34,6 +35,7 @@ rpclib.xml test_lib threads.posix + xapi-idl xapi-idl.cluster xapi-idl.rrd xapi-idl.memory diff --git a/ocaml/xapi-storage-script/dune b/ocaml/xapi-storage-script/dune index f1c02f5c837..b7d62f7e32a 100644 --- a/ocaml/xapi-storage-script/dune +++ b/ocaml/xapi-storage-script/dune @@ -10,7 +10,6 @@ core core_unix core_unix.time_unix - core_kernel dune-build-info message-switch-async message-switch-unix diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 45d5e67aaf9..9bdabb84b26 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -64,6 +64,7 @@ cstruct base64 cohttp + cohttp_posix domain-name ezxenstore.core fmt @@ -72,6 +73,7 @@ gzip hex http_lib + httpsvr ipaddr message-switch-core message-switch-unix @@ -83,6 +85,7 @@ pciutil pci ptime + ptime.clock.os rpclib.core rpclib.json rpclib.xml @@ -109,7 +112,7 @@ x509 xapi_aux xapi-backtrace - xapi-consts + (re_export xapi-consts) xapi-consts.xapi_version xapi-client xapi-cli-protocol @@ -136,7 +139,7 @@ xapi-log xapi-open-uri xapi-rrd - xapi-types + (re_export xapi-types) xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index 42b0823d9c2..1dbab9c0ea6 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/dune +++ b/ocaml/xcp-rrdd/bin/rrdd/dune @@ -31,6 +31,7 @@ xapi-stdext-threads xapi-stdext-unix xmlm + yojson ) (preprocess (pps ppx_deriving_rpc)) ) @@ -48,6 +49,7 @@ ezxenstore.watch forkexec http_lib + httpsvr inotify rpclib.core rpclib.json diff --git a/ocaml/xcp-rrdd/bin/rrdp-iostat/dune b/ocaml/xcp-rrdd/bin/rrdp-iostat/dune index 4ff5ab43453..4c6dd005206 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-iostat/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-iostat/dune @@ -20,6 +20,7 @@ xapi-idl.rrd xapi-log xapi-rrd + xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix diff --git a/ocaml/xe-cli/dune b/ocaml/xe-cli/dune index dede643723b..7d0429650d6 100644 --- a/ocaml/xe-cli/dune +++ b/ocaml/xe-cli/dune @@ -10,6 +10,7 @@ safe-resources stunnel threads + yojson xapi-backtrace xapi-cli-protocol xapi-stdext-pervasives diff --git a/ocaml/xen-api-client/async/dune b/ocaml/xen-api-client/async/dune index 406f2cc8cf9..a3ed8b645b7 100644 --- a/ocaml/xen-api-client/async/dune +++ b/ocaml/xen-api-client/async/dune @@ -8,6 +8,8 @@ base cohttp core + core_unix + core_unix.time_unix core_kernel rpclib.core rpclib.json diff --git a/ocaml/xenopsd/dbgring/dune b/ocaml/xenopsd/dbgring/dune index 7fa6db8c16d..0f79c13e2f0 100644 --- a/ocaml/xenopsd/dbgring/dune +++ b/ocaml/xenopsd/dbgring/dune @@ -6,6 +6,7 @@ dune-build-info xapi-xenopsd xenctrl + xenmmap xenstore xenstore.unix xenstore_transport diff --git a/ocaml/xenopsd/lib/dune b/ocaml/xenopsd/lib/dune index e389949c281..94fd8f4c10c 100644 --- a/ocaml/xenopsd/lib/dune +++ b/ocaml/xenopsd/lib/dune @@ -6,6 +6,7 @@ astring c_stubs cohttp + cohttp_posix fd-send-recv fmt forkexec diff --git a/ocaml/xenopsd/pvs/dune b/ocaml/xenopsd/pvs/dune index 6b915db2255..d8b113392c9 100644 --- a/ocaml/xenopsd/pvs/dune +++ b/ocaml/xenopsd/pvs/dune @@ -2,6 +2,6 @@ (name pvs_proxy_setup) (public_name pvs-proxy-ovs-setup) (package xapi-xenopsd-xc) - (libraries ezxenstore.core bos xapi-consts.xapi_version xapi-idl cmdliner) + (libraries ezxenstore.core bos xapi-consts.xapi_version xapi-idl cmdliner log rresult) ) diff --git a/ocaml/xenopsd/xc/dune b/ocaml/xenopsd/xc/dune index 032d99d16c0..7fedcaa3207 100644 --- a/ocaml/xenopsd/xc/dune +++ b/ocaml/xenopsd/xc/dune @@ -27,6 +27,7 @@ sexplib0 qmp threads.posix + uri uuid uuidm xapi-backtrace diff --git a/ocaml/xs-trace/dune b/ocaml/xs-trace/dune index 3a3e04b6e83..7ba26342471 100644 --- a/ocaml/xs-trace/dune +++ b/ocaml/xs-trace/dune @@ -4,7 +4,9 @@ (public_name xs-trace) (package xapi) (libraries + uri tracing xapi-stdext-unix + zstd ) ) diff --git a/ocaml/xxhash/lib/dune b/ocaml/xxhash/lib/dune index 1923c3d6510..70b43c59192 100644 --- a/ocaml/xxhash/lib/dune +++ b/ocaml/xxhash/lib/dune @@ -15,6 +15,7 @@ (wrapped false) (libraries ctypes + ctypes.stubs integers xxhash_bindings xapi-stdext-pervasives From 027874268977c8bcdfa72b92afa54ada75b49d53 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 29 Jan 2024 17:45:42 +0000 Subject: [PATCH 19/65] fix(dune): avoid "module unavailable" errors when running dune build @check MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Bytecode builds for `http_lib` are disabled due to '(modes best)', and that means that anything that depends on it must have it disabled too to avoid this warning. Avoids these kinds of warnings: ``` File "_none_", line 1: Error: Module `Buf_io' is unavailable (required by `Http_svr') ``` Signed-off-by: Edwin Török --- ocaml/database/dune | 1 + ocaml/libs/http-lib/dune | 2 ++ ocaml/tests/common/dune | 1 + ocaml/tests/dune | 3 ++- ocaml/xapi/dune | 1 + 5 files changed, 7 insertions(+), 1 deletion(-) diff --git a/ocaml/database/dune b/ocaml/database/dune index 9d5f1fac7ef..49bea1acfa9 100644 --- a/ocaml/database/dune +++ b/ocaml/database/dune @@ -21,6 +21,7 @@ (library (name xapi_database) + (modes best) (modules (:standard \ database_server_main db_cache_test db_names db_exn block_device_io string_marshall_helper string_unmarshall_helper schema diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index be0043e519a..dae6e86e669 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -36,6 +36,7 @@ (library (name httpsvr) (wrapped false) + (modes best) (modules http_svr http_proxy server_io) (libraries astring @@ -53,6 +54,7 @@ (tests (names http_test radix_tree_test) (package http-lib) + (modes (best exe)) (modules http_test radix_tree_test) (libraries alcotest diff --git a/ocaml/tests/common/dune b/ocaml/tests/common/dune index fdc6fbd9a6c..c578f5f9785 100644 --- a/ocaml/tests/common/dune +++ b/ocaml/tests/common/dune @@ -1,6 +1,7 @@ (library (name tests_common) (modules :standard) + (modes best) (wrapped false) (libraries alcotest diff --git a/ocaml/tests/dune b/ocaml/tests/dune index 1379bcc8a78..d1f8df151af 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -1,6 +1,6 @@ (test (name suite_alcotest) - (modes exe) + (modes (best exe)) (package xapi) (modules (:standard \ test_daemon_manager test_vdi_cbt test_event test_clustering @@ -130,6 +130,7 @@ (test (name test_observer) (package xapi) +(modes (best exe)) (modules test_observer) (libraries alcotest fmt tracing xapi_internal tests_common yojson log uri xapi-stdext-unix re ppx_deriving.runtime xapi-stdext-std)) diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 9bdabb84b26..76ce076be7a 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -57,6 +57,7 @@ (library (name xapi_internal) (wrapped false) + (modes best) (modules (:standard \ xapi_main)) (libraries angstrom From 514f13659cde44a7c2e73f923a180043a8c053b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 13 Dec 2023 13:18:43 +0000 Subject: [PATCH 20/65] CP-47001: [xapi-fdcaps]: dune plumbing for new library MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This will be a new library that will provide a more type-safe interface to file descriptor operations. Useful on its own, but also for testing stdext. Minimal dependencies, only Unix (and Alcotest for testing). Signed-off-by: Edwin Török --- dune-project | 10 ++++++++ lib/xapi-fdcaps/dune | 7 ++++++ lib/xapi-fdcaps/test/dune | 5 ++++ lib/xapi-fdcaps/test/test_xapi_fdcaps.ml | 0 lib/xapi-fdcaps/test/test_xapi_fdcaps.mli | 0 xapi-fdcaps.opam | 29 +++++++++++++++++++++++ 6 files changed, 51 insertions(+) create mode 100644 lib/xapi-fdcaps/dune create mode 100644 lib/xapi-fdcaps/test/dune create mode 100644 lib/xapi-fdcaps/test/test_xapi_fdcaps.ml create mode 100644 lib/xapi-fdcaps/test/test_xapi_fdcaps.mli create mode 100644 xapi-fdcaps.opam diff --git a/dune-project b/dune-project index 177eeeb7a79..49bae3dc81a 100644 --- a/dune-project +++ b/dune-project @@ -358,3 +358,13 @@ (odoc :with-doc) ) ) + +(package + (name xapi-fdcaps) + (synopsis "Static capabilities for file descriptor operations") + (depends + (alcotest :with-test) + base-unix + fmt + ) +) diff --git a/lib/xapi-fdcaps/dune b/lib/xapi-fdcaps/dune new file mode 100644 index 00000000000..1b0f0734da5 --- /dev/null +++ b/lib/xapi-fdcaps/dune @@ -0,0 +1,7 @@ +; Keep dependencies minimal here, ideally just OCaml stdlib +; This will be used to test other functions in stdext, so it should not itself rely on other stdext libs! +(library + (public_name xapi-fdcaps) + (name xapi_fdcaps) + (libraries unix) +) diff --git a/lib/xapi-fdcaps/test/dune b/lib/xapi-fdcaps/test/dune new file mode 100644 index 00000000000..8f304ecc5dd --- /dev/null +++ b/lib/xapi-fdcaps/test/dune @@ -0,0 +1,5 @@ +(test + (package xapi-fdcaps) + (name test_xapi_fdcaps) + (libraries xapi_fdcaps alcotest) +) diff --git a/lib/xapi-fdcaps/test/test_xapi_fdcaps.ml b/lib/xapi-fdcaps/test/test_xapi_fdcaps.ml new file mode 100644 index 00000000000..e69de29bb2d diff --git a/lib/xapi-fdcaps/test/test_xapi_fdcaps.mli b/lib/xapi-fdcaps/test/test_xapi_fdcaps.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/xapi-fdcaps.opam b/xapi-fdcaps.opam new file mode 100644 index 00000000000..6c5d05e2465 --- /dev/null +++ b/xapi-fdcaps.opam @@ -0,0 +1,29 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Static capabilities for file descriptor operations" +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" +depends: [ + "dune" {>= "2.0"} + "alcotest" {with-test} + "base-unix" + "fmt" +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" From 4c2682476f6853e2cc0a6a9436e4f193922ac227 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 13 Dec 2023 13:24:18 +0000 Subject: [PATCH 21/65] CP-47001: [xapi-fd-test]: dune plumbing for a new test framework MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This will be a test framework providing QCheck generators and properties for testing file descriptor operations. It will try to generate: * different kinds of file descriptors * actual data written/read on the other end of pipes and socket pairs * different speeds and delays on the other end to find buffering bugs * file descriptors that are >1024 to find bugs with select Signed-off-by: Edwin Török --- dune-project | 14 ++ lib/xapi-fd-test/dune | 6 + lib/xapi-fd-test/test/dune | 6 + .../test/test_xapi_fd_test.ml} | 0 .../test/test_xapi_fd_test.mli} | 0 lib/xapi-fdcaps/dune | 2 +- lib/xapi-fdcaps/safefd.ml | 185 ++++++++++++++++++ lib/xapi-fdcaps/safefd.mli | 115 +++++++++++ lib/xapi-fdcaps/test/dune | 6 +- lib/xapi-fdcaps/test/test_safefd.ml | 123 ++++++++++++ lib/xapi-fdcaps/test/test_safefd.mli | 0 xapi-fd-test.opam | 32 +++ xapi-stdext.opam | 1 + 13 files changed, 486 insertions(+), 4 deletions(-) create mode 100644 lib/xapi-fd-test/dune create mode 100644 lib/xapi-fd-test/test/dune rename lib/{xapi-fdcaps/test/test_xapi_fdcaps.ml => xapi-fd-test/test/test_xapi_fd_test.ml} (100%) rename lib/{xapi-fdcaps/test/test_xapi_fdcaps.mli => xapi-fd-test/test/test_xapi_fd_test.mli} (100%) create mode 100644 lib/xapi-fdcaps/safefd.ml create mode 100644 lib/xapi-fdcaps/safefd.mli create mode 100644 lib/xapi-fdcaps/test/test_safefd.ml create mode 100644 lib/xapi-fdcaps/test/test_safefd.mli create mode 100644 xapi-fd-test.opam diff --git a/dune-project b/dune-project index 49bae3dc81a..26944770d8d 100644 --- a/dune-project +++ b/dune-project @@ -275,6 +275,7 @@ (xapi-stdext-threads (= :version)) (xapi-stdext-unix (= :version)) (xapi-stdext-zerocheck (= :version)) + (xapi-fdcaps (= :version)) ) ) @@ -368,3 +369,16 @@ fmt ) ) + +(package + (name xapi-fd-test) + (synopsis "Test framework for file descriptor operations") + (depends + (alcotest :with-test) + base-unix + fmt + (mtime (>= 2.0.0)) + logs + (qcheck-core (>= 0.21.2)) + ) +) diff --git a/lib/xapi-fd-test/dune b/lib/xapi-fd-test/dune new file mode 100644 index 00000000000..b2a0d2fe007 --- /dev/null +++ b/lib/xapi-fd-test/dune @@ -0,0 +1,6 @@ +; This will be used to test stdext itself, so do not depend on stdext here +(library + (public_name xapi-fd-test) + (name xapi_fd_test) + (libraries xapi-fdcaps unix qcheck-core logs fmt mtime mtime.clock.os) +) diff --git a/lib/xapi-fd-test/test/dune b/lib/xapi-fd-test/test/dune new file mode 100644 index 00000000000..10b800a0290 --- /dev/null +++ b/lib/xapi-fd-test/test/dune @@ -0,0 +1,6 @@ +; This is a test framework, but we still need to test it +(test + (package xapi-fd-test) + (name test_xapi_fd_test) + (libraries xapi_fd_test alcotest) +) diff --git a/lib/xapi-fdcaps/test/test_xapi_fdcaps.ml b/lib/xapi-fd-test/test/test_xapi_fd_test.ml similarity index 100% rename from lib/xapi-fdcaps/test/test_xapi_fdcaps.ml rename to lib/xapi-fd-test/test/test_xapi_fd_test.ml diff --git a/lib/xapi-fdcaps/test/test_xapi_fdcaps.mli b/lib/xapi-fd-test/test/test_xapi_fd_test.mli similarity index 100% rename from lib/xapi-fdcaps/test/test_xapi_fdcaps.mli rename to lib/xapi-fd-test/test/test_xapi_fd_test.mli diff --git a/lib/xapi-fdcaps/dune b/lib/xapi-fdcaps/dune index 1b0f0734da5..6daf1416607 100644 --- a/lib/xapi-fdcaps/dune +++ b/lib/xapi-fdcaps/dune @@ -3,5 +3,5 @@ (library (public_name xapi-fdcaps) (name xapi_fdcaps) - (libraries unix) + (libraries fmt unix) ) diff --git a/lib/xapi-fdcaps/safefd.ml b/lib/xapi-fdcaps/safefd.ml new file mode 100644 index 00000000000..1d0d3a92b6d --- /dev/null +++ b/lib/xapi-fdcaps/safefd.ml @@ -0,0 +1,185 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * 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 string_of_file_kind = + let open Unix in + function + | S_REG -> + "regular file" + | S_BLK -> + "block device" + | S_CHR -> + "character device" + | S_DIR -> + "directory" + | S_LNK -> + "symlink" + | S_FIFO -> + "FIFO/pipe" + | S_SOCK -> + "socket" + +let pp_kind = Fmt.of_to_string string_of_file_kind + +module Identity = struct + type t = { + kind: Unix.file_kind + ; device: int + ; inode: int (* should be int64? *) + } + + let of_fd fd = + let open Unix.LargeFile in + let stat = fstat fd in + {kind= stat.st_kind; device= stat.st_dev; inode= stat.st_ino} + + let same a b = a.kind = b.kind && a.device = b.device && a.inode = b.inode + + let pp = + Fmt.( + record + ~sep:Fmt.(any ", ") + [ + field "kind" (fun t -> t.kind) pp_kind + ; field "device" (fun t -> t.device) int + ; field "inode" (fun t -> t.inode) int + ] + ) +end + +type t = { + fd: (Unix.file_descr, Printexc.raw_backtrace) result Atomic.t + ; opened_at: Printexc.raw_backtrace + ; original: Identity.t +} + +let pp ppf t = + (* print only essential info that fits on a single line *) + Fmt.pf ppf "@[FD %a: %a@]" + (Fmt.result ~ok:Fmt.(any "open") ~error:Fmt.(any "closed")) + (Atomic.get t.fd) Identity.pp t.original + +let pp_closed ppf bt = + let exception Closed_at in + Fmt.exn_backtrace ppf (Closed_at, bt) + +let pp_opened_at ppf bt = + let exception Opened_at in + Fmt.exn_backtrace ppf (Opened_at, bt) + +let dump = + Fmt.( + Dump.( + record + [ + field "fd" + (fun t -> Atomic.get t.fd) + Fmt.Dump.(result ~ok:(any "opened") ~error:pp_closed) + ; field "opened_at" (fun t -> t.opened_at) pp_opened_at + ; field "original" (fun t -> t.original) Identity.pp + ] + ) + ) + +let location () = + (* We could raise and immediately catch an exception but that will have a very short stacktrace, + [get_callstack] is better. + *) + Printexc.get_callstack 1000 + +let nop = + { + fd= Atomic.make (Error (location ())) + ; opened_at= Printexc.get_callstack 0 + ; original= Identity.of_fd Unix.stdin + } + +let check_exn ~caller t fd = + let actual = Identity.of_fd fd in + if not (Identity.same t.original actual) then ( + let msg = + Format.asprintf "@[File descriptor mismatch: %a <> %a@]" Identity.pp + t.original Identity.pp actual + in + (* invalidate FD so nothing else uses it anymore, we know it points to elsewhere now *) + Atomic.set t.fd (Error (location ())) ; + (* raise backtrace with original open location *) + Printexc.raise_with_backtrace + Unix.(Unix_error (EBADF, caller, msg)) + t.opened_at + ) + +let close_common_exn t = + let closed = Error (location ()) in + (* ensure noone else can access it, before we close it *) + match Atomic.exchange t.fd closed with + | Error _ as e -> + (* put back the original backtrace *) + Atomic.set t.fd e ; e + | Ok fd -> + check_exn ~caller:"close_common_exn" t fd ; + Ok (Unix.close fd) + +let close_exn t = + match close_common_exn t with + | Error bt -> + let ebadf = Unix.(Unix_error (EBADF, "close_exn", "")) in + (* raise with previous close's backtrace *) + Printexc.raise_with_backtrace ebadf bt + | Ok () -> + () + +let idempotent_close_exn t = + let (_ : _ result) = close_common_exn t in + () + +let leak_count = Atomic.make 0 + +let leaked () = Atomic.get leak_count + +let finalise t = + match Atomic.get t.fd with + | Ok _ -> + Atomic.incr leak_count ; + if Sys.runtime_warnings_enabled () then + Format.eprintf "@.Warning: leaked file descriptor detected:@,%a@]@." + pp_opened_at t.opened_at + | Error _ -> + () + +let of_file_descr fd = + let v = + { + fd= Atomic.make (Ok fd) + ; opened_at= location () + ; original= Identity.of_fd fd + } + in + Gc.finalise finalise v ; v + +let unsafe_to_file_descr_exn t = + match Atomic.get t.fd with + | Ok fd -> + fd + | Error bt -> + let ebadf = Unix.(Unix_error (EBADF, "unsafe_to_file_descr_exn", "")) in + Printexc.raise_with_backtrace ebadf bt + +let with_fd_exn t f = + let fd = unsafe_to_file_descr_exn t in + let r = f fd in + check_exn ~caller:"with_fd_exn" t fd ; + r + +let setup () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore diff --git a/lib/xapi-fdcaps/safefd.mli b/lib/xapi-fdcaps/safefd.mli new file mode 100644 index 00000000000..710d1a5ee47 --- /dev/null +++ b/lib/xapi-fdcaps/safefd.mli @@ -0,0 +1,115 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * 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. + *) + +(** Safe wrapper around {!type:Unix.file_descr} that detects "use after close" errors + + {!type:Unix.file_descr} is just an integer and cannot track whether {!val:Unix.close} has been called. + File descriptor numbers are reused by newly open file descriptors, so using a file descriptor that is already closed + doesn't always result in a visible error, but is nevertheless a programming error that should be detected. + + E.g. the following sequence would write data to the wrong file ([fd2] instead of [fd1]), + and raise no errors at runtime: + {[ + let fd1 = Unix.openfile "fd1" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 in + Unix.close fd1; + let fd2 = Unix.openfile "fd2" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 in + Unix.write_substring fd1 "test" 0 4; + Unix.close fd2 + ]} + + This module introduces a lightweight wrapper around {!type:Unix.file_descr}, + and detects attempts to use a file descriptor after it has been closed: + {[ + open Xapi_fdcaps + + let fd1 = Unix.openfile "fd1" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 |> Safefd.of_file_descr in + Safefd.close_exn fd1; + let fd2 = Unix.openfile "fd2" [Unix.O_WRONLY; Unix.O_CREAT] 0o700 |> Safefd.of_file_descr in + Safefd.with_fd_exn fd1 (fun fd -> Unix.write_substring fd "test" 0 4); + ]} + + It raises {!val:Unix.EBADF}: + {[ Exception: Unix.Unix_error(Unix.EBADF, "unsafe_to_file_descr_exn", "") ]} + + The callback of {!val:with_fd_exn} has access to the underlying {!type:Unix.file_descr}, + and may accidentally call {!val:Unix.close}. + + To detect that {!val:with_fd_exn} calls {!val:Unix.LargeFile.fstat} to check that the file descriptor + remained the "same" after the call. + File descriptors are considered to be the same if their kind, device and inode remain unchanged + (obviously other parts of the stat structure such as timestamps and size may change between calls). + This doesn't detect all bugs, but detects most common bugs + (hardlinked files will still show up as the same but the file position may have been different, which is not checked). + + The extra system calls have an overhead so an unsafe version is available, but not documented (it should only be used internally by other modules in {!mod:Xapi_fdcaps}). + + With the safe wrapper we also have a non-integer type that we can attach a finaliser too. + This is used to detect and close leaked file descriptors safely (by checking that it is "the same" that we originally opened). +*) + +(** a file descriptor that is safe against double close *) +type t + +val of_file_descr : Unix.file_descr -> t +(** [of_file_descr fd] wraps [fd]. + + *) + +val idempotent_close_exn : t -> unit +(** [idempotent_close_exn t] closes [t], and doesn't raise an exception if [t] is already closed. + Other exceptions may still escape (e.g. if the underlying [close] has reported an [ENOSPC] or [EIO] error). +*) + +val close_exn : t -> unit +(** [close_exn t] closes t and raises an exception if [t] is already closed. + + @raises Unix_error(Unix.EBADF,_,_) if [t] is already closed. +*) + +val with_fd_exn : t -> (Unix.file_descr -> 'a) -> 'a +(** [with_fd_exn t f] calls [f fd] with the underlying file descriptor. + [f] must not close [fd]. + + @raises Unix_error(Unix.EBADF,_,_) if the file descriptor is not the same after [f] terminates. +*) + +val nop : t +(** [nop] is a file descriptor that is always closed and no operations are valid on it. *) + +val pp_kind : Format.formatter -> Unix.file_kind -> unit +(** [pp_kind formatter kind] pretty prints [kind] on [formatter]. *) + +val pp : Format.formatter -> t -> unit +(** [pp formatter t] pretty prints information about [t] on [formatter]. *) + +val dump : Format.formatter -> t -> unit +(** [dump formatter t] prints all the debug information available about [t] on [formatter] *) + +(**/**) + +(* For small wrappers and high frequency calls like [read] and [write]. + Should only be used by the wrappers in {!mod:Operations}, hence hidden from the documentation. +*) + +val setup : unit -> unit +(** [setup ()] sets up a [SIGPIPE] handler. + With the handler set up a broken pipe will result in a [Unix.EPIPE] exception instead of killing the program *) + +val leaked : unit -> int +(** [leaked ()] is a count of leaked file descriptors detected. + Run [Gc.full_major ()] to get an accurate count before calling this *) + +(**/**) + +val unsafe_to_file_descr_exn : t -> Unix.file_descr diff --git a/lib/xapi-fdcaps/test/dune b/lib/xapi-fdcaps/test/dune index 8f304ecc5dd..b20b371663d 100644 --- a/lib/xapi-fdcaps/test/dune +++ b/lib/xapi-fdcaps/test/dune @@ -1,5 +1,5 @@ -(test +(tests (package xapi-fdcaps) - (name test_xapi_fdcaps) - (libraries xapi_fdcaps alcotest) + (names test_safefd) + (libraries xapi_fdcaps alcotest fmt) ) diff --git a/lib/xapi-fdcaps/test/test_safefd.ml b/lib/xapi-fdcaps/test/test_safefd.ml new file mode 100644 index 00000000000..ea1b1343410 --- /dev/null +++ b/lib/xapi-fdcaps/test/test_safefd.ml @@ -0,0 +1,123 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * 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 Xapi_fdcaps +open Safefd + +let make_safefd () = + let rd, wr = Unix.pipe ~cloexec:true () in + (of_file_descr rd, of_file_descr wr) + +let test_safefd_regular () = + let rd, wr = Unix.pipe ~cloexec:true () in + let rd, wr = (of_file_descr rd, of_file_descr wr) in + let (_ : Unix.LargeFile.stats) = with_fd_exn rd Unix.LargeFile.fstat + and (_ : Unix.LargeFile.stats) = with_fd_exn wr Unix.LargeFile.fstat in + close_exn rd ; close_exn wr + +let test_safefd_double_close () = + let rd, wr = make_safefd () in + close_exn rd ; + close_exn wr ; + let exn = Unix.(Unix_error (EBADF, "close_exn", "")) in + Alcotest.check_raises "double close" exn (fun () -> close_exn wr) + +let test_safefd_idempotent_close () = + let rd, wr = make_safefd () in + close_exn rd ; + idempotent_close_exn wr ; + idempotent_close_exn wr ; + idempotent_close_exn wr ; + idempotent_close_exn wr + +let test_safefd_unix_close () = + let rd, wr = make_safefd () in + close_exn rd ; + let exn = Unix.(Unix_error (EBADF, "fstat", "")) in + Alcotest.check_raises "Unix.close detected" exn (fun () -> + with_fd_exn wr Unix.close + ) + +let remove_unix_error_arg f = + try f () + with Unix.Unix_error (code, fn, _) -> + (* remove arg, so we can match with [Alcotest.check_raises] *) + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace (Unix.Unix_error (code, fn, "")) bt + +let with_fd_exn f arg = remove_unix_error_arg (fun () -> with_fd_exn f arg) + +let close_reuse fd = + Unix.close fd ; + (* open and leak fd, this should reuse the FD number of [fd], but we should be able to detect via stat *) + let _, _ = Unix.pipe () in + () + +let test_safefd_unix_close_reuse () = + let rd, wr = make_safefd () in + close_exn rd ; + let exn = Unix.(Unix_error (EBADF, "with_fd_exn", "")) in + Alcotest.check_raises "Unix.close detected" exn (fun () -> + with_fd_exn wr close_reuse + ) + +let leak () = + let rd, wr = make_safefd () in + close_exn rd ; + (* leak wr *) + unsafe_to_file_descr_exn wr + +let test_safefd_finalised () = + let _leaked_fd : Unix.file_descr = leak () in + Gc.full_major () ; + Alcotest.( + check' int ~msg:"leak detected" ~expected:2 ~actual:(Safefd.leaked ()) + ) + +let test_pp_and_dump () = + let a, b = make_safefd () in + Format.printf "a: %a@,b: %a@." Safefd.pp a Safefd.pp b ; + Format.printf "a: %a@,b: %a@." Safefd.dump a Safefd.dump b + +let test_nop () = + let ebadf = Unix.(Unix_error (EBADF, "close_exn", "")) in + Alcotest.check_raises "nop close raises" ebadf (fun () -> close_exn nop) + +let test_unsafe_closed () = + let ebadf = Unix.(Unix_error (EBADF, "unsafe_to_file_descr_exn", "")) in + dump Fmt.stdout nop ; + Alcotest.check_raises "unsafe raises" ebadf (fun () -> + let (_ : Unix.file_descr) = unsafe_to_file_descr_exn nop in + () + ) + +let tests_safefd = + Alcotest. + [ + test_case "nop" `Quick test_nop + ; test_case "regular ops" `Quick test_safefd_regular + ; test_case "double close detected" `Quick test_safefd_double_close + ; test_case "idempotent close" `Quick test_safefd_idempotent_close + ; test_case "Unix.close detected" `Quick test_safefd_unix_close + ; test_case "Unix.close detected after reuse" `Quick + test_safefd_unix_close_reuse + ; test_case "FD leak detected" `Quick test_safefd_finalised + ; test_case "test pp and dump" `Quick test_pp_and_dump + ; test_case "unsafe of closed fd" `Quick test_unsafe_closed + ] + +let () = + setup () ; + Sys.enable_runtime_warnings true ; + Alcotest.run ~show_errors:true "xapi_fdcaps" [("safefd", tests_safefd)] diff --git a/lib/xapi-fdcaps/test/test_safefd.mli b/lib/xapi-fdcaps/test/test_safefd.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/xapi-fd-test.opam b/xapi-fd-test.opam new file mode 100644 index 00000000000..56801434c62 --- /dev/null +++ b/xapi-fd-test.opam @@ -0,0 +1,32 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Test framework for file descriptor operations" +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" +depends: [ + "dune" {>= "2.0"} + "alcotest" {with-test} + "base-unix" + "fmt" + "mtime" {>= "2.0.0"} + "logs" + "qcheck-core" {>= "0.21.2"} +] +build: [ + ["dune" "subst"] {pinned} + [ + "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/xapi-stdext.opam b/xapi-stdext.opam index e2654f782ab..088e3a820d5 100644 --- a/xapi-stdext.opam +++ b/xapi-stdext.opam @@ -16,6 +16,7 @@ depends: [ "xapi-stdext-threads" {= version} "xapi-stdext-unix" {= version} "xapi-stdext-zerocheck" {= version} + "xapi-fdcaps" {= version} ] build: [ ["dune" "subst"] {pinned} From 5b0ac7b4b8d1eafe88c38e3af2ae8974ec5e9178 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 15 Dec 2023 17:24:16 +0000 Subject: [PATCH 22/65] CP-47001: [xapi-fdcaps]: add -principal flag MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We are going to use type-level constraints a lot. Try to future proof it by using the recommended compiler flag. `ocamlc` says this about `-principal`: > When using labelled arguments and/or polymorphic methods, this flag is required to > ensure future versions of the compiler will be able to infer types correctly, even if internal algorithms change Signed-off-by: Edwin Török --- lib/xapi-fdcaps/dune | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/xapi-fdcaps/dune b/lib/xapi-fdcaps/dune index 6daf1416607..0891178f2f2 100644 --- a/lib/xapi-fdcaps/dune +++ b/lib/xapi-fdcaps/dune @@ -3,5 +3,6 @@ (library (public_name xapi-fdcaps) (name xapi_fdcaps) - (libraries fmt unix) + (libraries fmt unix threads.posix) + (flags (:standard -principal)) ) From a975edf3e1fd31bef62fa45bff7a5f2ef9e65fc1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 15 Dec 2023 17:26:16 +0000 Subject: [PATCH 23/65] CP-47001: [xapi-fdcaps]: optional coverage support MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is not enabled by default (but bisect-ppx is nevertheless a build-time dependency) Usage: `make coverage` Signed-off-by: Edwin Török --- .gitignore | 1 + Makefile | 7 ++++++- dune-project | 3 ++- lib/xapi-fdcaps/dune | 3 +++ xapi-fd-test.opam | 5 +++-- xapi-fdcaps.opam | 6 ++++-- xapi-rrd-transport.opam | 2 +- xapi-rrdd-plugin.opam | 2 +- xapi-stdext-date.opam | 4 ++-- xapi-stdext-encodings.opam | 4 ++-- xapi-stdext-pervasives.opam | 4 ++-- xapi-stdext-std.opam | 4 ++-- xapi-stdext-threads.opam | 4 ++-- xapi-stdext-unix.opam | 4 ++-- xapi-stdext-zerocheck.opam | 4 ++-- xapi-stdext.opam | 5 +++-- 16 files changed, 38 insertions(+), 24 deletions(-) diff --git a/.gitignore b/.gitignore index 3e23706e3a9..768185e8a60 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ _build/ *.bak *.native .merlin +_coverage/ *.install *.swp compile_flags.txt diff --git a/Makefile b/Makefile index a57871a5c4e..45a0b3e6b09 100644 --- a/Makefile +++ b/Makefile @@ -6,7 +6,7 @@ JOBS = $(shell getconf _NPROCESSORS_ONLN) PROFILE=release OPTMANDIR ?= $(OPTDIR)/man/man1/ -.PHONY: build clean test doc python format install uninstall +.PHONY: build clean test doc python format install uninstall coverage # if we have XAPI_VERSION set then set it in dune-project so we use that version number instead of the one obtained from git # this is typically used when we're not building from a git repo @@ -20,6 +20,11 @@ build: check: dune build @check -j $(JOBS) +coverage: + dune runtest --instrument-with bisect_ppx --force --profile=$(RELEASE) -j $(JOBS) + bisect-ppx-report html + bisect-ppx-report summary --per-file + clean: dune clean diff --git a/dune-project b/dune-project index 26944770d8d..3f674e4adf8 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 2.0) +(lang dune 2.7) (formatting (enabled_for ocaml)) (implicit_transitive_deps false) @@ -367,6 +367,7 @@ (alcotest :with-test) base-unix fmt + (bisect_ppx :with-test) ) ) diff --git a/lib/xapi-fdcaps/dune b/lib/xapi-fdcaps/dune index 0891178f2f2..cb3c54ea189 100644 --- a/lib/xapi-fdcaps/dune +++ b/lib/xapi-fdcaps/dune @@ -5,4 +5,7 @@ (name xapi_fdcaps) (libraries fmt unix threads.posix) (flags (:standard -principal)) + + ; off by default, enable with --instrument-with bisect_ppx + (instrumentation (backend bisect_ppx)) ) diff --git a/xapi-fd-test.opam b/xapi-fd-test.opam index 56801434c62..d6887267659 100644 --- a/xapi-fd-test.opam +++ b/xapi-fd-test.opam @@ -7,16 +7,17 @@ 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" {>= "2.0"} + "dune" {>= "2.7"} "alcotest" {with-test} "base-unix" "fmt" "mtime" {>= "2.0.0"} "logs" "qcheck-core" {>= "0.21.2"} + "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-fdcaps.opam b/xapi-fdcaps.opam index 6c5d05e2465..c4428d7e0bc 100644 --- a/xapi-fdcaps.opam +++ b/xapi-fdcaps.opam @@ -7,13 +7,15 @@ 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" {>= "2.0"} + "dune" {>= "2.7"} "alcotest" {with-test} "base-unix" "fmt" + "bisect_ppx" {with-test} + "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-rrd-transport.opam b/xapi-rrd-transport.opam index e9882d24b12..7cdb8205c98 100644 --- a/xapi-rrd-transport.opam +++ b/xapi-rrd-transport.opam @@ -1,7 +1,7 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-rrdd-plugin.opam b/xapi-rrdd-plugin.opam index 68a9ed509c5..b01d85a6da5 100644 --- a/xapi-rrdd-plugin.opam +++ b/xapi-rrdd-plugin.opam @@ -1,7 +1,7 @@ # This file is generated by dune, edit dune-project instead license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index a7f4951d856..393ad6ef128 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" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" {>= "4.12"} "alcotest" {with-test} "astring" @@ -16,7 +16,7 @@ depends: [ "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index c3538116761..a01829f99ac 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" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" {>= "4.13.0"} "alcotest" {>= "0.6.0" & with-test} "odoc" {with-doc} @@ -16,7 +16,7 @@ depends: [ "notty" {with-test} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-pervasives.opam b/xapi-stdext-pervasives.opam index 53fd4b34939..b0309093fa5 100644 --- a/xapi-stdext-pervasives.opam +++ b/xapi-stdext-pervasives.opam @@ -7,14 +7,14 @@ 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" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" {>= "4.08"} "logs" "odoc" {with-doc} "xapi-backtrace" ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam index 95b61c73e3e..e4f40a8ae6a 100644 --- a/xapi-stdext-std.opam +++ b/xapi-stdext-std.opam @@ -7,13 +7,13 @@ 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" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" {>= "4.08.0"} "alcotest" {with-test} "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index 9dcc9ff090c..09449f30273 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" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" "base-threads" "base-unix" @@ -15,7 +15,7 @@ depends: [ "xapi-stdext-pervasives" {= version} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index f8e709afe7f..b067d6d030b 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" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" {>= "4.12.0"} "base-unix" "fd-send-recv" {>= "2.0.0"} @@ -16,7 +16,7 @@ depends: [ "xapi-stdext-pervasives" {= version} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-zerocheck.opam b/xapi-stdext-zerocheck.opam index 30861bf3dc1..ee7603fdc4b 100644 --- a/xapi-stdext-zerocheck.opam +++ b/xapi-stdext-zerocheck.opam @@ -7,12 +7,12 @@ 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" {>= "2.0"} + "dune" {>= "2.7"} "ocaml" "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext.opam b/xapi-stdext.opam index 088e3a820d5..c0e91ff6bd7 100644 --- a/xapi-stdext.opam +++ b/xapi-stdext.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" {>= "2.0"} + "dune" {>= "2.7"} "xapi-stdext-date" {= version} "xapi-stdext-encodings" {= version} "xapi-stdext-pervasives" {= version} @@ -17,9 +17,10 @@ depends: [ "xapi-stdext-unix" {= version} "xapi-stdext-zerocheck" {= version} "xapi-fdcaps" {= version} + "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" From 89e95b42fb3c92fff58abce980bf08e0b1d3e688 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 20 Dec 2023 17:07:58 +0000 Subject: [PATCH 24/65] CP-47001: [xapi-fdcaps]: add properties module and tests MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Lightweight wrapper using polymorphic variants to track read, write, and file kind properties on file descriptors. We only track the property at the time the file descriptor was opened. This prevents bugs like accidentally swapping the read and write ends of a pipe, or attempting to run an operation on a file descriptor that would alway s fail (e.g. setting a socket timeout on a pipe) Write tests using cram-style expect tests that the operations we expect to be forbidden by this type system are actually forbidden. The error messages may be compiler version dependent, so only run them on OCaml 4.14.1 for now. Signed-off-by: Edwin Török --- dune-project | 1 + lib/xapi-fdcaps/properties.ml | 122 ++++++++++++++ lib/xapi-fdcaps/properties.mli | 192 +++++++++++++++++++++++ lib/xapi-fdcaps/test/dune | 6 +- lib/xapi-fdcaps/test/properties.t | 15 ++ lib/xapi-fdcaps/test/test_properties.ml | 94 +++++++++++ lib/xapi-fdcaps/test/test_properties.mli | 0 7 files changed, 429 insertions(+), 1 deletion(-) create mode 100644 lib/xapi-fdcaps/properties.ml create mode 100644 lib/xapi-fdcaps/properties.mli create mode 100644 lib/xapi-fdcaps/test/properties.t create mode 100644 lib/xapi-fdcaps/test/test_properties.ml create mode 100644 lib/xapi-fdcaps/test/test_properties.mli diff --git a/dune-project b/dune-project index 3f674e4adf8..44b3b3c6722 100644 --- a/dune-project +++ b/dune-project @@ -1,6 +1,7 @@ (lang dune 2.7) (formatting (enabled_for ocaml)) +(cram enable) (implicit_transitive_deps false) (generate_opam_files true) diff --git a/lib/xapi-fdcaps/properties.ml b/lib/xapi-fdcaps/properties.ml new file mode 100644 index 00000000000..9e359a9b471 --- /dev/null +++ b/lib/xapi-fdcaps/properties.ml @@ -0,0 +1,122 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * 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 (+!'a, +!'b) props = {rw: 'a; kind: 'b} + +type rdonly = [`rdonly] + +type wronly = [`wronly] + +type rdwr = [`rdwr] + +let pp_rw fmt = + Fmt.of_to_string + (function #rdonly -> "RDONLY" | #wronly -> "WRONLY" | #rdwr -> "RDWR") + fmt + +type reg = [`reg] + +type blk = [`blk] + +type chr = [`chr] + +type dir = [`dir] + +type lnk = [`lnk] + +type fifo = [`fifo] + +type sock = [`sock] + +type kind = [reg | blk | chr | dir | lnk | fifo | sock] + +let to_unix_kind = + let open Unix in + function + | #reg -> + S_REG + | #blk -> + S_BLK + | #chr -> + S_CHR + | #dir -> + S_DIR + | #lnk -> + S_LNK + | #fifo -> + S_FIFO + | #sock -> + S_SOCK + +let pp_kind fmt = Fmt.using to_unix_kind Safefd.pp_kind fmt + +let pp fmt = + Fmt.( + record + ~sep:Fmt.(any ", ") + [field "rw" (fun t -> t.rw) pp_rw; field "kind" (fun t -> t.kind) pp_kind] + ) + fmt + +type readable = [rdonly | rdwr] + +type writable = [wronly | rdwr] + +type rw = [rdonly | wronly | rdwr] + +type (+!'a, +!'b) t = (([< rw] as 'a), ([< kind] as 'b)) props + +let as_readable ({rw= #readable; _} as t) = t + +let as_writable ({rw= #writable; _} as t) = t + +let as_readable_opt = function + | {rw= #readable; _} as x -> + Some x + | {rw= #wronly; _} -> + None + +let as_writable_opt = function + | {rw= #writable; _} as x -> + Some x + | {rw= #rdonly; _} -> + None + +type espipe = [fifo | sock] + +let as_kind_opt expected ({kind; _} as t) = + (* we cannot compare the values directly because we want to keep the type parameters distinct *) + match (kind, expected) with + | #reg, #reg -> + Some {t with kind= expected} + | #blk, #blk -> + Some {t with kind= expected} + | #chr, #chr -> + Some {t with kind= expected} + | #dir, #dir -> + Some {t with kind= expected} + | #lnk, #lnk -> + Some {t with kind= expected} + | #fifo, #fifo -> + Some {t with kind= expected} + | #sock, #sock -> + Some {t with kind= expected} + | #kind, #kind -> + None + +type seekable = [reg | blk] + +type truncatable = reg + +let make rw kind = {rw; kind} diff --git a/lib/xapi-fdcaps/properties.mli b/lib/xapi-fdcaps/properties.mli new file mode 100644 index 00000000000..0afc529c56a --- /dev/null +++ b/lib/xapi-fdcaps/properties.mli @@ -0,0 +1,192 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * 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. + *) + +(** Static file property checking + + When file descriptors are open they have: + * a file kind: ({!type:reg}, {!type:blk), {!type:chr}, {!type:lnk}, {!type:fifo}, {!type:sock}) + * an open mode: {!type:readonly}, {!type:writeonly}, {!type:readwrite} depending on the {!type:Unix.open_flag} used + + Depending on these properties there are {!val:Unix} operations on file descriptors that always fail, e.g.: + * writing to a read-only file + * socket operation on non-socket + * seeking on a pipe + * ... + + The read-write property can also change at runtime: + * {!val:Unix.shutdown} can be used to shutdown the socket in either direction + + We track the property of the file at open time, and we reject operations that we can statically determine to always fail. + This doesn't guarantee the absence of runtime errors, but catches programming errors like accidentally swapping the read and write ends of a pipe, + or attempting to set a socket timeout on a pipe. + + We use polymorphic variants as type parameters to track these properties: they are simple to use and work well with type inference. + They also allow dispatching at runtime on the actual capabilities available, although they could be purely compile-time types (phantom types). + + Alternative approaches (typically with phantom types): + * abstract types as phantom type parameters: don't work well with type inference, and cannot express removing a property + * behavioural types (recursive polymorphic variants) can express removing a property, but error messages and type signatures become too long + * object phantom types strike a good balance between clarity of error messages and complexity of type signatures + + It'd be also possible to use purely boolean properties (capabilities), but that causes a long type signature, and allows expressing meaningless combinations, + such as a file that is both a socket and seekable, which is impossible. + Instead we directly map the concepts from the Unix module to a polymorphic variant (e.g. instead of separate read and write properties we have the 3 properties from the Unix module). + +{b References.} +{ul + {- Yaron Minsky. + {e {{:https://blog.janestreet.com/howto-static-access-control-using-phantom-types/}HOWTO: Static access control using phantom types}. 2008.}} + {- KC Sivaramakrishnan. + {e {{:https://kcsrk.info/ocaml/types/2016/06/30/behavioural-types/#file-descriptors}Behavioural types}. 2016.}} + {- Florian Angeletti. + {e {{:https://stackoverflow.com/a/55081337}Object phantom types}. 2019.}} +} +*) + +(** {1 File properties} + + Polymorphic type parameters for the set of properties a file descriptor may have on a given codepath. + E.g. {[> rdonly | wronly]} means that this codepath may be reached by a file descriptor with either of these properties, + although of course a file descriptor can only have one of these properties at a time. + + Usual rules for using polymorphic variants apply: + * when receiving a type declare an upper bound on what the code can handle, e.g. : {[< readable]} + * when returning a type declare a lower bound to make type inference/unification work, e.g. : {[> readable]} + + Naming conventions: + * [type property ] + * [val as_property : [< property] t -> [> property] t] + * [val as_property_opt: [< all] t -> [> property] t option] +*) + +(** file properties: {!type:rw}, {!type:kind} + + Upper bounds are avoided here to make the type usable in functors + *) +type (+!'a, +!'b) props + +(** {2 Read/write property} + + A file can be read-only, write-only, or read-write. +*) + +(** file opened with {!val:Unix.O_RDONLY} or the read end of a pipe *) +type rdonly = [`rdonly] + +(** file opened with {!val:Unix.O_WRONLY} or the write end of a pipe *) +type wronly = [`wronly] + +(** file opened with {!val:Unix.O_RDWR} or a socketpair *) +type rdwr = [`rdwr] + +(** file opened with either {!val:Unix.O_RDONLY} or {!val:Unix.O_RDWR} *) +type readable = [rdonly | rdwr] + +(** file opened with either {!val:Unix.O_WRONLY} or {!val:Unix.O_RDWR} *) +type writable = [wronly | rdwr] + +(** the read-write property *) +type rw = [rdonly | wronly | rdwr] + +val pp_rw : Format.formatter -> [< rw] -> unit +(** [pp_rw formatter rw] pretty prints the [rw] state on [formatter]. *) + +(** {2 File kind} *) + +(** A regular file, {!val:Unix.S_REG} *) +type reg = [`reg] + +(** A block device, {!val:Unix.S_BLK} *) +type blk = [`blk] + +(** A character device, {!val:Unix.S_CHR} *) +type chr = [`chr] + +(** A directory, {!val:Unix.S_DIR} *) +type dir = [`dir] + +(** A symbolic link, {!val:Unix.S_LNK} *) +type lnk = [`lnk] + +(** A pipe or FIFO, {!val:Unix.S_FIFO} *) +type fifo = [`fifo] + +(** A socket, {!val:Unix.S_SOCK} *) +type sock = [`sock] + +(** a {!type:Unix.file_kind} *) +type kind = [reg | blk | chr | dir | lnk | fifo | sock] + +val pp_kind : Format.formatter -> [< kind] -> unit +(** [pp_kind formatter kind] pretty prints [kind] on [formatter]. *) + +(** {2 Property type} *) + +(** upper bounds on properties *) +type (+!'a, +!'b) t = (([< rw] as 'a), ([< kind] as 'b)) props + +(** {2 Operations on read-write properties} *) + +val as_readable : ([< readable], 'a) t -> ([> readable], 'a) t +(** [as_readable t] requires [t] to be readable and ignores the writeonly property. *) + +val as_writable : ([< writable], 'a) t -> ([> writable], 'a) t +(** [as_writable t] requires [t] to be writable and ignores the readonly property. *) + +val as_readable_opt : ([< rw], 'a) t -> ([> readable], 'a) t option +(** [as_readable_opt t] tests for the presence of the readable property at runtime. + + @returns [Some t] when [t] is readable, and [None] otherwise +*) + +val as_writable_opt : ([< rw], 'a) t -> ([> writable], 'a) t option +(** [as_writable_opt t] tests for the presence of the writable property at runtime. + + @returns [Some t] when [t] is writable, and [None] otherwise +*) + +(** {2 Operations on file kind properties} *) + +val to_unix_kind : kind -> Unix.file_kind +(** [to_unix_kind kind] converts the polymorphic variant [kind] to {!type:Unix.file_kind} *) + +(** pipe, FIFO or socket that may raise {!val:Unix.ESPIPE} *) +type espipe = [fifo | sock] + +val as_kind_opt : ([< kind] as 'a) -> ('b, [< kind]) t -> ('b, 'a) t option +(** [as_kind_opt kind t] checks whether [t] is of type [kind]. + + @returns [Some t] if [t] is of type [kind], and [None] otherwise + *) + +(** {2 Properties derived from file kind} *) + +(** seek may be implementation defined on devices other than regular files or block devices. + + E.g. {!type:chr} devices would always return 0 when seeking, which doesn't follow the usual semantics of seek. +*) +type seekable = [reg | blk] + +(** truncate only works on regular files *) +type truncatable = reg + +(** {2 Create properties} *) + +val make : ([< rw] as 'a) -> ([< kind] as 'b) -> ('a, 'b) t +(** [make rw kind] builds a file property *) + +(** {2 Pretty printing} *) + +val pp : Format.formatter -> (_, _) t -> unit +(** [pp formatter t] pretty prints the properties on [formatter]. *) diff --git a/lib/xapi-fdcaps/test/dune b/lib/xapi-fdcaps/test/dune index b20b371663d..60619b2c1aa 100644 --- a/lib/xapi-fdcaps/test/dune +++ b/lib/xapi-fdcaps/test/dune @@ -1,5 +1,9 @@ (tests (package xapi-fdcaps) - (names test_safefd) + (names test_safefd test_properties) (libraries xapi_fdcaps alcotest fmt) ) + +(cram + (deps (package xapi-fdcaps)) +) diff --git a/lib/xapi-fdcaps/test/properties.t b/lib/xapi-fdcaps/test/properties.t new file mode 100644 index 00000000000..51b37e0eaeb --- /dev/null +++ b/lib/xapi-fdcaps/test/properties.t @@ -0,0 +1,15 @@ +Check that we get compile errors when trying to use a read-only or write-only property with the opposite operation: + + $ cat >t.ml <<'EOF' + > open Xapi_fdcaps.Properties + > let _ = as_readable (make `wronly `reg) + > EOF + $ ocamlfind ocamlc -package xapi-fdcaps -c t.ml 2>&1 | tail -n 1 + The second variant type does not allow tag(s) `wronly + + $ cat >t.ml <<'EOF' + > open Xapi_fdcaps.Properties + > let _ = as_writable (make `rdonly `reg) + > EOF + $ ocamlfind ocamlc -package xapi-fdcaps -c t.ml 2>&1 | tail -n 1 + The second variant type does not allow tag(s) `rdonly diff --git a/lib/xapi-fdcaps/test/test_properties.ml b/lib/xapi-fdcaps/test/test_properties.ml new file mode 100644 index 00000000000..e72e179af51 --- /dev/null +++ b/lib/xapi-fdcaps/test/test_properties.ml @@ -0,0 +1,94 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * 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 Xapi_fdcaps.Properties + +(* compilation tests, failed ones are in [properties.t] *) +let () = + let (_ : (_, _) t) = as_readable (make `rdonly `reg) in + let (_ : (_, _) t) = as_writable (make `wronly `reg) in + let (_ : (_, _) t) = as_readable (make `rdwr `reg) in + let (_ : (_, _) t) = as_writable (make `rdwr `reg) in + let #espipe = `fifo in + let #espipe = `sock in + let #seekable = `reg in + let #seekable = `blk in + let #truncatable = `reg in + () + +(* test that unification works *) +let _any_file = function + | 0 -> + make `rdonly `reg + | 1 -> + make `rdonly `blk + | 2 -> + make `rdonly `chr + | 3 -> + make `rdonly `dir + | 4 -> + make `rdonly `sock + | _ -> + make `rdonly `fifo + +let all_rw = [`rdonly; `wronly; `rdwr] + +let test_as_rw_opt f expected_set = + let t = Alcotest.testable pp ( = ) in + all_rw + |> List.map @@ fun rw -> + let test () = + let prop = make rw `reg in + let expected = if List.mem rw expected_set then Some prop else None in + let msg = Fmt.str "as_%a_opt" pp_rw rw in + Alcotest.(check' @@ option t) ~msg ~expected ~actual:(f prop) + in + Alcotest.test_case (Fmt.to_to_string pp_rw rw) `Quick test + +let _test_pp prop = Alcotest.test_case (Fmt.to_to_string pp prop) `Quick ignore + +let all_kinds = [`reg; `blk; `chr; `dir; `lnk; `sock; `fifo] + +let test_to_unix_kind () = + let all_unix_kinds = + List.sort_uniq compare @@ all_kinds |> List.map to_unix_kind + in + Alcotest.(check' int) + ~msg:"to_unix_kind mapping is unique" ~expected:(List.length all_kinds) + ~actual:(List.length all_unix_kinds) + +let test_as_kind = + let t = Alcotest.testable pp ( = ) in + all_kinds + |> List.map @@ fun k1 -> + ( Fmt.str "as_kind_opt %a" pp_kind k1 + , all_kinds + |> List.map @@ fun k2 -> + let test () = + let prop = make `rdonly k2 in + let actual = as_kind_opt k1 prop in + let expected = if k1 = k2 then Some prop else None in + Alcotest.(check' @@ option t) ~msg:"as_kind_opt" ~expected ~actual + in + Alcotest.test_case (Fmt.to_to_string pp_kind k2) `Quick test + ) + +let tests = + let open Alcotest in + ("to_unix_kind", [test_case "to_unix_kind" `Quick test_to_unix_kind]) + :: ("as_readable_opt", test_as_rw_opt as_readable_opt [`rdonly; `rdwr]) + :: ("as_writable_opt", test_as_rw_opt as_writable_opt [`wronly; `rdwr]) + :: test_as_kind + +let () = Alcotest.run ~show_errors:true "test_capabilities" tests diff --git a/lib/xapi-fdcaps/test/test_properties.mli b/lib/xapi-fdcaps/test/test_properties.mli new file mode 100644 index 00000000000..e69de29bb2d From fd68005330489946c9850adf52262fc370a5e19c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 20 Dec 2023 17:09:37 +0000 Subject: [PATCH 25/65] CP-47001: [xapi-fdcaps]: add operations module and tests MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Use the capabilities module to wrap most Unix operations needed in testing Unixext Add a testsuite that checks that whenever the type says "never" the underlying file descriptor operation would indeed raise an exception. This ensures that the type constraints we declare are actually correct. The checks use unsafe operations that bypass the type layer. Similarly check that operations that are accepted by the type system and marked as "always" in the type succeed. Signed-off-by: Edwin Török --- lib/xapi-fdcaps/operations.ml | 205 ++++++++++++++++++ lib/xapi-fdcaps/operations.mli | 216 +++++++++++++++++++ lib/xapi-fdcaps/test/dune | 2 +- lib/xapi-fdcaps/test/test_operations.ml | 262 +++++++++++++++++++++++ lib/xapi-fdcaps/test/test_operations.mli | 0 5 files changed, 684 insertions(+), 1 deletion(-) create mode 100644 lib/xapi-fdcaps/operations.ml create mode 100644 lib/xapi-fdcaps/operations.mli create mode 100644 lib/xapi-fdcaps/test/test_operations.ml create mode 100644 lib/xapi-fdcaps/test/test_operations.mli diff --git a/lib/xapi-fdcaps/operations.ml b/lib/xapi-fdcaps/operations.ml new file mode 100644 index 00000000000..12e74d60681 --- /dev/null +++ b/lib/xapi-fdcaps/operations.ml @@ -0,0 +1,205 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * 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 Properties + +type +!'a props = { + props: ('b, 'c) Properties.props + ; custom_ftruncate: (int64 -> unit) option + ; fd: Safefd.t +} + constraint 'a = ('b, 'c) Properties.props + +type +!'a t = 'a props constraint 'a = (_, _) Properties.t + +type (+!'a, +!'b) make = ('a, 'b) Properties.t t + +let dump ppf = + Fmt.( + Dump.( + record + [ + field "props" (fun t -> t.props) pp + ; field "custom_ftruncate" + (fun t -> Option.is_some t.custom_ftruncate) + bool + ; field "fd" (fun t -> t.fd) Safefd.dump + ] + ) + ) + ppf + +let pp ppf = + Fmt.( + record + ~sep:Fmt.(any "; ") + [ + field "props" (fun t -> t.props) pp + ; field "custom_ftruncate" + (fun t -> Option.is_some t.custom_ftruncate) + bool + ; field "fd" (fun t -> t.fd) Safefd.pp + ] + ) + ppf + +let close t = Safefd.idempotent_close_exn t.fd + +let with_fd t f = + let finally () = close t in + Fun.protect ~finally (fun () -> f t) + +module Syntax = struct let ( let@ ) f x = f x end + +open Syntax + +let with_fd2 (fd1, fd2) f = + let@ fd1 = with_fd fd1 in + let@ fd2 = with_fd fd2 in + f (fd1, fd2) + +let make ?custom_ftruncate props fd : 'a t = + {fd= Safefd.of_file_descr fd; props; custom_ftruncate} + +let make_ro_exn kind fd = make (Properties.make `rdonly kind) fd + +let make_wo_exn kind fd = make (Properties.make `wronly kind) fd + +let make_rw_exn ?custom_ftruncate kind fd = + make (Properties.make `rdwr kind) ?custom_ftruncate fd + +let pipe () = + let kind = `fifo in + let ro, wo = Unix.pipe ~cloexec:true () in + (make_ro_exn kind ro, make_wo_exn kind wo) + +let socketpair domain typ proto = + let kind = `sock in + let fd1, fd2 = Unix.socketpair ~cloexec:true domain typ proto in + (make_rw_exn kind fd1, make_rw_exn kind fd2) + +let openfile_ro kind path flags = + make_ro_exn kind + @@ Unix.openfile path (Unix.O_RDONLY :: Unix.O_CLOEXEC :: flags) 0 + +let openfile_rw ?custom_ftruncate kind path flags = + make_rw_exn ?custom_ftruncate kind + @@ Unix.openfile path (Unix.O_RDWR :: Unix.O_CLOEXEC :: flags) 0 + +let openfile_wo kind path flags = + make_wo_exn kind + @@ Unix.openfile path (Unix.O_WRONLY :: Unix.O_CLOEXEC :: flags) 0 + +let creat path flags perm = + make_rw_exn `reg + @@ Unix.openfile path + (Unix.O_RDWR :: Unix.O_CREAT :: Unix.O_EXCL :: Unix.O_CLOEXEC :: flags) + perm + +let dev_null_out () = openfile_wo `chr "/dev/null" [] + +let dev_null_in () = openfile_ro `chr "/dev/null" [] + +let dev_zero () = openfile_ro `chr "/dev/zero" [] + +let shutdown_recv t = + Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_RECEIVE + +let shutdown_send t = + Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_SEND + +let shutdown_all t = + Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_ALL + +let ftruncate t size = + match t.custom_ftruncate with + | None -> + Unix.LargeFile.ftruncate (Safefd.unsafe_to_file_descr_exn t.fd) size + | Some f -> + f size + +let lseek t off whence = + Unix.LargeFile.lseek (Safefd.unsafe_to_file_descr_exn t.fd) off whence + +let read t buf off len = + Unix.read (Safefd.unsafe_to_file_descr_exn t.fd) buf off len + +let single_write_substring t buf off len = + Unix.single_write_substring (Safefd.unsafe_to_file_descr_exn t.fd) buf off len + +let set_nonblock t = Unix.set_nonblock (Safefd.unsafe_to_file_descr_exn t.fd) + +let clear_nonblock t = Unix.clear_nonblock (Safefd.unsafe_to_file_descr_exn t.fd) + +let with_tempfile ?size () f = + let name, ch = + Filename.open_temp_file ~mode:[Open_binary] "xapi_fdcaps" "tmp" + in + let finally () = + close_out_noerr ch ; + 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 = with_fd t in + size |> Option.iter (fun size -> ftruncate t size) ; + f (name, t) + +let check_output cmd args = + let cmd = Filename.quote_command cmd args in + let ch = Unix.open_process_in cmd in + let finally () = + try + let (_ : Unix.process_status) = Unix.close_process_in ch in + () + with _ -> () + in + Fun.protect ~finally @@ fun () -> + let out = In_channel.input_all ch |> String.trim in + match Unix.close_process_in ch with + | Unix.WEXITED 0 -> + out + | _ -> + 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 custom_ftruncate size = + Unix.LargeFile.truncate name size ; + let (_ : string) = check_output "losetup" ["--set-capacity"; name] in + () + in + let finally () = + let (_ : string) = check_output "losetup" ["--detach"; blkdev] in + () + in + let@ () = Fun.protect ~finally in + let@ t = with_fd @@ openfile_rw ~custom_ftruncate `blk blkdev [] in + f (blkdev, t) + +let setup () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore + +module For_test = struct + let unsafe_fd_exn t = Safefd.unsafe_to_file_descr_exn t.fd +end diff --git a/lib/xapi-fdcaps/operations.mli b/lib/xapi-fdcaps/operations.mli new file mode 100644 index 00000000000..e320c681648 --- /dev/null +++ b/lib/xapi-fdcaps/operations.mli @@ -0,0 +1,216 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * 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. + *) + +(** Statically enforce file descriptor capabilities using type parameters. + + *) + +open Properties + +(** {1 Type and pretty printers } *) + +(** a file descriptor with properties + Upper bounds are avoided here so that this type can be used in functors + *) +type +!'a props constraint 'a = (_, _) Properties.props + +(** like {!type:props} but with upper bounds on properties *) +type +!'a t = 'a props constraint 'a = (_, _) Properties.t + +(** convenience type for declaring properties *) +type (+!'a, +!'b) make = ('a, 'b) Properties.t t + +val pp : _ t Fmt.t +(** [pp formatter t] pretty prints [t] on [formatter]. *) + +val dump : _ t Fmt.t +(** [dump formatter t] prints a debug representation of [t] on [formatter]. *) + +(** {1 Initialization} *) + +val setup : unit -> unit +(** [setup ()] installs a SIGPIPE handler. + + By default a SIGPIPE would kill the program, this makes it return [EPIPE] instead. + *) + +(** {1 With resource wrappers} *) + +val with_fd : 'a t -> ('a t -> 'b) -> 'b +(** [with_fd t f] calls [f t] and always closes [t] after [f] finishes. + [f] can also close [t] earlier if it wants to without a double close error. +*) + +val with_fd2 : 'a t * 'b t -> ('a t * 'b t -> 'c) -> 'c +(** [with_fd2 fd1 fd2 f] calls [f fd1 fd2] and always closes [t] after [f] finishes. *) + +module Syntax : sig + val ( let@ ) : ('a -> 'b) -> 'a -> 'b + (** [let@ fd = with_fd t in ... use fd] *) +end + +(** {1 {!mod:Unix} wrappers} *) + +val close : _ t -> unit +(** [close t] closes t. Doesn't raise an exception if it is already closed. + Other errors from the underlying {!val:Unix.close} are propagated. + *) + +val pipe : unit -> ([> rdonly], [> fifo]) make * ([> wronly], [> fifo]) make +(** [pipe ()] creates an unnamed pipe. + @see {!val:Unix.pipe} + *) + +val socketpair : + Unix.socket_domain + -> Unix.socket_type + -> int + -> ([> rdwr], [> sock]) make * ([> rdwr], [> sock]) make +(** [socketpair domain type protocol] creates a socket pair. + @see {!val:Unix.socketpair} + *) + +val openfile_ro : 'a -> string -> Unix.open_flag list -> ([> rdonly], 'a) make +(** [openfile_ro kind path flags] opens an existing [path] readonly. + + @param kind [path] is expected to be this file kind + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val openfile_rw : + ?custom_ftruncate:(int64 -> unit) + -> 'a + -> string + -> Unix.open_flag list + -> ([> rdwr], 'a) make +(** [openfile_rw kind path flags] opens an existing [path] readwrite. + + @param kind [path] is expected to be this file kind + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val openfile_wo : 'a -> string -> Unix.open_flag list -> ([> wronly], 'a) make +(** [openfile_wo kind path flags] opens an existing [path] writeonly. + + @param kind [path] is expected to be this file kind + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val creat : string -> Unix.open_flag list -> int -> ([> rdwr], [> reg]) make +(** [creat path flags perms] creates [path] readwrite. The path must not already exist. + + @param perms initial permissions for [path] + @see {!val:Unix.openfile} + + @raises Invalid_argument if [path] is not kind + *) + +val dev_null_out : unit -> ([> wronly], [> chr]) make +(** [dev_null_out ()] is "/dev/null" opened for writing *) + +val dev_null_in : unit -> ([> rdonly], [> chr]) make +(** [dev_null_in ()] is "/dev/null" opened for reading *) + +val dev_zero : unit -> ([> rdonly], [> chr]) make +(** [dev_zero ()] is "/dev/zero" opened for reading *) + +val shutdown_recv : ([< readable], [< sock]) make -> unit +(** [shutdown_recv t] shuts down receiving on [t]. + + @see {!Unix.shutdown} + *) + +val shutdown_send : ([< writable], [< sock]) make -> unit +(** [shutdown_send t] shuts down sending on [t]. + + @see {!Unix.shutdown} + *) + +val shutdown_all : ([< rdwr], [< sock]) make -> unit +(** [shutdown_all t] shuts down both receiving and sending on [t]. + + @see {!Unix.shutdown} + *) + +val ftruncate : ([< writable], [< truncatable]) make -> int64 -> unit +(** [ftruncate t size] sets the size of the regular file [t] to [size]. + + @see {!Unix.ftruncate} + *) + +val lseek : (_, [< seekable]) make -> int64 -> Unix.seek_command -> int64 +(** [lseek t off whence] sets the position of [t] to [off] with origin specified by [whence]. + + @see {!Unix.lseek} +*) + +val read : ([< readable], _) make -> bytes -> int -> int -> int +(** [read t buf off len] + @see {!Unix.read} + *) + +val single_write_substring : + ([< writable], _) make -> string -> int -> int -> int +(** [single_write_substring t buf off len] + + @see {!Unix.single_write_substring} +*) + +val set_nonblock : (_, [< espipe]) make -> unit +(** [set_nonblock t]. + + Only pipes, FIFOs and sockets are guaranteed to not block when this flag is set. + Although it is possible to set regular files and block devices as non-blocking, they currently still block + (although according to the manpage this may change in the future) + + @see {!Unix.set_nonblock} + *) + +val clear_nonblock : _ t -> unit +(** [clear_nonblock t]. + + We do not restrict clearing the non-blocking flag: that is just reverting back to default behaviour. + + @see {!Unix.clear_nonblock} + *) + +(** {1 Temporary files} *) + +val with_tempfile : + ?size:int64 -> unit -> (string * ([> wronly], [> reg]) make -> 'a) -> 'a +(** [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 +(** [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]. + + Deletes the block device when [f] finishes. + Only works when run as root. + + @param sector_size between 512 and 4096 +*) + +(**/**) + +module For_test : sig + val unsafe_fd_exn : _ t -> Unix.file_descr +end diff --git a/lib/xapi-fdcaps/test/dune b/lib/xapi-fdcaps/test/dune index 60619b2c1aa..505852753bb 100644 --- a/lib/xapi-fdcaps/test/dune +++ b/lib/xapi-fdcaps/test/dune @@ -1,6 +1,6 @@ (tests (package xapi-fdcaps) - (names test_safefd test_properties) + (names test_safefd test_properties test_operations) (libraries xapi_fdcaps alcotest fmt) ) diff --git a/lib/xapi-fdcaps/test/test_operations.ml b/lib/xapi-fdcaps/test/test_operations.ml new file mode 100644 index 00000000000..f3c22f36619 --- /dev/null +++ b/lib/xapi-fdcaps/test/test_operations.ml @@ -0,0 +1,262 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * 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 Xapi_fdcaps +open Properties +open Operations +open Syntax + +let b = Bytes.make 256 'x' + +let read_fd fd = + let (_ : int) = read fd b 0 (Bytes.length b) in + () + +let check_unsafe_raises ?(exn = Unix.EBADF) name t op = + (* if we bypass the type safety then we should get an error at runtime, + but only when the capability is 'no', not when it is 'removed' + *) + let fd = For_test.unsafe_fd_exn t in + let msg = Printf.sprintf "%s when <%s: no; ..>" name name in + let exn = Unix.Unix_error (exn, name, "") in + Alcotest.check_raises msg exn @@ fun () -> op fd + +let error_read_fd (t : ([< wronly], _) make) = + let@ fd = check_unsafe_raises "read" t in + let (_ : int) = Unix.read fd b 0 (Bytes.length b) in + () + +let str = "test" + +let write_fd fd = + let (_ : int) = single_write_substring fd str 0 (String.length str) in + () + +let error_write_fd (t : ([< rdonly], _) make) = + let@ fd = check_unsafe_raises "single_write" t in + let (_ : int) = Unix.single_write_substring fd str 0 (String.length str) in + () + +let test_ro fd = read_fd fd ; error_write_fd fd + +let test_wo fd = write_fd fd ; error_read_fd fd + +let test_lseek t = + let actual = lseek t 0L Unix.SEEK_SET in + Alcotest.(check' int64) ~msg:"starting position" ~expected:0L ~actual ; + let expected = 17L in + let actual = lseek t expected Unix.SEEK_SET in + Alcotest.(check' int64) ~msg:"jump1 position" ~expected ~actual ; + let actual = lseek t 3L Unix.SEEK_CUR in + Alcotest.(check' int64) ~msg:"jump2 position" ~expected:20L ~actual + +let error_lseek (t : (_, [< espipe]) make) = + let@ fd = check_unsafe_raises ~exn:Unix.ESPIPE "lseek" t in + let (_ : int) = Unix.lseek fd 0 Unix.SEEK_CUR in + () + +let test_ftruncate t = + let expected = 4000L in + ftruncate t expected ; + let actual = lseek t 0L Unix.SEEK_END in + Alcotest.(check' int64) ~msg:"size after ftruncate" ~expected ~actual + +type not_truncate = [blk | chr | dir | lnk | fifo | sock] + +let error_ftruncate (t : (_, [< not_truncate]) make) = + let@ fd = check_unsafe_raises ~exn:Unix.EINVAL "ftruncate" t in + Unix.LargeFile.ftruncate fd 4000L + +type not_sock = [reg | blk | chr | dir | lnk | fifo] + +let error_shutdown (t : (_, [< not_sock]) make) = + let@ fd = check_unsafe_raises ~exn:Unix.ENOTSOCK "shutdown" t in + Unix.shutdown fd Unix.SHUTDOWN_RECEIVE + +let test_fd2 make ops = + ops + |> List.map @@ fun (name, op1, op2) -> + let test () = + let@ fd1, fd2 = with_fd2 @@ make () in + pp Fmt.stdout fd1 ; + dump Fmt.stdout fd1 ; + (* the 2 operations may depend on each-other, e.g. write and read on a pipe, so must be part of same testcase *) + set_nonblock fd1 ; + set_nonblock fd2 ; + op2 fd2 ; + op1 fd1 ; + clear_nonblock fd1 ; + clear_nonblock fd2 + in + Alcotest.(test_case name `Quick) test + +let test_fd with_make ops = + ops + |> List.map @@ fun (name, op) -> + let test () = + let@ fd = with_make () in + op fd + in + Alcotest.(test_case name `Quick) test + +let test_pipe = + test_fd2 pipe + [ + ("wo,ro", test_ro, test_wo) + ; ("error_lseek", error_lseek, error_lseek) + ; ("error_ftruncate", error_ftruncate, error_ftruncate) + ; ("error_shutdown", error_shutdown, error_shutdown) + ] + +let test_sock = + let make () = socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + test_fd2 make + [ + ("read,write", read_fd, write_fd) + ; ("error_lseek", error_lseek, error_lseek) + ; ("error_ftruncate", error_ftruncate, error_ftruncate) + ] + +let with_fd fd f = pp Fmt.stdout fd ; dump Fmt.stdout fd ; with_fd fd f + +let with_tempfile () f = + let@ name, fd = with_tempfile () in + Fmt.pf Fmt.stdout "%s: %a@." name pp fd ; + f (name, fd) + +let test_single make f () = + let@ t = with_fd @@ make () in + error_shutdown t ; f t + +let test_safe_close () = + let@ t = with_fd @@ dev_null_in () in + close t ; close t + +let test_regular = + let with_make () f = + let@ _name, out = with_tempfile () in + f out + in + test_fd with_make + [ + ("wo", test_wo) + ; ("lseek", test_lseek) + ; ("ftruncate", test_ftruncate) + ; ("error_shutdown", error_shutdown) + ] + +let test_sock_shutdown_r () = + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + shutdown_recv fd1 ; + let exn = Unix.Unix_error (Unix.EPIPE, "single_write", "") in + let@ () = Alcotest.check_raises "write after shutdown of other end" exn in + write_fd fd2 + +let test_sock_shutdown_w () = + let@ _fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + write_fd fd2 ; + shutdown_send fd2 ; + let exn = Unix.Unix_error (Unix.EPIPE, "single_write", "") in + let@ () = Alcotest.check_raises "write after shutdown" exn in + write_fd fd2 + +let test_sock_shutdown_all () = + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + write_fd fd2 ; + shutdown_all fd2 ; + let exn = Unix.Unix_error (Unix.EPIPE, "single_write", "") in + let () = + let@ () = Alcotest.check_raises "write after shutdown" exn in + write_fd fd2 + in + let@ () = Alcotest.check_raises "write after shutdown" exn in + write_fd fd1 + +let test_block sector_size = + 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 + f fd + with Failure _ -> + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace (Failure "with_temp_blk") bt + in + if Unix.geteuid () = 0 then + run () + else + Alcotest.check_raises "non-root fails to create blockdevice" + (Failure "with_temp_blk") run + in + 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 ; + let@ fd1 = with_fd @@ creat name [] 0o600 in + pp Fmt.stdout fd1 ; + read_fd fd1 ; + write_fd fd1 ; + let@ fd2 = with_fd @@ openfile_rw `reg name [] in + pp Fmt.stdout fd2 ; read_fd fd2 ; write_fd fd2 + +let tests = + Alcotest. + [ + test_case "/dev/null in" `Quick @@ test_single dev_null_in test_ro + ; test_case "/dev/null out" `Quick @@ test_single dev_null_out test_wo + ; test_case "/dev/zero" `Quick @@ test_single dev_zero test_ro + ; test_case "safe close" `Quick test_safe_close + ; test_case "socket shutdown read" `Quick test_sock_shutdown_r + ; test_case "socket shutdown write" `Quick test_sock_shutdown_w + ; test_case "socket shutdown both" `Quick test_sock_shutdown_all + ; test_case "create" `Quick test_creat + ] + +(* this must be the last test *) +let test_no_leaks () = + Gc.full_major () ; + Alcotest.(check' int) + ~msg:"Check for no FD leaks" ~expected:0 ~actual:(Safefd.leaked ()) + +let () = + setup () ; + Sys.enable_runtime_warnings true ; + Alcotest.run ~show_errors:true "xapi_fdcaps" + [ + ("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) + ; ("xapi_fdcaps", tests) + ; ("no fd leaks", [Alcotest.test_case "no leaks" `Quick test_no_leaks]) + ] diff --git a/lib/xapi-fdcaps/test/test_operations.mli b/lib/xapi-fdcaps/test/test_operations.mli new file mode 100644 index 00000000000..e69de29bb2d From b1c757b4c01ecd0e6d3a2436efe526812cb8fa3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 21 Dec 2023 13:44:26 +0000 Subject: [PATCH 26/65] CP-47001: [xapi-fdcaps]: wrap more Unix operations MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-fdcaps/operations.ml | 79 +++++++++++++++++++++++++ lib/xapi-fdcaps/operations.mli | 57 ++++++++++++++++++ lib/xapi-fdcaps/properties.ml | 18 ++++++ lib/xapi-fdcaps/properties.mli | 3 + lib/xapi-fdcaps/test/test_operations.ml | 41 +++++++++++++ 5 files changed, 198 insertions(+) diff --git a/lib/xapi-fdcaps/operations.ml b/lib/xapi-fdcaps/operations.ml index 12e74d60681..7f7c9067e7a 100644 --- a/lib/xapi-fdcaps/operations.ml +++ b/lib/xapi-fdcaps/operations.ml @@ -56,6 +56,8 @@ let pp ppf = let close t = Safefd.idempotent_close_exn t.fd +let fsync t = Unix.fsync (Safefd.unsafe_to_file_descr_exn t.fd) + let with_fd t f = let finally () = close t in Fun.protect ~finally (fun () -> f t) @@ -107,6 +109,14 @@ let creat path flags perm = (Unix.O_RDWR :: Unix.O_CREAT :: Unix.O_EXCL :: Unix.O_CLOEXEC :: flags) perm +let kind_of_fd fd = of_unix_kind Unix.LargeFile.((fstat fd).st_kind) + +let stdin = make_ro_exn (kind_of_fd Unix.stdin) Unix.stdin + +let stdout = make_wo_exn (kind_of_fd Unix.stdout) Unix.stdout + +let stderr = make_wo_exn (kind_of_fd Unix.stderr) Unix.stderr + let dev_null_out () = openfile_wo `chr "/dev/null" [] let dev_null_in () = openfile_ro `chr "/dev/null" [] @@ -122,6 +132,9 @@ let shutdown_send t = let shutdown_all t = Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_ALL +let setsockopt_float t opt value = + Unix.setsockopt_float (Safefd.unsafe_to_file_descr_exn t.fd) opt value + let ftruncate t size = match t.custom_ftruncate with | None -> @@ -138,6 +151,18 @@ let read t buf off len = let single_write_substring t buf off len = Unix.single_write_substring (Safefd.unsafe_to_file_descr_exn t.fd) buf off len +let fstat t = Unix.LargeFile.fstat (Safefd.unsafe_to_file_descr_exn t.fd) + +let dup t = + { + t with + fd= + t.fd + |> Safefd.unsafe_to_file_descr_exn + |> Unix.dup + |> Safefd.of_file_descr + } + let set_nonblock t = Unix.set_nonblock (Safefd.unsafe_to_file_descr_exn t.fd) let clear_nonblock t = Unix.clear_nonblock (Safefd.unsafe_to_file_descr_exn t.fd) @@ -200,6 +225,60 @@ let with_temp_blk ?(sector_size = 512) name f = let setup () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore +type ('a, 'b) operation = 'a t -> 'b -> int -> int -> int + +let repeat_read op fd buf off len = + let rec loop consumed = + let off = off + consumed and len = len - consumed in + if len = 0 then + consumed (* we filled the buffer *) + else + match op fd buf off len with + | 0 (* EOF *) + | (exception + Unix.( + Unix_error + ((ECONNRESET | ENOTCONN | EAGAIN | EWOULDBLOCK | EINTR), _, _)) + ) (* connection error or non-blocking socket *) -> + consumed + | n -> + assert (n >= 0) ; + assert (n <= len) ; + loop (consumed + n) + in + loop 0 + +let repeat_write op fd buf off len = + let rec loop written = + let off = off + written and len = len - written in + if len = 0 then + written (* we've written the entire buffer *) + else + match op fd buf off len with + | 0 + (* should never happen, but we cannot retry now or we'd enter an infinite loop *) + | (exception + Unix.( + Unix_error + ( ( ECONNRESET + | EPIPE + | EINTR + | ENETDOWN + | ENETUNREACH + | EAGAIN + | EWOULDBLOCK ) + , _ + , _ + )) + ) (* connection error or nonblocking socket *) -> + written + | n -> + assert (n >= 0) ; + assert (n <= len) ; + loop (written + n) + in + loop 0 + module For_test = struct let unsafe_fd_exn t = Safefd.unsafe_to_file_descr_exn t.fd end diff --git a/lib/xapi-fdcaps/operations.mli b/lib/xapi-fdcaps/operations.mli index e320c681648..ee4a9f363f0 100644 --- a/lib/xapi-fdcaps/operations.mli +++ b/lib/xapi-fdcaps/operations.mli @@ -62,11 +62,26 @@ end (** {1 {!mod:Unix} wrappers} *) +val stdin : ([> rdonly], kind) make +(** [stdin] is a readonly file descriptor of unknown kind *) + +val stdout : ([> wronly], kind) make +(** [stdout] is a writeonly file descriptor of unknown kind *) + +val stderr : ([> wronly], kind) make +(** [stderr] is a writeonly file descriptor of unknown kind *) + val close : _ t -> unit (** [close t] closes t. Doesn't raise an exception if it is already closed. Other errors from the underlying {!val:Unix.close} are propagated. *) +val fsync : _ t -> unit +(** [fsync t] flushes [t] buffer to disk. + + Note that the file doesn't necessarily have to be writable, e.g. you can fsync a readonly open directory. + *) + val pipe : unit -> ([> rdonly], [> fifo]) make * ([> wronly], [> fifo]) make (** [pipe ()] creates an unnamed pipe. @see {!val:Unix.pipe} @@ -173,6 +188,12 @@ val single_write_substring : @see {!Unix.single_write_substring} *) +val fstat : _ t -> Unix.LargeFile.stats +(** [fstat t] is {!val:Unix.LargeFile.fstat} *) + +val dup : 'a t -> 'a t +(** [dup t] is {!val:Unix.dup} on [t]. *) + val set_nonblock : (_, [< espipe]) make -> unit (** [set_nonblock t]. @@ -191,6 +212,10 @@ val clear_nonblock : _ t -> unit @see {!Unix.clear_nonblock} *) +val setsockopt_float : + (_, [< sock]) make -> Unix.socket_float_option -> float -> unit +(** [set_sockopt_float t opt val] sets the socket option [opt] to [val] for [t]. *) + (** {1 Temporary files} *) val with_tempfile : @@ -209,6 +234,38 @@ val with_temp_blk : @param sector_size between 512 and 4096 *) +(** {1 Operation wrappers} + + The low-level {!val:read} and {!val:single_write_substring} can raise different exceptions + to mean end-of-file/disconnected depending on the file's kind. + + If you want to consider disconnectins as end-of-file then use these wrappers. + *) + +(** a buffered operation on a file descriptors. + + @see {!val:read} and {!val:single_write_substring} + *) +type ('a, 'b) operation = 'a t -> 'b -> int -> int -> int + +val repeat_read : ('a, bytes) operation -> ('a, bytes) operation +(** [repeat_read op buf off len] repeats [op] on the supplied buffer until EOF or a connection error is encountered. + The following connection errors are treated as EOF and are not reraised: + {!val:Unix.ECONNRESET}, {!val:Unix.ENOTCONN}. + {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} also cause the iteration to stop. + + The returned value may be less than [len] if EOF was encountered. +*) + +val repeat_write : ('a, string) operation -> ('a, string) operation +(** [repeat_write op buf off len] repeats [op] on the supplied buffer until a connection error is encountered or the entire buffer is written. + The following are treated as connection errors and not reraised: + {!val:Unix.ECONNRESET}, {!val:Unix.EPIPE}, {!val:Unix.ENETDOWN}, {!val:Unix.ENETUNREACH} + {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} also cause the iteration to stop. + + The returned value may be less than [len] if we were not able to complete the write due to a connection error. +*) + (**/**) module For_test : sig diff --git a/lib/xapi-fdcaps/properties.ml b/lib/xapi-fdcaps/properties.ml index 9e359a9b471..d26194cfeb9 100644 --- a/lib/xapi-fdcaps/properties.ml +++ b/lib/xapi-fdcaps/properties.ml @@ -59,6 +59,24 @@ let to_unix_kind = | #sock -> S_SOCK +let of_unix_kind = + let open Unix in + function + | S_REG -> + `reg + | S_BLK -> + `blk + | S_CHR -> + `chr + | S_DIR -> + `dir + | S_LNK -> + `lnk + | S_FIFO -> + `fifo + | S_SOCK -> + `sock + let pp_kind fmt = Fmt.using to_unix_kind Safefd.pp_kind fmt let pp fmt = diff --git a/lib/xapi-fdcaps/properties.mli b/lib/xapi-fdcaps/properties.mli index 0afc529c56a..6b51a3ab7a7 100644 --- a/lib/xapi-fdcaps/properties.mli +++ b/lib/xapi-fdcaps/properties.mli @@ -161,6 +161,9 @@ val as_writable_opt : ([< rw], 'a) t -> ([> writable], 'a) t option val to_unix_kind : kind -> Unix.file_kind (** [to_unix_kind kind] converts the polymorphic variant [kind] to {!type:Unix.file_kind} *) +val of_unix_kind : Unix.file_kind -> kind +(** [of_unix_kind kind] converts the {!type:Unix.file_kind} to {!type:kind}. *) + (** pipe, FIFO or socket that may raise {!val:Unix.ESPIPE} *) type espipe = [fifo | sock] diff --git a/lib/xapi-fdcaps/test/test_operations.ml b/lib/xapi-fdcaps/test/test_operations.ml index f3c22f36619..fa60e5f6682 100644 --- a/lib/xapi-fdcaps/test/test_operations.ml +++ b/lib/xapi-fdcaps/test/test_operations.ml @@ -227,6 +227,45 @@ let test_creat () = let@ fd2 = with_fd @@ openfile_rw `reg name [] in pp Fmt.stdout fd2 ; read_fd fd2 ; write_fd fd2 +let test_repeat_read () = + let buf = String.init 255 Char.chr in + let read _ dst off len = + let available = String.length buf - off in + let len = Int.min len 11 in + let len = Int.min len available in + Bytes.blit_string buf off dst off len ; + len + in + let dst = Bytes.make 300 '_' in + let@ placeholder = with_fd @@ dev_zero () in + (* not actually used, just to make the types work, we simulate the read using string ops *) + let actual = repeat_read read placeholder dst 0 (Bytes.length dst) in + Alcotest.(check' int) ~msg:"amount read" ~actual ~expected:(String.length buf) ; + Alcotest.(check' string) + ~msg:"contents" + ~actual:(Bytes.sub_string dst 0 actual) + ~expected:buf + +let test_repeat_write () = + let buf = Bytes.make 255 '_' in + let write _ src off len = + let available = Bytes.length buf - off in + let len = Int.min len 11 in + let len = Int.min len available in + Bytes.blit_string src off buf off len ; + len + in + let src = String.init 255 Char.chr in + let@ placeholder = with_fd @@ dev_zero () in + (* not actually used, just to make the types work, we simulate the read using string ops *) + let actual = repeat_write write placeholder src 0 (String.length src) in + Alcotest.(check' int) + ~msg:"amount written" ~actual ~expected:(Bytes.length buf) ; + Alcotest.(check' string) + ~msg:"contents" + ~actual:(Bytes.sub_string buf 0 actual) + ~expected:src + let tests = Alcotest. [ @@ -238,6 +277,8 @@ let tests = ; test_case "socket shutdown write" `Quick test_sock_shutdown_w ; test_case "socket shutdown both" `Quick test_sock_shutdown_all ; test_case "create" `Quick test_creat + ; test_case "repeat_read" `Quick test_repeat_read + ; test_case "repeat_write" `Quick test_repeat_write ] (* this must be the last test *) From 4da756c809ffee1586121c1de69555e57065f215 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 22 Dec 2023 13:58:26 +0000 Subject: [PATCH 27/65] CP-47001: [xapi-fdcaps] runtime tests for read-write properties MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-fdcaps/operations.ml | 31 +++++++++++++++++++++++++++++++ lib/xapi-fdcaps/operations.mli | 23 +++++++++++++++++++++++ 2 files changed, 54 insertions(+) diff --git a/lib/xapi-fdcaps/operations.ml b/lib/xapi-fdcaps/operations.ml index 7f7c9067e7a..bce25cdcd03 100644 --- a/lib/xapi-fdcaps/operations.ml +++ b/lib/xapi-fdcaps/operations.ml @@ -58,6 +58,29 @@ 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_opt t = + match as_readable_opt t.props with + | None -> + None + | Some props -> + Some {t with props} + +let as_writable_opt t = + match as_writable_opt t.props with + | None -> + None + | Some props -> + Some {t with props} + +let as_spipe_opt t = + match + (Properties.as_kind_opt `sock t.props, Properties.as_kind_opt `fifo t.props) + with + | Some props, _ | _, Some props -> + Some {t with props} + | None, None -> + None + let with_fd t f = let finally () = close t in Fun.protect ~finally (fun () -> f t) @@ -129,6 +152,14 @@ let shutdown_recv t = let shutdown_send t = Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_SEND +let as_readonly_socket t = + shutdown_send t ; + {t with props= Properties.make `rdonly `sock} + +let as_writeonly_socket t = + shutdown_recv t ; + {t with props= Properties.make `wronly `sock} + let shutdown_all t = Unix.shutdown (Safefd.unsafe_to_file_descr_exn t.fd) Unix.SHUTDOWN_ALL diff --git a/lib/xapi-fdcaps/operations.mli b/lib/xapi-fdcaps/operations.mli index ee4a9f363f0..6097f8cddf5 100644 --- a/lib/xapi-fdcaps/operations.mli +++ b/lib/xapi-fdcaps/operations.mli @@ -45,6 +45,19 @@ val setup : unit -> unit By default a SIGPIPE would kill the program, this makes it return [EPIPE] instead. *) +(** {1 Runtime property tests} *) + +val as_readable_opt : + (([< rw] as 'a), 'b) make -> ([> readable], 'b) make option +(** [as_readable_opt t] returns [Some t] when [t] is readable, and [None] otherwise. *) + +val as_writable_opt : + (([< rw] as 'a), 'b) make -> ([> writable], 'b) make option +(** [as_writable_opt t] returns [Some t] when [t] is readable, and [None] otherwise. *) + +val as_spipe_opt : ('a, [< kind]) make -> ('a, [> espipe]) make option +(** [as_spipe_opt t] returns [Some t] when [t] is a socket or pipe, and [None] otherwise. *) + (** {1 With resource wrappers} *) val with_fd : 'a t -> ('a t -> 'b) -> 'b @@ -158,6 +171,16 @@ val shutdown_send : ([< writable], [< sock]) make -> unit @see {!Unix.shutdown} *) +val as_readonly_socket : + ([< readable], [< sock]) make -> ([> rdonly], [> sock]) make +(** [as_readonly_socket t] calls {!val:shutdown_send} and returns a readonly socket, + if it was originally readable. *) + +val as_writeonly_socket : + ([< writable], [< sock]) make -> ([> wronly], [> sock]) make +(** [as_writeonly_socket t] calls {!val:shutdown_recv} and returns a writeonly socket, + if it was originally readable. *) + val shutdown_all : ([< rdwr], [< sock]) make -> unit (** [shutdown_all t] shuts down both receiving and sending on [t]. From 43026be18eb7e311bda89e23f545d82a1d94a9bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 22 Dec 2023 13:58:50 +0000 Subject: [PATCH 28/65] CP-47001: [xapi-fdcaps-test]: add observations module MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It can be used to wrap read or write operations andobserve the data that is transferred, and elapsed time. It also provides 2 functions that create a file of a given kind. We only test UNIX sockets, because socketpair doesn't support TCP sockets on Linux. Signed-off-by: Edwin Török --- lib/xapi-fd-test/dune | 5 +- lib/xapi-fd-test/observations.ml | 307 +++++++++++++++++++++ lib/xapi-fd-test/observations.mli | 202 ++++++++++++++ lib/xapi-fd-test/test/dune | 2 +- lib/xapi-fd-test/test/test_xapi_fd_test.ml | 115 ++++++++ 5 files changed, 629 insertions(+), 2 deletions(-) create mode 100644 lib/xapi-fd-test/observations.ml create mode 100644 lib/xapi-fd-test/observations.mli diff --git a/lib/xapi-fd-test/dune b/lib/xapi-fd-test/dune index b2a0d2fe007..4ae4d8d51b2 100644 --- a/lib/xapi-fd-test/dune +++ b/lib/xapi-fd-test/dune @@ -2,5 +2,8 @@ (library (public_name xapi-fd-test) (name xapi_fd_test) - (libraries xapi-fdcaps unix qcheck-core logs fmt mtime mtime.clock.os) + (libraries (re_export xapi-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/lib/xapi-fd-test/observations.ml b/lib/xapi-fd-test/observations.ml new file mode 100644 index 00000000000..32213b6de98 --- /dev/null +++ b/lib/xapi-fd-test/observations.ml @@ -0,0 +1,307 @@ +open Xapi_fdcaps +open Properties +open Operations +open Syntax + +let open_ro name = openfile_ro `reg name [] + +let open_wo name = openfile_wo `reg name [] + +let with_kind_ro kind f = + let with2 t = + let@ fd1, fd2 = with_fd2 t in + f fd1 (Some fd2) + in + match kind with + | Unix.S_SOCK -> + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + f (as_readonly_socket fd1) (Some fd2) + | Unix.S_REG -> + let@ name, out = with_tempfile () in + let@ fd = with_fd @@ open_ro name in + f fd (Some out) + | Unix.S_FIFO -> + with2 (pipe ()) + | Unix.S_DIR -> + invalid_arg + "S_DIR" (* not supported, OCaml has separate dir_handle type *) + | Unix.S_LNK -> + invalid_arg "S_LNK" (* O_NOFOLLOW not bound in OCaml *) + | Unix.S_BLK -> + let@ name, out = with_tempfile ~size:512L () in + let@ blkname, _ = with_temp_blk name in + let@ fd = with_fd @@ open_ro blkname in + f fd (Some out) + | Unix.S_CHR -> + let@ fd = with_fd @@ dev_zero () in + f fd None + +let with_kind_wo kind f = + let with2 t = + let@ fd1, fd2 = with_fd2 t in + f fd2 (Some fd1) + in + match kind with + | Unix.S_REG -> + let@ name, _out = with_tempfile () in + let@ fd = with_fd @@ open_wo name in + let@ fd_ro = with_fd @@ open_ro name in + f fd (Some fd_ro) + | Unix.S_FIFO -> + with2 @@ pipe () + | Unix.S_SOCK -> + let@ fd1, fd2 = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + f (as_writeonly_socket fd2) (Some fd1) + | Unix.S_DIR -> + invalid_arg + "S_DIR" (* not supported, OCaml has separate dir_handle type *) + | 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@ blkname, _ = with_temp_blk name in + let@ fd_ro = with_fd @@ open_ro blkname in + let@ fd = with_fd @@ open_wo blkname in + f fd (Some fd_ro) + | Unix.S_CHR -> + let@ fd = with_fd @@ dev_null_out () in + f fd None + +let with_kind_rw kind f = + match kind with + | 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" + +let observe_read observed op t dest off len = + let amount = op t dest off len in + assert (amount >= 0) ; + Buffer.add_subbytes observed dest off amount ; + amount + +let observe_write observed op t source off len = + let amount = op t source off len in + assert (amount >= 0) ; + Buffer.add_substring observed source off amount ; + amount + +type 'a or_exn = ('a, Rresult.R.exn_trap) result + +let unwrap_exn = function + | Ok ok -> + ok + | Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + +let concurrently (f, g) (farg, garg) = + (* only one thread at a time reads or writes, atomic not needed *) + let thread_result = ref None in + let thread_fun (tfun, arg) = + thread_result := Some (Rresult.R.trap_exn tfun arg) + in + let t = Thread.create thread_fun (g, garg) in + let res = Rresult.R.trap_exn f farg in + Thread.join t ; + let thread_result = + match !thread_result with + | Some r -> + r + | None -> + Rresult.R.trap_exn failwith "Thread not run?" + in + (res, thread_result) + +type 'a observation = { + elapsed: Mtime.span + ; data: string + ; is_read: [< rdonly | wronly] as 'a +} + +let truncated_string ppf s = + let n = 35 in + if String.length s < 2 * n then + Fmt.string ppf s + else + Fmt.pf ppf "%S...%S" (String.sub s 0 n) + (String.sub s (String.length s - n) n) + +let pp ppf = + Fmt.( + record ~sep:(any ";") + [ + field "elapsed" (fun t -> t.elapsed) Mtime.Span.pp + ; field "data" (fun t -> t.data) truncated_string + ] + ) + ppf + +type ('a, 'b) observations = {read: 'a; write: 'b; elapsed: Mtime.span} + +module CancellableSleep = struct + type nonrec t = { + wait: (rdonly, sock) make + ; wake: (wronly, sock) make + ; buf: bytes + } + + let with_ f = + let@ wait, wake = with_fd2 @@ socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + f + { + wait= as_readonly_socket wait + ; wake= as_writeonly_socket wake + ; buf= Bytes.make 1 ' ' + } + + let set_rcvtimeo sock timeo = setsockopt_float sock Unix.SO_RCVTIMEO timeo + + let sleep t dt = + set_rcvtimeo t.wait (Mtime.Span.to_float_ns dt *. 1e-9) ; + try + let (_ : int) = read t.wait t.buf 0 1 in + () + with Unix.Unix_error (Unix.EAGAIN, _, _) -> () + + let cancel t = shutdown_send t.wake +end + +module Delay = struct + type t = {duration: Mtime.span; every_bytes: int} + + let pp = + Fmt.( + record ~sep:(any ";") + [ + field "duration" (fun t -> t.duration) Mtime.Span.pp + ; field "every_bytes" (fun t -> t.every_bytes) int + ] + ) + + let v ~duration ~every_bytes = {duration; every_bytes} + + let apply repeat cancel t op = + let remaining = ref t.every_bytes in + let sleep () = + CancellableSleep.sleep cancel t.duration ; + remaining := t.every_bytes + in + let delayed_op fd buf off len = + (* ensure we'll be able to insert our sleep, limit [len] if needed *) + let n = op fd buf off (Int.min !remaining len) in + remaining := !remaining - n ; + if !remaining <= 0 then sleep () ; + n + in + repeat delayed_op + + let apply_read cancel t op = apply repeat_read cancel t op + + let apply_write cancel t op = apply repeat_write cancel t op +end + +let do_op buf is_read repeat observe op arg off length fd = + fd + |> Option.map @@ fun rd -> + let dt = Mtime_clock.counter () in + let (_ : int) = repeat (observe buf op) rd arg off length in + let elapsed = Mtime_clock.count dt in + let data = Buffer.contents buf in + {is_read; data; elapsed} + +let do_read read rd_buf ~size = + let length = size in + do_op rd_buf `rdonly repeat_read observe_read read (Bytes.make length 'x') 0 + length + +let do_write write buf expected off = + do_op buf `wronly repeat_write observe_write write expected off + (String.length expected - off) + +let wrap_measure f arg = + let dt = Mtime_clock.counter () in + let r = Rresult.R.trap_exn f arg in + let result = (Mtime_clock.count dt, r) in + close arg ; result + +let observe_ro write ~f kind expected = + with_kind_ro kind @@ fun ro wo_opt -> + let written = Buffer.create 0 in + let prepare fd_opt = + let () = + fd_opt + |> Option.iter @@ fun fd -> + as_spipe_opt fd |> Option.iter set_nonblock ; + let (_ : int) = + repeat_write + (observe_write written write) + fd expected 0 (String.length expected) + in + clear_nonblock fd + in + Buffer.length written + in + (* write as much as possible initially, TODO: should be configurable? *) + let off = prepare wo_opt in + let g fd_opt = + fd_opt + |> Option.fold ~none:None ~some:(fun fd -> + let r = do_write write written expected off (as_writable_opt fd) in + close fd ; r + ) + in + let res, thread_result = concurrently (wrap_measure f, g) (ro, wo_opt) in + let elapsed, res = unwrap_exn res in + let write = unwrap_exn thread_result in + let write = + write + |> Option.map @@ fun write -> {write with data= Buffer.contents written} + in + ({read= (); write; elapsed}, res) + +let observe_wo read ~f ~size kind = + with_kind_wo kind @@ fun wo ro_opt -> + let rd_buf = Buffer.create 0 in + (* TODO:set block device size *) + let g fd_opt = + fd_opt + |> Option.fold ~none:None ~some:(fun fd -> + do_read ~size read rd_buf (as_readable_opt fd) + ) + in + let res, thread_result = concurrently (wrap_measure f, g) (wo, ro_opt) in + let elapsed, res = unwrap_exn res in + let read = unwrap_exn thread_result in + let (_ : _ option) = g ro_opt in + let read = + read |> Option.map @@ fun read -> {read with data= Buffer.contents rd_buf} + in + ({write= (); read; elapsed}, res) + +let observe_rw read write ~f ~size kind expected = + with_kind_rw kind @@ fun rw1 rw2 -> + let written = Buffer.create 0 in + let rd_buf = Buffer.create 0 in + let gw fd = do_write write written expected 0 (as_writable_opt fd) + and gr fd = do_read ~size read rd_buf (as_readable_opt fd) in + let g fd = + let r = concurrently (gr, gw) (fd, fd) in + close fd ; r + in + let res, thread_result = concurrently (wrap_measure f, g) (rw1, rw2) in + let elapsed, res = unwrap_exn res in + let read, write = unwrap_exn thread_result in + let read = + read + |> unwrap_exn + |> Option.map @@ fun read -> {read with data= Buffer.contents rd_buf} + and write = + write + |> unwrap_exn + |> Option.map @@ fun write -> {write with data= Buffer.contents written} + in + ({read; write; elapsed}, res) diff --git a/lib/xapi-fd-test/observations.mli b/lib/xapi-fd-test/observations.mli new file mode 100644 index 00000000000..2e4ecb6b7d0 --- /dev/null +++ b/lib/xapi-fd-test/observations.mli @@ -0,0 +1,202 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * 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 Xapi_fdcaps +open Properties +open Operations + +(** {1 Generate test resources} *) + +val with_kind_ro : + Unix.file_kind + -> (([> rdonly], kind) make -> ([> writable], kind) make option -> 'a) + -> 'a +(** [with_kind_ro kind f] creates file descriptors of [kind] type, and calls [f] with it. + For sockets and pipes [f] receives both sides. + For regular files and block devices it receives a writable file. + For character devices it receives a {!val:null} device. +*) + +val with_kind_wo : + Unix.file_kind + -> (([> wronly], kind) make -> ([> readable], kind) make option -> 'a) + -> 'a +(** [with_kind_wo kind f] is like {!val:with_kind_ro} but creates a write only file. +*) + +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. +*) + +(** {1 Observe operations} *) + +val observe_read : + Buffer.t + -> ((([< readable], _) Properties.t as 'a), bytes) operation + -> ('a, bytes) operation +(** [observe_read buf op] wraps the operation [op], and stores all substrings read into [buf]. *) + +val observe_write : + Buffer.t + -> ((([< writable], _) Properties.t as 'a), string) operation + -> ('a, string) operation +(** [observe_write buf op] wraps the operation [op], and stores all substrings written into [buf]. *) + +(** {1 Concurrency helpers} *) + +(** a successful result ['a], or an exception with its backtrace on error. + +@see {!val:unwrap_exn} to reraise the exception with its original backtrace + *) +type 'a or_exn = ('a, Rresult.R.exn_trap) result + +val unwrap_exn : 'a or_exn -> 'a +(** [unwrap_exn t] returns the underlying successful result, or reraises the exception *) + +val concurrently : ('a -> 'b) * ('c -> 'd) -> 'a * 'c -> 'b or_exn * 'd or_exn +(** [concurrently (f, g) (farg, garg)] calls [f farg] and [g garg] in separate threads, + and returns their results. +*) + +(** Sleep that can be interrupted from another thread. + + This uses file descriptors internally, so shouldn't be used as is in XAPI, + because it'd use up 2 file descriptors every time a [with_] is called. + + `pthread_cond_timedwait` could've been used instead, but that is not available in OCaml, + and `pthread_cond*` is known to have deadlock bugs on glibc >= 2.27 + https://sourceware.org/bugzilla/show_bug.cgi?id=25847 +*) +module CancellableSleep : sig + (** cancel signal *) + type t + + val with_ : (t -> 'a) -> 'a + (** [with f] creates a cancellable sleep value and calls [f] with it. *) + + val sleep : t -> Mtime.span -> unit + (** [sleep t duration] sleeps until [duration] has elapsed or [t] has been signaled. *) + + val cancel : t -> unit + (** [cancel t] signals [t] to cancel any sleeps *) +end + +(** 1 Introduce delays + +These are needed to trigger short reads on sockets. +*) + +module Delay : sig + (** a delay specification *) + type t + + val v : duration:Mtime.span -> every_bytes:int -> t + (** [v ~duration ~every_bytes] inserts a sleep for [duration] every [every_bytes] interval. + The sleep can be canceled with [cancel]. + + Note that the time taken to send or receive [after_bytes] is not taken into account to guarantee the insertion of the delay. + *) + + val apply_read : + CancellableSleep.t + -> t + -> ((([< readable], _) Properties.t as 'a), bytes) operation + -> ('a, bytes) operation + (** [apply_read cancel delay op] returns a new operation which calls [op] and every [delay.after_bytes] + calls sleep for [duration] *) + + val apply_write : + CancellableSleep.t + -> t + -> ((([< writable], _) Properties.t as 'a), string) operation + -> ('a, string) operation + (** [apply_write cancel delay op] returns a new operation which calls [op] and every [delay.after_bytes] + calls sleep for [duration] *) + + val pp : t Fmt.t + (** [pp formatter t] is a pretty printer for [t] on [formatter]. *) +end + +(** {1 Observe file descriptor actions} + + File descriptors are created in pairs, and we can observe the actions from the other end of a pipe or socketpair. + For regular files we can prepare some data before, or inspect the data at the end. + *) + +(** an observation from the point of view of the observer *) +type 'a observation = { + elapsed: Mtime.span + (** the elapsed time for the observer until EOF was encountered *) + ; data: string (** the data that was sent or received *) + ; is_read: [< rdonly | wronly] as 'a + (** observer's point of view, so observing actions on a readonly pipe will be a write action *) +} + +val pp : _ observation Fmt.t +(**[pp formatter obs] pretty prints [obs]ervation on [formatter]. *) + +(** read and write observations, and the time elapsed for the function under test *) +type ('a, 'b) observations = {read: 'a; write: 'b; elapsed: Mtime.span} + +val observe_ro : + (([> writable], kind) Properties.t, string) operation + -> f:(([< readable > `rdonly], kind) make -> 'a) + -> Unix.file_kind + -> string + -> (unit, [> wronly] observation option) observations * 'a or_exn +(** [observe_ro write ~f kind expected] generates a file descriptor of [kind] type, + and calls [f] with it. + It observes [f]'s actions from the other side of a pipe, socket, file descriptor, + or block device if possible. + + @param write the operation used for writing, allows insertion of delays + @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 + *) + +val observe_wo : + (([> readable], kind) Properties.t, bytes) operation + -> f:(([< writable > `wronly], kind) make -> 'a) + -> size:int + -> Unix.file_kind + -> ([> rdonly] observation option, unit) observations * 'a or_exn +(** [observe_wo read ~f ~size kind] generates a file descriptor of [kind] type, + and calls [f] with it. + It observes [f]'s actions from the other side of a pipe, socket, file descriptor, + or block device if possible. + It expects [size] bytes written by [f]. + + @returns an observation of [f]'s actions on the file descriptor and [f]'s result + *) + +val observe_rw : + (([> readable], kind) Properties.t, bytes) operation + -> (([> writable], kind) Properties.t, string) operation + -> f:((rdwr, kind) make -> 'a) + -> size:int + -> Unix.file_kind + -> string + -> ([> rdonly] observation option, [> wronly] observation option) observations + * 'a or_exn +(** [observe_rw read write ~f ~size kind expected] generates a file descriptor of [kind] type, + and calls [f] with it. + It observes [f]'s actions from the other side of a pipe, socket, file descriptor, + or block device if possible. + + @param read the operation used for reading, allows insertion of delays + @param write the operation used for writing, allows insertion of delays + @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 + *) diff --git a/lib/xapi-fd-test/test/dune b/lib/xapi-fd-test/test/dune index 10b800a0290..ecc23b141b3 100644 --- a/lib/xapi-fd-test/test/dune +++ b/lib/xapi-fd-test/test/dune @@ -2,5 +2,5 @@ (test (package xapi-fd-test) (name test_xapi_fd_test) - (libraries xapi_fd_test alcotest) + (libraries xapi_fd_test alcotest fmt mtime.clock.os) ) diff --git a/lib/xapi-fd-test/test/test_xapi_fd_test.ml b/lib/xapi-fd-test/test/test_xapi_fd_test.ml index e69de29bb2d..b6ae12eb035 100644 --- a/lib/xapi-fd-test/test/test_xapi_fd_test.ml +++ b/lib/xapi-fd-test/test/test_xapi_fd_test.ml @@ -0,0 +1,115 @@ +open Xapi_fdcaps +open Operations +open Xapi_fd_test.Observations +open Syntax + +let skip_blk = function + | Unix.S_BLK -> + if Unix.geteuid () <> 0 then + Alcotest.skip () + | _ -> + () + +let expected = "string to be written" + +(* +let prepare fd_opt = + let buf = Buffer.create 0 in + let () = + fd_opt + |> Option.iter @@ fun fd -> + let (_ : int) = + observe_write buf single_write_substring fd expected 0 + (String.length expected) + in + () + in + buf +*) + +let test_kind_ro kind () = + skip_blk kind ; + let f fd = + let b = Bytes.make 128 'x' in + let n = read fd b 0 (Bytes.length b) in + close fd ; Bytes.sub_string b 0 n + in + let observed, res = observe_ro single_write_substring kind expected ~f in + let actual = unwrap_exn res in + match observed.write with + | Some observed_write -> + Alcotest.(check' string) + ~msg:"expected string received" ~expected:observed_write.data ~actual + | None -> + () + +let test_kind_wo kind () = + skip_blk kind ; + let f fd = + let n = single_write_substring fd expected 0 (String.length expected) in + close fd ; String.sub expected 0 n + in + let observed, res = observe_wo read kind ~f ~size:128 in + let actual = unwrap_exn res in + match observed.read with + | Some observed_read -> + Alcotest.(check' string) + ~msg:"expected string received" ~expected:observed_read.data ~actual + | None -> + () + +let kinds = Unix.[S_BLK; S_CHR; S_FIFO; S_REG; S_SOCK] + +let test_kind_all test = + kinds + |> List.map @@ fun kind -> + Alcotest.test_case (Fmt.to_to_string Safefd.pp_kind kind) `Quick (test kind) + +let test_cancellable_sleep () = + let@ t = CancellableSleep.with_ in + let sleep_duration = Mtime.Span.(2 * s) in + let sleeper () = + let dt = Mtime_clock.counter () in + let () = CancellableSleep.sleep t sleep_duration in + Mtime_clock.count dt + in + let waker_duration = 0.1 in + let waker () = Unix.sleepf waker_duration ; CancellableSleep.cancel t in + let slept, _ = concurrently (sleeper, waker) ((), ()) in + let slept = unwrap_exn slept in + if Mtime.Span.compare slept sleep_duration >= 0 then + Alcotest.failf + "Sleep wasn't interrupted as expected, total duration = %a; waked at = \ + %fs" + Mtime.Span.pp slept waker_duration ; + if Mtime.Span.to_float_ns slept *. 1e-9 < waker_duration then + Alcotest.failf "Sleep was shorter than expected, total duration = %a < %fs" + Mtime.Span.pp slept waker_duration + +let test_full_sleep () = + let@ t = CancellableSleep.with_ in + let sleep_duration = Mtime.Span.(10 * ms) in + let slept = + let dt = Mtime_clock.counter () in + let () = CancellableSleep.sleep t sleep_duration in + Mtime_clock.count dt + in + if Mtime.Span.compare slept sleep_duration < 0 then + Alcotest.failf "Sleep was shorter than expected, total duration = %a < %a" + Mtime.Span.pp slept Mtime.Span.pp sleep_duration + +let () = + setup () ; + (* kill test after 5s, it must've gotten stuck.. *) + (* let (_: int) = Unix.alarm 5 in *) + Alcotest.run ~show_errors:true "xapi_fdcaps" + [ + ("test_kind_ro", test_kind_all test_kind_ro) + ; ("test_kind_wo", test_kind_all test_kind_wo) + ; ( "cancellable sleep" + , [ + Alcotest.test_case "cancellable" `Quick test_cancellable_sleep + ; Alcotest.test_case "full" `Quick test_full_sleep + ] + ) + ] From 908f5a021d0ecc133232120f1e65449a4d6de735 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 22 Dec 2023 17:05:01 +0000 Subject: [PATCH 29/65] CP-47001: [xapi-fdcaps-test]: add generate module MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-fd-test/generate.ml | 138 ++++++++++++++++++++++++++++++++++ lib/xapi-fd-test/generate.mli | 87 +++++++++++++++++++++ 2 files changed, 225 insertions(+) create mode 100644 lib/xapi-fd-test/generate.ml create mode 100644 lib/xapi-fd-test/generate.mli diff --git a/lib/xapi-fd-test/generate.ml b/lib/xapi-fd-test/generate.ml new file mode 100644 index 00000000000..b3d28b15c4d --- /dev/null +++ b/lib/xapi-fd-test/generate.ml @@ -0,0 +1,138 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * 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 Xapi_fdcaps +open Operations +open Observations + +type t = { + size: int + ; delay_read: Delay.t option + ; delay_write: Delay.t option + ; kind: Unix.file_kind +} + +let make ~size ~delay_read ~delay_write kind = + {size; delay_read; delay_write; kind} + +open QCheck2 + +let file_kind = + ( Gen.oneofa Unix.[|S_BLK; S_CHR; S_DIR; S_FIFO; S_LNK; S_REG; S_SOCK|] + , Print.contramap (Fmt.to_to_string Safefd.pp_kind) Print.string + ) + +(* also coincidentally the pipe buffer size on Linux *) +let ocaml_unix_buffer_size = 65536 + +let sizes = + Gen.oneofa + [| + 0 + ; 1 + ; 100 + ; 4096 + ; ocaml_unix_buffer_size - 1 + ; ocaml_unix_buffer_size + ; ocaml_unix_buffer_size + 1 + ; 2 * ocaml_unix_buffer_size + ; (10 * ocaml_unix_buffer_size) + 3 + |] + +(* some may exceed length of test, but that is what the timeout is for *) +let total_delays = Gen.oneofa [|0.001; 0.01; 0.1; 0.4|] + +let span_of_s s = s *. 1e9 |> Mtime.Span.of_float_ns |> Option.get + +(* keep these short *) +let timeouts = Gen.oneofa [|0.0; 0.001; 0.1; 0.3|] + +let delay_of_size total_delay size = + let open Gen in + let* every_bytes = if size = 0 then return 1 else 1 -- size in + let chunks = max 1 (size / every_bytes) in + let duration = total_delay /. float_of_int chunks |> span_of_s in + return @@ Some (Delay.v ~every_bytes ~duration) + +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* delay = delay_of_size total_delay size in + return @@ make ~delay_read:delay ~delay_write:delay ~size kind + +let print t = + (* to easily grep print on single line *) + let buf = Buffer.create 128 in + let fmt = Fmt.with_buffer buf in + Format.pp_set_geometry fmt ~max_indent:999 ~margin:1000 ; + Fmt.( + record ~sep:(any "; ") + [ + field "delay_read" (fun t -> t.delay_read) (option Delay.pp) + ; field "delay_write" (fun t -> t.delay_write) (option Delay.pp) + ; field "size" (fun t -> t.size) int + ; field "file_kind" (fun t -> (snd file_kind) t.kind) string + ] + ) + fmt t ; + Fmt.flush fmt () ; + Buffer.contents buf + +let run_ro t data ~f = + (* we can only implement delays on write, skip *) + CancellableSleep.with_ @@ fun cancel -> + let finally () = CancellableSleep.cancel cancel in + let f arg = Fun.protect ~finally (fun () -> f arg) in + let write = + match t.delay_write with + | Some delay -> + Delay.apply_write cancel delay single_write_substring + | None -> + single_write_substring + in + observe_ro write ~f t.kind data + +let run_wo t ~f = + CancellableSleep.with_ @@ fun cancel -> + let finally () = CancellableSleep.cancel cancel in + let f arg = Fun.protect ~finally (fun () -> f arg) in + let read = + match t.delay_read with + | Some delay -> + Delay.apply_read cancel delay read + | None -> + read + in + observe_wo read ~f t.kind ~size:t.size + +let run_rw t data ~f = + CancellableSleep.with_ @@ fun cancel -> + let finally () = CancellableSleep.cancel cancel in + let f arg = Fun.protect ~finally (fun () -> f arg) in + let read = + match t.delay_read with + | Some delay -> + Delay.apply_read cancel delay read + | None -> + read + in + let write = + match t.delay_write with + | Some delay -> + Delay.apply_write cancel delay single_write_substring + | None -> + single_write_substring + in + observe_rw read write ~f t.kind ~size:t.size data diff --git a/lib/xapi-fd-test/generate.mli b/lib/xapi-fd-test/generate.mli new file mode 100644 index 00000000000..6aba67c7a6d --- /dev/null +++ b/lib/xapi-fd-test/generate.mli @@ -0,0 +1,87 @@ +(* + * Copyright (C) 2023 Cloud Software Group + * + * 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 Xapi_fdcaps +open Properties +open Operations +open Observations + +(** file descriptor behaviour specification *) +type t = { + size: int + ; delay_read: Delay.t option + ; delay_write: Delay.t option + ; kind: Unix.file_kind +} + +val timeouts : float QCheck2.Gen.t +(** [timeouts] is a generator for small timeouts *) + +val make : + size:int + -> delay_read:Delay.t option + -> delay_write:Delay.t option + -> Unix.file_kind + -> t +(** [make ~size ~delay_read ~delay_write kind] is a file descriptor test. + + @param size the size of the file, or the amount of data sent on a socket/pipe + @param delay_read whether to insert sleeps to trigger short reads + @param delay_write whether to insert sleeps to trigger short writes + @param kind the {!type:Unix.file_kind} of the file descriptor to create +*) + +val t : t QCheck2.Gen.t +(** [t] is a {!mod:QCheck2} generator for {!type:t}. + + This doesn't yet open any file descriptors (there'd be too many leaks and we'd run out), + that is done by {!val:run} + + Follows the naming convention to name generators after the type they generate. +*) + +val print : t QCheck2.Print.t +(** [print] is a QCheck2 pretty printer for [t] *) + +val run_ro : + t + -> string + -> f:(([< readable > `rdonly], kind) make -> 'a) + -> (unit, [> wronly] observation option) observations * 'a or_exn +(** [run_ro t data ~f] creates a file descriptor according to [t] and calls the function under test [f]. + The file descriptor should be treated as readonly. + + @returns observations about [f]'s actions the file descriptor +*) + +val run_wo : + t + -> f:(([< writable > `wronly], kind) make -> 'a) + -> ([> rdonly] observation option, unit) observations * 'a or_exn +(** [run_wo t ~f] creates a file descriptor according to [t] and calls the function under test [f]. + The file descriptor should be treated as writeonly. + + @returns observations about [f]'s actions on the file descriptor +*) + +val run_rw : + t + -> string + -> f:((rdwr, kind) make -> 'a) + -> ([> rdonly] observation option, [> wronly] observation option) observations + * 'a or_exn +(** [run_rw t data ~f] creates a file descriptor according to [t] and calls the function under test [f]. + The file descriptor should be treated as read-write. + + @returns observations about [f]'s actions the file descriptor +*) From 78ec02fa44def47f9129da2f156e3e7819b6b362 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 22 Dec 2023 17:27:25 +0000 Subject: [PATCH 30/65] CP-47001: [unixext-test]: add quickcheck-style test MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Uses 'xapi_fd_test'. Signed-off-by: Edwin Török --- .../lib/xapi-stdext-unix/test/dune | 13 ++ .../lib/xapi-stdext-unix/test/generate.mli | 0 .../lib/xapi-stdext-unix/test/unixext_test.ml | 163 ++++++++++++++++++ .../xapi-stdext-unix/test/unixext_test.mli | 0 4 files changed, 176 insertions(+) create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/generate.mli create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.mli diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune new file mode 100644 index 00000000000..7c86c6371d4 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune @@ -0,0 +1,13 @@ +(test + (name unixext_test) + (modules unixext_test) + (libraries xapi_stdext_unix qcheck-core mtime.clock.os qcheck-core.runner fmt xapi_fd_test mtime threads.posix rresult) + ; use fixed seed to avoid causing random failures in CI and package builds + (action (run %{test} -v -bt --seed 42)) +) + +(rule + (alias stresstest) + ; use default random seed on stresstests + (action (run %{dep:unixext_test.exe} -v -bt)) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/generate.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/generate.mli new file mode 100644 index 00000000000..e69de29bb2d 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 new file mode 100644 index 00000000000..d1d467168e9 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/unixext_test.ml @@ -0,0 +1,163 @@ +open QCheck2 +open Xapi_stdext_unix +open Xapi_fd_test + +let expect_string ~expected ~actual = + if not (String.equal expected actual) then + Test.fail_reportf "Data sent and observed do not match: %S <> %S" expected + actual + +let expect_amount ~expected observation = + let open Observations in + let actual = String.length observation.data in + if expected <> actual then + Test.fail_reportf + "Amount of data available and transferred does not match: %d <> %d;@,%a" + expected actual pp observation + +let skip_blk = function + | Unix.S_BLK -> + if Unix.geteuid () <> 0 then + QCheck2.assume_fail () + | _ -> + () + +let skip_dirlnk = function + | Unix.S_DIR | Unix.S_LNK -> + QCheck2.assume_fail () + | _ -> + () + +(* +let pp_pair = + let open Observations in + Fmt.(record + [ field "read" (fun t -> t.read) pp + ; field "write" (fun t -> t.write) pp + ; field "elapsed" (fun t -> t.elapsed) Mtime.Span.pp + ] + ) +*) + +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_dirlnk behaviour.kind ; + try + let test_elapsed = ref Mtime.Span.zero in + let test wrapped_fd = + let len = behaviour.size in + let buf = String.init len (fun i -> Char.chr (i mod 255)) in + let fd = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd in + Unix.set_nonblock fd ; + let dt = Mtime_clock.counter () in + let deadline = Unix.gettimeofday () +. timeout in + let finally () = test_elapsed := Mtime_clock.count dt in + Fun.protect ~finally (fun () -> + Unixext.time_limited_write_substring fd len buf deadline + ) ; + 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 + let elapsed_s = Mtime.Span.to_float_ns !test_elapsed *. 1e-9 in + if elapsed_s > timeout +. 0.5 then + Test.fail_reportf + "Function duration significantly exceeds timeout: %f > %f; %s" + elapsed_s timeout + (Fmt.to_to_string Fmt.(option pp) observations.Observations.read) ; + match (observations, result) with + | {read= Some read; _}, Ok expected -> + (* expected is the input given to [time_limited_write_substring] *) + expect_amount ~expected:(String.length expected) read ; + expect_string ~expected ~actual:read.data + | {read= Some read; _}, Error (`Exn_trap (Unixext.Timeout, _)) -> + let elapsed_s = Mtime.Span.to_float_ns !test_elapsed *. 1e-9 in + if elapsed_s < timeout then + Test.fail_reportf "Timed out earlier than requested: %f < %f" + elapsed_s timeout ; + let actual = String.length read.data in + if actual >= behaviour.size then + Test.fail_reportf "Timed out, but transferred enough data: %d >= %d" + actual behaviour.size + | ( {read= Some read; _} + , Error (`Exn_trap (Unix.Unix_error (Unix.EPIPE, _, _), _)) ) -> + if String.length read.data = behaviour.size then + Test.fail_reportf + "Transferred exact amount, shouldn't have tried to send more: %d" + behaviour.size + | {read= None; _}, _ -> + () + | _, Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + in + true + with e -> + Format.eprintf "Error: %a@." Fmt.exn_backtrace + (e, Printexc.get_raw_backtrace ()) ; + false + +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 ; + 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 + Unix.set_nonblock fd ; + let dt = Mtime_clock.counter () in + let deadline = Unix.gettimeofday () +. timeout in + let finally () = test_elapsed := Mtime_clock.count dt in + Fun.protect ~finally (fun () -> + 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 + in + let () = + let open Observations in + let elapsed_s = Mtime.Span.to_float_ns !test_elapsed *. 1e-9 in + if elapsed_s > timeout +. 0.5 then + Test.fail_reportf + "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 ; + expect_string ~expected:write.data ~actual + | {write= Some _; _}, Error (`Exn_trap (Unixext.Timeout, _)) -> + let elapsed_s = Mtime.Span.to_float_ns !test_elapsed *. 1e-9 in + if elapsed_s < timeout then + Test.fail_reportf "Timed out earlier than requested: %f < %f" + elapsed_s timeout + | ( {write= Some write; _} + , Error (`Exn_trap (Unix.Unix_error (Unix.EPIPE, _, _), _)) ) -> + if String.length write.data = behaviour.size then + Test.fail_reportf + "Transferred exact amount, shouldn't have tried to send more: %d" + behaviour.size + | {write= None; _}, _ -> + () + | _, Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + in + true + +let tests = [test_time_limited_write; test_time_limited_read] + +let () = + (* avoid SIGPIPE *) + let (_ : Sys.signal_behavior) = Sys.signal Sys.sigpipe Sys.Signal_ignore in + QCheck_base_runner.run_tests_main tests 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 new file mode 100644 index 00000000000..e69de29bb2d From de2613e71c66ac76559ddec9a73af48db1a503c5 Mon Sep 17 00:00:00 2001 From: Steven Woods Date: Tue, 14 Feb 2023 13:38:31 +0000 Subject: [PATCH 31/65] CP-47001: Add unit tests for threadext MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Steven Woods Signed-off-by: Edwin Török --- dune-project | 1 + .../xapi-stdext/lib/xapi-stdext-threads/dune | 6 ++++ .../lib/xapi-stdext-threads/threadext_test.ml | 35 +++++++++++++++++++ .../xapi-stdext-threads/threadext_test.mli | 0 xapi-stdext-threads.opam | 1 + 5 files changed, 43 insertions(+) create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.ml create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.mli diff --git a/dune-project b/dune-project index 44b3b3c6722..5c037744405 100644 --- a/dune-project +++ b/dune-project @@ -336,6 +336,7 @@ base-unix (odoc :with-doc) (xapi-stdext-pervasives (= :version)) + (mtime :with-test) ) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune index fe2cc6dd85a..a3b4d9f8609 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune @@ -1,8 +1,14 @@ (library (public_name xapi-stdext-threads) (name xapi_stdext_threads) + (modules :standard \ threadext_test) (libraries threads.posix unix xapi-stdext-pervasives) ) +(test + (name threadext_test) + (modules threadext_test) + (libraries xapi_stdext_threads alcotest mtime.clock.os mtime fmt) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.ml new file mode 100644 index 00000000000..c21cd62e8c0 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.ml @@ -0,0 +1,35 @@ +(* + * 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. + *) + +module Delay = Xapi_stdext_threads.Threadext.Delay + +let span_approx ~max_error = + let eq_within a b = + let diff = Mtime.Span.abs_diff a b in + Mtime.Span.compare diff max_error < 0 + in + Alcotest.testable Mtime.Span.pp @@ eq_within + +let test_wait () = + let m = Delay.make () in + let c = Mtime_clock.counter () in + let time = 1 in + let expected = Mtime.Span.(time * s) in + let max_error = Mtime.Span.(10 * ms) in + let _ = Delay.wait m (float_of_int time) in + let wait_time = Mtime_clock.count c in + Alcotest.check' (span_approx ~max_error) ~msg:"diff is smaller than max error" + ~expected ~actual:wait_time + +let () = Alcotest.run "Threadext" [("wait", [("wait", `Quick, test_wait)])] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext_test.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index 09449f30273..e6ad1798938 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -13,6 +13,7 @@ depends: [ "base-unix" "odoc" {with-doc} "xapi-stdext-pervasives" {= version} + "mtime" {with-test} ] build: [ ["dune" "subst"] {dev} From 8ef9fa57a0555df36f92a949a5d4742738c82128 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 30 Jan 2024 22:34:43 +0000 Subject: [PATCH 32/65] CP-47001: [unixext-test]: add test for Unixext.proxy 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-unix/test/unixext_test.ml | 34 ++++++++++++++++++- 1 file changed, 33 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 d1d467168e9..2acad9396fd 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 @@ -155,7 +155,39 @@ let test_time_limited_read = in true -let tests = [test_time_limited_write; test_time_limited_read] +let test_proxy = + let gen = Generate.t and print = Generate.print in + Test.make ~name:__FUNCTION__ ~print gen @@ fun behaviour -> + if behaviour.kind <> Unix.S_SOCK then + QCheck2.assume_fail () ; + let test wrapped_fd = + let buf = String.init behaviour.size (fun i -> Char.chr (i mod 255)) in + let fd = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd in + let test2 wrapped_fd2 = + let fd2 = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd2 in + Unixext.proxy (Unix.dup fd) (Unix.dup fd2) + in + match Generate.run_rw behaviour buf ~f:test2 with + | _, Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + | obs, Ok () -> + obs + in + let buf' = + String.init behaviour.size (fun i -> Char.chr ((30 + i) mod 255)) + in + match Generate.run_rw behaviour buf' ~f:test with + | _, Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + | {read= None; _}, Ok _ -> + false + | _, Ok {write= None; _} -> + false + | {read= Some write; _}, Ok {write= Some read; _} -> + expect_string ~expected:write.data ~actual:read.data ; + true + +let tests = [test_proxy; test_time_limited_write; test_time_limited_read] let () = (* avoid SIGPIPE *) From 801bb4f5745efd64f34bd59a8cc5a661dcec77a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 21 Nov 2023 09:02:15 +0000 Subject: [PATCH 33/65] Unix.time_limited_write: fix timeout behaviour on >64KiB writes/reads MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `Unix.write` would internally loop until the desired number of bytes are sent, or `EAGAIN`/`EWOULDBLOCK`/another error is reached. It cannot check for timeouts because it is not aware that we'd want one. For pipes and sockets in non-blocking mode this wouldn't be a problem, but this function is often called with block devices too. However according to `pselect(3p)` it is a no-op on regular files: "File descriptors associated with regular files shall always select true for ready to read, ready to write, and error conditions." And the behaviour on block devices is left unspecified by POSIX, and `select(2)` on Linux doesn't document the behaviour either: "The pselect() and select() functions shall support regular files, terminal and pseudo‐terminal devices, STREAMS‐based files, FIFOs, pipes, and sockets. The behavior of pselect() and select() on file descriptors that refer to other types of file is unspecified" Although timeouts for a completely stuck block device cannot be implemented, we can still implement timeouts for a *slow* block device. Use `Unix.single_{write,read}` instead which gives full control of the iteration to the caller. The only way to interrupt stuck IO on a block device or regular file would be to use a separate process and `SIGKILL` it after a timeout (this is what `block_device_io` in XAPI does). These approaches do not work: * `alarm` or `setitimer` would only interrupt one thread in a multi-threaded program. * `pthread_kill` can be used to send a signal to a particular thread, but that requires `EINTR` behaviour on syscalls to be enabled * XAPI expects `SA_RESTART` semantics from syscalls, and would fail an assertion if it ever sees `EINTR` in some paths, so although the syscall *would* get interrupted, it'd also immediately resume without giving the caller a chance to check for timeouts * even if it'd work there are no bindings to `pthread_kill` in OCaml Signed-off-by: Edwin Török --- ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 4cf628d45e9..e6d1f99ac22 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -562,11 +562,11 @@ let time_limited_write_internal raise Timeout let time_limited_write filedesc length data target_response_time = - time_limited_write_internal Unix.write filedesc length data + time_limited_write_internal Unix.single_write filedesc length data target_response_time let time_limited_write_substring filedesc length data target_response_time = - time_limited_write_internal Unix.write_substring filedesc length data + time_limited_write_internal Unix.single_write_substring filedesc length data target_response_time (* Read as many bytes to a file descriptor as possible before a given clock time. *) From 319b82b6fa72e018bf68d28b82c6a1f166a59b29 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 21 Nov 2023 11:07:09 +0000 Subject: [PATCH 34/65] Unix.time_limited_{read,write}: replace select with Polly MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 'select' has a hardcoded limit of 1024 file descriptors. Signed-off-by: Edwin Török --- dune-project | 1 + .../xapi-stdext/lib/xapi-stdext-unix/dune | 2 + .../lib/xapi-stdext-unix/unixext.ml | 105 ++++++++++++------ xapi-stdext-unix.opam | 3 +- xapi-stdext-unix.opam.template | 2 +- 5 files changed, 79 insertions(+), 34 deletions(-) diff --git a/dune-project b/dune-project index 5c037744405..0c9c6712bac 100644 --- a/dune-project +++ b/dune-project @@ -350,6 +350,7 @@ (odoc :with-doc) xapi-backtrace (xapi-stdext-pervasives (= :version)) + polly ) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune index da0b509d2d2..de736b3fdd2 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune @@ -3,8 +3,10 @@ (public_name xapi-stdext-unix) (libraries fd-send-recv + polly unix xapi-backtrace + threads.posix xapi-stdext-pervasives) (foreign_stubs (language c) 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 e6d1f99ac22..42df0b510b9 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -422,6 +422,11 @@ let string_of_signal x = else Printf.sprintf "(ocaml signal %d with an unknown name)" x +let with_polly f = + let polly = Polly.create () in + let finally () = Polly.close polly in + Xapi_stdext_pervasives.Pervasiveext.finally (fun () -> f polly) finally + 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] *) @@ -528,32 +533,69 @@ let really_read_string fd length = exception Timeout +let to_milliseconds ms = ms *. 1000. |> ceil |> int_of_float + +(* Allocating a new polly and waiting like this results in at least 3 syscalls. + An alternative for sockets would be to use [setsockopt], + but that would need 3 system calls too: + + [fstat] to check that it is not a pipe + (you'd risk getting stuck forever without [select/poll/epoll] there) + [setsockopt_float] to set the timeout + [clear_nonblock] to ensure the socket is non-blocking +*) +let with_polly_wait kind fd f = + match Unix.(LargeFile.fstat fd).st_kind with + | S_DIR -> + failwith "File descriptor cannot be a directory for read/write" + | S_LNK -> + (* should never happen, the file is already open and OCaml doesn't support O_SYMLINK to open the link itself *) + failwith "cannot read/write into a symbolic link" + | S_REG | S_BLK -> + (* the best we can do is to split up the read/write operation into 64KiB chunks, + and check the timeout after each chunk. + select() would've silently succeeded here, whereas epoll() is stricted and returns EPERM + *) + let wait remaining_time = if remaining_time < 0. then raise Timeout in + f wait fd + | S_CHR | S_FIFO | S_SOCK -> + with_polly @@ fun polly -> + Polly.add polly fd kind ; + let wait remaining_time = + let milliseconds = to_milliseconds remaining_time in + if milliseconds <= 0 then raise Timeout ; + let ready = + Polly.wait polly 1 milliseconds @@ fun _ event_on_fd _ -> + assert (event_on_fd = fd) + in + if ready = 0 then raise Timeout + in + f wait fd + (* Write as many bytes to a file descriptor as possible from data before a given clock time. *) (* Raises Timeout exception if the number of bytes written is less than the specified length. *) (* Writes into the file descriptor at the current cursor position. *) let time_limited_write_internal (write : Unix.file_descr -> 'a -> int -> int -> int) filedesc length data target_response_time = + with_polly_wait Polly.Events.out filedesc @@ fun wait filedesc -> let total_bytes_to_write = length in let bytes_written = ref 0 in let now = ref (Unix.gettimeofday ()) in while !bytes_written < total_bytes_to_write && !now < target_response_time do let remaining_time = target_response_time -. !now in - let _, ready_to_write, _ = Unix.select [] [filedesc] [] remaining_time in - (* Note: there is a possibility that the storage could go away after the select and before the write, so the write would block. *) - ( if List.mem filedesc ready_to_write then - let bytes_to_write = total_bytes_to_write - !bytes_written in - let bytes = - try write filedesc data !bytes_written bytes_to_write - with - | Unix.Unix_error (Unix.EAGAIN, _, _) - | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) - -> - 0 - in - (* write from buffer=data from offset=bytes_written, length=bytes_to_write *) - bytes_written := bytes + !bytes_written - ) ; + wait remaining_time ; + let bytes_to_write = total_bytes_to_write - !bytes_written in + let bytes = + try write filedesc data !bytes_written bytes_to_write + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + -> + 0 + in + (* write from buffer=data from offset=bytes_written, length=bytes_to_write *) + bytes_written := bytes + !bytes_written ; now := Unix.gettimeofday () done ; if !bytes_written = total_bytes_to_write then @@ -573,29 +615,28 @@ let time_limited_write_substring filedesc length data target_response_time = (* Raises Timeout exception if the number of bytes read is less than the desired number. *) (* Reads from the file descriptor at the current cursor position. *) let time_limited_read filedesc length target_response_time = + with_polly_wait Polly.Events.inp filedesc @@ fun wait filedesc -> let total_bytes_to_read = length in let bytes_read = ref 0 in let buf = Bytes.make total_bytes_to_read '\000' in let now = ref (Unix.gettimeofday ()) in while !bytes_read < total_bytes_to_read && !now < target_response_time do let remaining_time = target_response_time -. !now in - let ready_to_read, _, _ = Unix.select [filedesc] [] [] remaining_time in - ( if List.mem filedesc ready_to_read then - let bytes_to_read = total_bytes_to_read - !bytes_read in - let bytes = - try Unix.read filedesc buf !bytes_read bytes_to_read - with - | Unix.Unix_error (Unix.EAGAIN, _, _) - | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) - -> - 0 - in - (* read into buffer=buf from offset=bytes_read, length=bytes_to_read *) - if bytes = 0 then - raise End_of_file (* End of file has been reached *) - else - bytes_read := bytes + !bytes_read - ) ; + wait remaining_time ; + let bytes_to_read = total_bytes_to_read - !bytes_read in + let bytes = + try Unix.read filedesc buf !bytes_read bytes_to_read + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + -> + 0 + in + (* read into buffer=buf from offset=bytes_read, length=bytes_to_read *) + if bytes = 0 then + raise End_of_file (* End of file has been reached *) + else + bytes_read := bytes + !bytes_read ; now := Unix.gettimeofday () done ; if !bytes_read = total_bytes_to_read then diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index b067d6d030b..36df8e943d8 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -14,6 +14,7 @@ depends: [ "odoc" {with-doc} "xapi-backtrace" "xapi-stdext-pervasives" {= version} + "polly" ] build: [ ["dune" "subst"] {dev} @@ -31,4 +32,4 @@ build: [ ] dev-repo: "git+https://github.com/xapi-project/xen-api.git" depexts: ["linux-headers"] {os-distribution = "alpine"} -available: [ os = "macos" | os = "linux" ] +available: [ os = "linux" ] diff --git a/xapi-stdext-unix.opam.template b/xapi-stdext-unix.opam.template index ae75bf72ee5..ae1fb3e0f99 100644 --- a/xapi-stdext-unix.opam.template +++ b/xapi-stdext-unix.opam.template @@ -1,2 +1,2 @@ depexts: ["linux-headers"] {os-distribution = "alpine"} -available: [ os = "macos" | os = "linux" ] +available: [ os = "linux" ] From 8736e5d9f65ac4d7eeee3225cf6824ccd7bf669e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 28 Nov 2023 17:17:46 +0000 Subject: [PATCH 35/65] add Unixext.time_limited_single_read MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It is too easy to misuse Unixext.time_limited_read because that one takesan absolute timestamp as parameter, not a relative one. Introduce a new function that takes a relative time as parameter, and doesn't loop. Signed-off-by: Edwin Török --- .../xapi-stdext/lib/xapi-stdext-unix/unixext.ml | 14 ++++++++++++++ .../xapi-stdext/lib/xapi-stdext-unix/unixext.mli | 3 +++ 2 files changed, 17 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 42df0b510b9..3c6bada784c 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -644,6 +644,20 @@ let time_limited_read filedesc length target_response_time = else (* we ran out of time *) raise Timeout +let time_limited_single_read filedesc length ~max_wait = + let buf = Bytes.make length '\000' in + with_polly_wait Polly.Events.inp filedesc @@ fun wait filedesc -> + wait max_wait ; + let bytes = + try Unix.read filedesc buf 0 length + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + -> + 0 + in + Bytes.sub_string buf 0 bytes + (* --------------------------------------------------------------------------------------- *) (* 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 c6168150b54..df81171a3b4 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli @@ -153,6 +153,9 @@ val time_limited_write_substring : val time_limited_read : Unix.file_descr -> int -> float -> string +val time_limited_single_read : + Unix.file_descr -> int -> max_wait:float -> string + val read_data_in_string_chunks : (string -> int -> unit) -> ?block_size:int From b0935423d763f13f895aee33c44b4d6c6684a413 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 21 Nov 2023 15:00:42 +0000 Subject: [PATCH 36/65] CP-32622: replace select with Thread.delay MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 3c6bada784c..1b58ff8b3f1 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -383,7 +383,7 @@ let kill_and_wait ?(signal = Sys.sigterm) ?(timeout = 10.) pid = let cmdline = readcmdline pid in if cmdline = reference then ( (* still up, let's sleep a bit *) - ignore (Unix.select [] [] [] loop_time_waiting) ; + Thread.delay loop_time_waiting ; left := !left -. loop_time_waiting ) else (* not the same, it's gone ! *) quit := true From bcae6f5eb6d8eb88db96475cd26cecdbd8a7a34c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 21 Nov 2023 15:39:40 +0000 Subject: [PATCH 37/65] CP-32622: Delay: replace select with time_limited_read MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- dune-project | 1 + ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune | 1 + .../xapi-stdext/lib/xapi-stdext-threads/threadext.ml | 10 +++++++--- xapi-stdext-threads.opam | 1 + 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/dune-project b/dune-project index 0c9c6712bac..a43ca18d1a7 100644 --- a/dune-project +++ b/dune-project @@ -337,6 +337,7 @@ (odoc :with-doc) (xapi-stdext-pervasives (= :version)) (mtime :with-test) + (xapi-stdext-unix (= :version)) ) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune index a3b4d9f8609..4db49ea52e2 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune @@ -5,6 +5,7 @@ (libraries threads.posix unix + xapi-stdext-unix xapi-stdext-pervasives) ) (test 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 56025d51154..ef30cfb5ba4 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml @@ -86,11 +86,15 @@ module Delay = struct pipe_out ) in - let r, _, _ = Unix.select [pipe_out] [] [] seconds in + let open Xapi_stdext_unix.Unixext in (* flush the single byte from the pipe *) - if r <> [] then ignore (Unix.read pipe_out (Bytes.create 1) 0 1) ; + try + let (_ : string) = + time_limited_single_read pipe_out 1 ~max_wait:seconds + in + false + with Timeout -> true (* return true if we waited the full length of time, false if we were woken *) - r = [] with Pre_signalled -> false ) (fun () -> diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index e6ad1798938..8de2f45c03e 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -14,6 +14,7 @@ depends: [ "odoc" {with-doc} "xapi-stdext-pervasives" {= version} "mtime" {with-test} + "xapi-stdext-unix" {= version} ] build: [ ["dune" "subst"] {dev} From 1c374c2ffcc63026810e1552f1dc5ff94fc6fe61 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 26 Jan 2024 15:11:47 +0000 Subject: [PATCH 38/65] CP-32622: replace select in proxy with polly 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-unix/unixext.ml | 42 ++++++++++++------- 1 file changed, 28 insertions(+), 14 deletions(-) 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 1b58ff8b3f1..160cfe46b67 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -434,24 +434,38 @@ let proxy (a : Unix.file_descr) (b : Unix.file_descr) = let a' = CBuf.empty size and b' = CBuf.empty size in Unix.set_nonblock a ; Unix.set_nonblock b ; + with_polly @@ fun polly -> + Polly.add polly a Polly.Events.empty ; + Polly.add polly b Polly.Events.empty ; 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 [] + (* use oneshot notification so that we can use Polly.mod as needed to reenable, + but it will disable itself each turn *) + let a_events = + Polly.Events.( + (if CBuf.should_read a' then inp lor oneshot else empty) + lor if CBuf.should_write b' then out lor oneshot else empty + ) + and b_events = + Polly.Events.( + (if CBuf.should_read b' then inp lor oneshot else empty) + lor if CBuf.should_write a' then out lor oneshot else empty + ) 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 Polly.Events.(a_events lor b_events = empty) then raise End_of_file ; + + if Polly.Events.(a_events <> empty) then + Polly.upd polly a a_events ; + if Polly.Events.(b_events <> empty) then + Polly.upd polly b b_events ; + Polly.wait_fold polly 4 (-1) () (fun _polly fd events () -> + (* Do the writing before the reading *) + if Polly.Events.(test out events) then + if a = fd then CBuf.write b' a else CBuf.write a' b ; + if Polly.Events.(test inp events) then + if a = fd then CBuf.read a' a else CBuf.read b' b + ) ; (* If there's nothing else to read or write then signal the other end *) List.iter (fun (buf, fd) -> From 3f9472c98420403463930790d1c3ddb7cfcc8c2c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 15 Apr 2024 10:45:01 +0100 Subject: [PATCH 39/65] CP-32622: move new libraries to proper subdir MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/dune | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/generate.ml | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/generate.mli | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/observations.ml | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/observations.mli | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/test/dune | 0 .../libs/xapi-stdext/lib}/xapi-fd-test/test/test_xapi_fd_test.ml | 0 .../libs/xapi-stdext/lib}/xapi-fd-test/test/test_xapi_fd_test.mli | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/dune | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/operations.ml | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/operations.mli | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/properties.ml | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/properties.mli | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/safefd.ml | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/safefd.mli | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/dune | 0 {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/properties.t | 0 .../libs/xapi-stdext/lib}/xapi-fdcaps/test/test_operations.ml | 0 .../libs/xapi-stdext/lib}/xapi-fdcaps/test/test_operations.mli | 0 .../libs/xapi-stdext/lib}/xapi-fdcaps/test/test_properties.ml | 0 .../libs/xapi-stdext/lib}/xapi-fdcaps/test/test_properties.mli | 0 .../libs/xapi-stdext/lib}/xapi-fdcaps/test/test_safefd.ml | 0 .../libs/xapi-stdext/lib}/xapi-fdcaps/test/test_safefd.mli | 0 23 files changed, 0 insertions(+), 0 deletions(-) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/dune (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/generate.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/generate.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/observations.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/observations.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/test/dune (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/test/test_xapi_fd_test.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fd-test/test/test_xapi_fd_test.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/dune (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/operations.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/operations.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/properties.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/properties.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/safefd.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/safefd.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/dune (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/properties.t (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/test_operations.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/test_operations.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/test_properties.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/test_properties.mli (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/test_safefd.ml (100%) rename {lib => ocaml/libs/xapi-stdext/lib}/xapi-fdcaps/test/test_safefd.mli (100%) diff --git a/lib/xapi-fd-test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune similarity index 100% rename from lib/xapi-fd-test/dune rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/dune diff --git a/lib/xapi-fd-test/generate.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml similarity index 100% rename from lib/xapi-fd-test/generate.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.ml diff --git a/lib/xapi-fd-test/generate.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli similarity index 100% rename from lib/xapi-fd-test/generate.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/generate.mli diff --git a/lib/xapi-fd-test/observations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml similarity index 100% rename from lib/xapi-fd-test/observations.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.ml diff --git a/lib/xapi-fd-test/observations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli similarity index 100% rename from lib/xapi-fd-test/observations.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/observations.mli diff --git a/lib/xapi-fd-test/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/dune similarity index 100% rename from lib/xapi-fd-test/test/dune rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/dune diff --git a/lib/xapi-fd-test/test/test_xapi_fd_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.ml similarity index 100% rename from lib/xapi-fd-test/test/test_xapi_fd_test.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.ml diff --git a/lib/xapi-fd-test/test/test_xapi_fd_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.mli similarity index 100% rename from lib/xapi-fd-test/test/test_xapi_fd_test.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fd-test/test/test_xapi_fd_test.mli diff --git a/lib/xapi-fdcaps/dune b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/dune similarity index 100% rename from lib/xapi-fdcaps/dune rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/dune diff --git a/lib/xapi-fdcaps/operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml similarity index 100% rename from lib/xapi-fdcaps/operations.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.ml diff --git a/lib/xapi-fdcaps/operations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli similarity index 100% rename from lib/xapi-fdcaps/operations.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/operations.mli diff --git a/lib/xapi-fdcaps/properties.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.ml similarity index 100% rename from lib/xapi-fdcaps/properties.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.ml diff --git a/lib/xapi-fdcaps/properties.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.mli similarity index 100% rename from lib/xapi-fdcaps/properties.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/properties.mli diff --git a/lib/xapi-fdcaps/safefd.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.ml similarity index 100% rename from lib/xapi-fdcaps/safefd.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.ml diff --git a/lib/xapi-fdcaps/safefd.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.mli similarity index 100% rename from lib/xapi-fdcaps/safefd.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/safefd.mli diff --git a/lib/xapi-fdcaps/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune similarity index 100% rename from lib/xapi-fdcaps/test/dune rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune diff --git a/lib/xapi-fdcaps/test/properties.t b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/properties.t similarity index 100% rename from lib/xapi-fdcaps/test/properties.t rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/properties.t diff --git a/lib/xapi-fdcaps/test/test_operations.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml similarity index 100% rename from lib/xapi-fdcaps/test/test_operations.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.ml diff --git a/lib/xapi-fdcaps/test/test_operations.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.mli similarity index 100% rename from lib/xapi-fdcaps/test/test_operations.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_operations.mli diff --git a/lib/xapi-fdcaps/test/test_properties.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.ml similarity index 100% rename from lib/xapi-fdcaps/test/test_properties.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.ml diff --git a/lib/xapi-fdcaps/test/test_properties.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.mli similarity index 100% rename from lib/xapi-fdcaps/test/test_properties.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_properties.mli diff --git a/lib/xapi-fdcaps/test/test_safefd.ml b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.ml similarity index 100% rename from lib/xapi-fdcaps/test/test_safefd.ml rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.ml diff --git a/lib/xapi-fdcaps/test/test_safefd.mli b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.mli similarity index 100% rename from lib/xapi-fdcaps/test/test_safefd.mli rename to ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/test_safefd.mli From 22d20eda87d200743aeb46a1db282e25ce9735e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 12 Apr 2024 17:42:21 +0100 Subject: [PATCH 40/65] IH-543: Add IPMI DCMI based power reading rrdd plugin MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Guard against buggy firmware by ignoring 0 or 65535 Watts (although xcp-rrdd doesn't actually correctly ignore these yet). Future-proof plugin by parsing Watts as float, although currently it is always an integer in the DCMI spec. Signed-off-by: Edwin Török --- Makefile | 1 + ocaml/xcp-rrdd/bin/rrdp-dcmi/dune | 16 ++++ ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.ml | 80 +++++++++++++++++++ ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.mli | 0 .../bin/rrdp-scripts/sysconfig-rrdd-plugins | 2 +- 5 files changed, 98 insertions(+), 1 deletion(-) create mode 100644 ocaml/xcp-rrdd/bin/rrdp-dcmi/dune create mode 100644 ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.ml create mode 100644 ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.mli diff --git a/Makefile b/Makefile index a57871a5c4e..c43c9aaba44 100644 --- a/Makefile +++ b/Makefile @@ -202,6 +202,7 @@ install: build doc sdk doc-json install -D -m 755 _build/install/default/bin/xcp-rrdd-iostat $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-iostat install -D -m 755 _build/install/default/bin/xcp-rrdd-squeezed $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-squeezed install -D -m 755 _build/install/default/bin/xcp-rrdd-xenpm $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-xenpm + install -D -m 755 _build/install/default/bin/xcp-rrdd-dcmi $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-dcmi install -D -m 644 ocaml/xcp-rrdd/bugtool-plugin/rrdd-plugins.xml $(DESTDIR)$(ETCXENDIR)/bugtool/xcp-rrdd-plugins.xml install -D -m 644 ocaml/xcp-rrdd/bugtool-plugin/rrdd-plugins/stuff.xml $(DESTDIR)$(ETCXENDIR)/bugtool/xcp-rrdd-plugins/stuff.xml install -D -m 755 ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins $(DESTDIR)/etc/sysconfig/xcp-rrdd-plugins diff --git a/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune b/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune new file mode 100644 index 00000000000..0f438a65861 --- /dev/null +++ b/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune @@ -0,0 +1,16 @@ +(executable + (modes exe) + (name rrdp_dcmi) + (package rrdd-plugins) + (public_name xcp-rrdd-dcmi) + (libraries + dune-build-info + rrdd-plugin + rrdd-plugins.libs + xapi-idl.rrd + xapi-log + xapi-rrd + astring + ) +) + diff --git a/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.ml b/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.ml new file mode 100644 index 00000000000..03afac48bc7 --- /dev/null +++ b/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.ml @@ -0,0 +1,80 @@ +(* + * Copyright (c) 2024 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. + *) + +(** Read power measurements from IPMI DCMI where available. + There is also IPMI SDR entity 21 that returns the same information (power consumption in watts), + but isn't always available, and seems to be slower to read, especially when missing. + *) + +open Rrdd_plugin + +module Process = Process (struct let name = "xcp-rrdd-dcmi" end) + +open Process + +let ipmitool_bin = "/usr/bin/ipmitool" + +let ipmitool args = + (* we connect to the local /dev/ipmi0 if available to read measurements from local BMC *) + ipmitool_bin :: "-I" :: "open" :: args |> String.concat " " + +let discover () = + Utils.exec_cmd + (module Process.D) + ~cmdstring:(ipmitool ["dcmi"; "discover"]) + ~f:(fun line -> + (* this code runs once on startup, logging all the output here will be useful for debugging *) + D.debug "DCMI discover: %s" line ; + if String.trim line = "Power management available" then + Some () + else + None + ) + +let get_dcmi_power_reading () = + Utils.exec_cmd + (module Process.D) + ~cmdstring:(ipmitool ["dcmi"; "power"; "reading"]) + ~f:(fun line -> + (* example line: ' Instantaneous power reading: 34 Watts' *) + try + Scanf.sscanf line " Instantaneous power reading : %f Watts" Option.some + with Scanf.Scan_failure _ | End_of_file -> None + ) + +let gen_dcmi_power_reading value = + ( Rrd.Host + , Ds.ds_make ~name:"DCMI-power-reading" + ~description:"Host power usage reported by IPMI DCMI" + ~value:(Rrd.VT_Float value) ~ty:Rrd.Gauge ~default:true ~units:"W" + ~min:Float.min_float ~max:65534. () + ) + +let generate_dss () = + match get_dcmi_power_reading () with + | watts :: _ -> + [gen_dcmi_power_reading watts] + | _ -> + [] + +let _ = + initialise () ; + match discover () with + | [] -> + D.info "IPMI DCMI power reading is unavailable" ; + exit 1 + | _ -> + D.info "IPMI DCMI power reading is available" ; + main_loop ~neg_shift:0.5 ~target:(Reporter.Local 1) + ~protocol:Rrd_interface.V2 ~dss_f:generate_dss diff --git a/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.mli b/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins b/ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins index 6998ad20c12..ced7c537254 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins +++ b/ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins @@ -1 +1 @@ -PLUGINS="xcp-rrdd-iostat xcp-rrdd-squeezed xcp-rrdd-xenpm" +PLUGINS="xcp-rrdd-iostat xcp-rrdd-squeezed xcp-rrdd-xenpm xcp-rrdd-dcmi" From 916b6e07e9af5efcf0df6540e29bd1f647b21701 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 22 Apr 2024 14:42:49 +0100 Subject: [PATCH 41/65] fixup! scripts/xentrace: detect host CPU spikes and dump xentrace MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fix shellcheck warnings and bugs. Signed-off-by: Edwin Török --- scripts/xe-xentrace | 66 +++++++++++++++++++++------------------------ 1 file changed, 31 insertions(+), 35 deletions(-) diff --git a/scripts/xe-xentrace b/scripts/xe-xentrace index 0c3310ea217..94b51bcf134 100755 --- a/scripts/xe-xentrace +++ b/scripts/xe-xentrace @@ -47,8 +47,8 @@ while getopts "hct:s:M:p:r:" opt ; do esac done -SIZE=$((${SIZE_GB} * 1024 * 1024 * 1024)) -MEMORY=$((${MEMORY_MB} * 1024 * 1024)) +SIZE=$((SIZE_GB * 1024 * 1024 * 1024)) +MEMORY=$((MEMORY_MB * 1024 * 1024)) if [ ! -e @INVENTORY@ ]; then echo Must run on a XAPI host. @@ -59,7 +59,7 @@ fi XE="@OPTDIR@/bin/xe" -crashdump_sr=$(${XE} host-list params=crash-dump-sr-uuid --minimal uuid=${INSTALLATION_UUID}) +crashdump_sr=$(${XE} host-list params=crash-dump-sr-uuid --minimal "uuid=${INSTALLATION_UUID}") if [ -z "${crashdump_sr}" ]; then echo No crashdump storage repository defined for the host. @@ -70,69 +70,65 @@ vdi_date=$(date +%c) vdi_name="Xentrace results at ${vdi_date}" echo -n "Creating VDI: " -vdi_uuid=$(${XE} vdi-create sr-uuid=${crashdump_sr} name-label="${vdi_name}" type=system virtual-size=${SIZE}) -echo ${vdi_uuid} - -if [ $? -ne 0 -o -z "${vdi_uuid}" ]; then +if ! vdi_uuid=$(${XE} vdi-create "sr-uuid=${crashdump_sr}" name-label="${vdi_name}" type=system "virtual-size=${SIZE}") || [ -z "${vdi_uuid}" ]; then echo error creating VDI in the crashdump storage repository exit 1 fi -${XE} vdi-param-set uuid=${vdi_uuid} other-config:xentrace=1 +echo "${vdi_uuid}" + +${XE} vdi-param-set "uuid=${vdi_uuid}" other-config:xentrace=1 mnt= function cleanup { killall xentrace - if [ ! -z "${vdi_uuid}" ]; then - ${XE} vdi-destroy uuid=${vdi_uuid} + if [ -n "${vdi_uuid}" ]; then + ${XE} vdi-destroy "uuid=${vdi_uuid}" fi - if [ ! -z "${mnt}" ]; then - umount ${mnt} - rmdir ${mnt} + if [ -n "${mnt}" ]; then + umount "${mnt}" + rmdir "${mnt}" fi - if [ ! -z "${vbd_uuid}" ]; then - ${XE} vbd-unplug uuid=${vbd_uuid} - ${XE} vbd-destroy uuid=${vbd_uuid} + if [ -n "${vbd_uuid}" ]; then + ${XE} vbd-unplug "uuid=${vbd_uuid}" + ${XE} vbd-destroy "uuid=${vbd_uuid}" fi } echo -n "Creating VBD: " -vbd_uuid=$(${XE} vbd-create vm-uuid=${CONTROL_DOMAIN_UUID} vdi-uuid=${vdi_uuid} device=autodetect) -echo ${vbd_uuid} - -if [ $? -ne 0 -o -z "${vbd_uuid}" ]; then +if ! vbd_uuid=$(${XE} vbd-create "vm-uuid=${CONTROL_DOMAIN_UUID}" "vdi-uuid=${vdi_uuid}" device=autodetect) || [ -z "${vbd_uuid}" ]; then echo error creating VBD cleanup exit 1 fi +echo "${vbd_uuid}" + echo -n "Plugging VBD: " -${XE} vbd-plug uuid=${vbd_uuid} -device=/dev/$(${XE} vbd-param-get uuid=${vbd_uuid} param-name=device) +${XE} vbd-plug "uuid=${vbd_uuid}" +device=/dev/$(${XE} vbd-param-get "uuid=${vbd_uuid}" param-name=device) -if [ ! -b ${device} ]; then - echo ${device}: not a block special +if [ ! -b "${device}" ]; then + echo "${device}: not a block special" cleanup exit 1 fi -echo ${device} +echo "${device}" echo -n "Creating filesystem: " -mkfs.ext3 -j -F ${device} > /dev/null 2>&1 +mkfs.ext3 -j -F "${device}" > /dev/null 2>&1 echo "done" echo -n "Mounting filesystem: " mnt=/var/run/crashdump-${vdi_uuid} -mkdir -p ${mnt} - -mount ${device} ${mnt} +mkdir -p "${mnt}" -if [ $? -ne 0 ]; then - echo mount to ${mnt} failed +if ! mount "${device}" "${mnt}"; then + echo "mount to ${mnt} failed" cleanup exit 1 fi @@ -146,10 +142,10 @@ if [ -n "${DUMP_ON_CPUAVG}" ]; then echo "Xentrace: will dump when triggered for ${REPEAT}*5s intervals in a row" (rrd2csv "AVERAGE:host:${INSTALLATION_UUID}:cpu_avg" \ | (TRIGGER=0 - read IGNORE - while IFS=, read -r time value; do + read -r _IGNORE + while IFS=, read -r _time value; do if (( $(echo "${value} > ${DUMP_ON_CPUAVG}/100" | bc -l) )); then - TRIGGER=$((${TRIGGER} + 1)) + TRIGGER=$((TRIGGER + 1)) else TRIGGER=0 fi @@ -170,7 +166,7 @@ while : ; do echo "Xentrace: in circular mode, waiting for 'killall xentrace'" /usr/sbin/xentrace -D -e all -r 1 "${TRACE}" -M "${MEMORY}" else - /usr/sbin/xentrace -D -e all -r 1 "${TRACE}" -T ${TIME} + /usr/sbin/xentrace -D -e all -r 1 "${TRACE}" -T "${TIME}" fi # do not destroy the VDI anymore, we've got useful data on it From 374b5dc45e5cf69e31d7dee8cf073565b8a2e6e1 Mon Sep 17 00:00:00 2001 From: Steven Woods Date: Wed, 4 Jan 2023 10:50:32 +0000 Subject: [PATCH 42/65] CP-32622: Use Unix.sleepf for sleeps instead of select Signed-off-by: Steven Woods --- ocaml/libs/stunnel/stunnel.ml | 2 +- ocaml/squeezed/src/squeeze_xen.ml | 4 ++-- ocaml/xe-cli/newcli.ml | 2 +- ocaml/xenopsd/cli/xn.ml | 2 +- ocaml/xenopsd/xc/memory_breakdown.ml | 2 +- ocaml/xenopsd/xc/memory_summary.ml | 2 +- 6 files changed, 7 insertions(+), 7 deletions(-) diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index aaaf3dd7d2a..db7bd24c309 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -391,7 +391,7 @@ let rec retry f = function try f () with Stunnel_initialisation_failed -> (* Leave a few seconds between each attempt *) - ignore (Unix.select [] [] [] 3.) ; + Thread.delay 3. ; retry f (n - 1) ) diff --git a/ocaml/squeezed/src/squeeze_xen.ml b/ocaml/squeezed/src/squeeze_xen.ml index f4ba7e5accd..b5303382605 100644 --- a/ocaml/squeezed/src/squeeze_xen.ml +++ b/ocaml/squeezed/src/squeeze_xen.ml @@ -581,7 +581,7 @@ let make_host ~verbose ~xc = 1024L <> 0L do - ignore (Unix.select [] [] [] 0.25) + Thread.delay 0.25 done ; (* Some VMs are considered by us (but not by xen) to have an @@ -857,7 +857,7 @@ let io ~xc ~verbose = (fun domid kib -> execute_action ~xc {Squeeze.action_domid= domid; new_target_kib= kib} ) - ; wait= (fun delay -> ignore (Unix.select [] [] [] delay)) + ; wait= (fun delay -> Thread.delay delay) ; execute_action= (fun action -> execute_action ~xc action) ; target_host_free_mem_kib ; free_memory_tolerance_kib diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index d197b849a94..0e75dbbc877 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -633,7 +633,7 @@ let main_loop ifd ofd permitted_filenames = with | Unix.Unix_error (_, _, _) when !delay <= long_connection_retry_timeout -> - ignore (Unix.select [] [] [] !delay) ; + Unix.sleepf !delay ; delay := !delay *. 2. ; keep_connection () | e -> diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index 0eb6ef5ac1b..74ade92f21e 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -1047,7 +1047,7 @@ let raw_console_proxy sockaddr = (fun () -> Unix.close s) with | Unix.Unix_error (_, _, _) when !delay <= long_connection_retry_timeout -> - ignore (Unix.select [] [] [] !delay) ; + Unix.sleepf !delay ; delay := !delay *. 2. ; keep_connection () | e -> diff --git a/ocaml/xenopsd/xc/memory_breakdown.ml b/ocaml/xenopsd/xc/memory_breakdown.ml index f13d76d41c8..ac37273d388 100644 --- a/ocaml/xenopsd/xc/memory_breakdown.ml +++ b/ocaml/xenopsd/xc/memory_breakdown.ml @@ -246,7 +246,7 @@ let print_memory_field_values xc xs = flush stdout (** Sleeps for the given time period in seconds. *) -let sleep time_period_seconds = ignore (Unix.select [] [] [] time_period_seconds) +let sleep time_period_seconds = Unix.sleepf time_period_seconds (** Prints a header line of memory field names, and then periodically prints a line of memory field values. *) diff --git a/ocaml/xenopsd/xc/memory_summary.ml b/ocaml/xenopsd/xc/memory_summary.ml index 15ddac0098f..c63e495ccb4 100644 --- a/ocaml/xenopsd/xc/memory_summary.ml +++ b/ocaml/xenopsd/xc/memory_summary.ml @@ -36,7 +36,7 @@ let _ = let finished = ref false in while not !finished do finished := !delay < 0. ; - if !delay > 0. then ignore (Unix.select [] [] [] !delay) ; + if !delay > 0. then Unix.sleepf !delay ; flush stdout ; let physinfo = Xenctrl.physinfo xc in let one_page = 4096L in From 760641f3fc5b65aa7ff7b28047047381798f511a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 10 May 2024 17:15:13 +0100 Subject: [PATCH 43/65] CP-47536: drop Unix.select in newcli MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is a followup of this commit: 14fd0c98ef ("CA-226177: Fix premature termination of cli") That commit dropped the active monitoring of stunnel processes, but kept the while-select loop. That loop serves no purpose now, we can instead do a blocking Unix.read directly, and get woken up when a packet arrives (this is the the single-threaded CLI, not the CLI server). Signed-off-by: Edwin Török --- ocaml/xe-cli/newcli.ml | 8 -------- 1 file changed, 8 deletions(-) diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index 0e75dbbc877..50367aee11a 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -463,14 +463,6 @@ let main_loop ifd ofd permitted_filenames = marshal_protocol ofd ; let exit_code = ref None in while !exit_code = None do - (* Wait for input asynchronously so that we can check the status - of Stunnel every now and then, for better debug/dignosis. - *) - while - match Unix.select [ifd] [] [] 5.0 with _ :: _, _, _ -> false | _ -> true - do - () - done ; let cmd = try unmarshal ifd with e -> handle_unmarshal_failure e ifd in debug "Read: %s\n%!" (string_of_message cmd) ; flush stderr ; From f3ca4b0a0bfa5bada9c989f97d288989f3398532 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 23 May 2024 17:31:59 +0100 Subject: [PATCH 44/65] CP-47536: test for Buf_io timeouts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/libs/http-lib/bufio_test.ml | 81 ++++++++++++++++++++++++++++++ ocaml/libs/http-lib/bufio_test.mli | 0 ocaml/libs/http-lib/dune | 28 ++++++++++- 3 files changed, 108 insertions(+), 1 deletion(-) create mode 100644 ocaml/libs/http-lib/bufio_test.ml create mode 100644 ocaml/libs/http-lib/bufio_test.mli diff --git a/ocaml/libs/http-lib/bufio_test.ml b/ocaml/libs/http-lib/bufio_test.ml new file mode 100644 index 00000000000..b35c55381de --- /dev/null +++ b/ocaml/libs/http-lib/bufio_test.ml @@ -0,0 +1,81 @@ +open QCheck2 +open Xapi_fd_test + +let print_timeout = string_of_float + +let expect_string ~expected ~actual = + if not (String.equal expected actual) then + Test.fail_reportf "Data sent and observed do not match: %S <> %S" expected + actual + +let expect_amount ~expected observation = + let open Observations in + let actual = String.length observation.data in + if expected <> actual then + Test.fail_reportf + "Amount of data available and transferred does not match: %d <> %d;@,%a" + expected actual pp observation + +let test_buf_io = + let timeouts = Generate.timeouts in + let gen = Gen.tup2 Generate.t timeouts + and print = Print.tup2 Generate.print print_timeout in + Test.make ~name:__FUNCTION__ ~print gen @@ fun (behaviour, timeout) -> + let timeout_span = Mtime.Span.of_float_ns (timeout *. 1e9) |> Option.get in + (* Format.eprintf "Testing %s@." (print (behaviour, timeout)); *) + if behaviour.kind <> Unix.S_SOCK then + QCheck2.assume_fail () ; + (* we only support sockets for this function *) + 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 + let bio = Buf_io.of_fd fd in + let dt = Mtime_clock.counter () in + let finally () = test_elapsed := Mtime_clock.count dt in + Fun.protect ~finally (fun () -> + Buf_io.really_input_buf bio behaviour.size ~timeout + ) + 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 + in + let () = + let open Observations in + let elapsed = !test_elapsed in + let timeout_extra = + Mtime.Span.(add (timeout_span :> Mtime.Span.t) @@ (500 * ms)) + in + if Mtime.Span.compare elapsed timeout_extra > 0 then + Test.fail_reportf + "Function duration significantly exceeds timeout: %a > %.6f; %s" + Mtime.Span.pp elapsed 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 ; + expect_string ~expected:write.data ~actual + | {write= Some _; _}, Error (`Exn_trap (Buf_io.Timeout, _)) -> + let elapsed = !test_elapsed in + if Mtime.Span.compare elapsed timeout_span < 0 then + Test.fail_reportf "Timed out earlier than requested: %a < %a" + Mtime.Span.pp elapsed Mtime.Span.pp timeout_span + | ( {write= Some write; _} + , Error (`Exn_trap (Unix.Unix_error (Unix.EPIPE, _, _), _)) ) -> + if String.length write.data = behaviour.size then + Test.fail_reportf + "Transferred exact amount, shouldn't have tried to send more: %d" + behaviour.size + | {write= None; _}, _ -> + () + | _, Error (`Exn_trap (e, bt)) -> + Printexc.raise_with_backtrace e bt + in + true + +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 new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index dae6e86e669..9b64daf375f 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)) + (modules (:standard \ http_svr http_proxy server_io http_test radix_tree_test test_client test_server bufio_test)) (preprocess (per_module ((pps ppx_deriving_rpc) Http))) (libraries astring @@ -64,6 +64,32 @@ ) ) +(test + (name bufio_test) + (package http-lib) + (modes (best exe)) + (modules bufio_test) + (libraries + fmt + mtime + mtime.clock + mtime.clock.os + 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 + (alias stresstest) + ; use default random seed on stresstests + (action (run %{dep:bufio_test.exe} -v -bt)) +) + (executable (modes exe) (name test_client) From d4e1c0bc7c8ef3949007b811dc0f0f6bb0b37157 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 10 Mar 2023 11:31:17 +0000 Subject: [PATCH 45/65] [maintenance]: quicktest: add the ability to run without XAPI MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add a `-skip-xapi` flag that avoids connecting to XAPI. Useful if you just want to query the list of tests, or execute a specific test that relies on external programs (and thus cannot be a unit test) , but doesn't require XAPI. This will be useful for running etcd tests with 'dune exec'. Also add a '--' flag to be able to pass flags to alcotest directly. E.g. `dune exec ./quicktest.exe -- -skip-xapi -- list` The first '--' separates 'dune' arguments from 'quicktest.exe' arguments, and the 2nd one separates legacy quicktest CLI arguments from alcotest arguments. To ensure this keeps working properly add a runtest that just list the tests. Signed-off-by: Edwin Török --- ocaml/quicktest/dune | 5 +++++ ocaml/quicktest/qt.ml | 6 +++++- ocaml/quicktest/qt_filter.ml | 21 ++++++++++++++++----- ocaml/quicktest/qt_filter.mli | 4 ++++ ocaml/quicktest/quicktest_args.ml | 10 +++++++++- 5 files changed, 39 insertions(+), 7 deletions(-) diff --git a/ocaml/quicktest/dune b/ocaml/quicktest/dune index 380345b1b2d..7230101b552 100644 --- a/ocaml/quicktest/dune +++ b/ocaml/quicktest/dune @@ -35,3 +35,8 @@ (preprocess (pps ppx_deriving_rpc ppx_sexp_conv)) ) + +(rule + (alias runtest) + (action (run ./quicktest.exe -skip-xapi -- list)) +) diff --git a/ocaml/quicktest/qt.ml b/ocaml/quicktest/qt.ml index d390f0dfc38..7485cef15d4 100644 --- a/ocaml/quicktest/qt.ml +++ b/ocaml/quicktest/qt.ml @@ -58,7 +58,11 @@ let inventory_lookup k = Xapi_inventory.inventory_filename := "/etc/xensource-inventory" ; Xapi_inventory.lookup k -let localhost_uuid = inventory_lookup Xapi_inventory._installation_uuid +let localhost_uuid = + if Unix.geteuid () = 0 then + inventory_lookup Xapi_inventory._installation_uuid + else + Uuidm.nil |> Uuidm.to_string module Test = struct let assert_raises_match exception_match fn = diff --git a/ocaml/quicktest/qt_filter.ml b/ocaml/quicktest/qt_filter.ml index cd6933db98c..744b0545a16 100644 --- a/ocaml/quicktest/qt_filter.ml +++ b/ocaml/quicktest/qt_filter.ml @@ -76,10 +76,20 @@ let cleanup () = Client.Client.Session.logout ~rpc:!A.rpc ~session_id:!session_id let wrap f = - init () ; - Xapi_stdext_pervasives.Pervasiveext.finally - (fun () -> f () ; finish ()) - cleanup + if !Quicktest_args.skip_xapi then + f () + else ( + init () ; + Xapi_stdext_pervasives.Pervasiveext.finally + (fun () -> f () ; finish ()) + cleanup + ) + +let with_xapi_query f = + if !Quicktest_args.skip_xapi then + [] + else + f () let conn tcs = for_each @@ -317,7 +327,7 @@ module SR = struct let test = test sr_info in (name, speed, test) - let list_srs srs = srs () + let list_srs srs = with_xapi_query srs let f srs tcs = for_each @@ -329,6 +339,7 @@ let sr = SR.f let vm_template template_name = for_each (fun (name, speed, test) -> + with_xapi_query @@ fun () -> match Qt.VM.Template.find !A.rpc !session_id template_name with | None -> [] diff --git a/ocaml/quicktest/qt_filter.mli b/ocaml/quicktest/qt_filter.mli index 8fdf1003f09..ba8a7416358 100644 --- a/ocaml/quicktest/qt_filter.mli +++ b/ocaml/quicktest/qt_filter.mli @@ -20,6 +20,10 @@ val wrap : (unit -> unit) -> unit (** This has to wrap the quicktest run *) +val with_xapi_query : (unit -> 'a list) -> 'a list +(** [with_xapi_query get_list] calls [get_list ()] unless [-skip-xapi] CLI + argument was used. *) + (** A slightly different definition of Alcotest.test_case, to ensure we can reason about the entire type of the test function *) type 'a test_case = string * Alcotest.speed_level * 'a diff --git a/ocaml/quicktest/quicktest_args.ml b/ocaml/quicktest/quicktest_args.ml index da394f1fd27..85a4d914c60 100644 --- a/ocaml/quicktest/quicktest_args.ml +++ b/ocaml/quicktest/quicktest_args.ml @@ -35,6 +35,12 @@ let rpc_unix_domain xml = let rpc = ref rpc_unix_domain +let alcotest_args = ref [||] + +let set_alcotest_args l = alcotest_args := Array.of_list l + +let skip_xapi = 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. *) @@ -56,6 +62,8 @@ let parse () = , "Only run SR tests on the specified SR, mutually exclusive with \ -default-sr" ) + ; ("-skip-xapi", Arg.Set skip_xapi, "SKIP tests that require XAPI") + ; ("--", Arg.Rest_all set_alcotest_args, "Supply alcotest arguments") ] (fun x -> match (!host, !username, !password) with @@ -82,4 +90,4 @@ let parse () = let get_alcotest_args () = let name = [|Sys.argv.(0)|] in let colour = if not !use_colour then [|"--color=never"|] else [||] in - Array.concat [name; colour] + Array.concat [name; colour; !alcotest_args] From 1e5e5f3648c537464f9110e97c55bb5f24420183 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 29 May 2024 16:46:33 +0100 Subject: [PATCH 46/65] CP-47536: add ezxenstore quicktest MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Basic read/write operation, and watches with and without timeouts. The test can be run with: ``` ./quicktest.exe -skip-xapi -- test xenstore -v ``` Signed-off-by: Edwin Török --- ocaml/quicktest/dune | 2 + ocaml/quicktest/quicktest.ml | 1 + ocaml/quicktest/quicktest_xenstore.ml | 63 ++++++++++++++++++++++++++ ocaml/quicktest/quicktest_xenstore.mli | 1 + 4 files changed, 67 insertions(+) create mode 100644 ocaml/quicktest/quicktest_xenstore.ml create mode 100644 ocaml/quicktest/quicktest_xenstore.mli diff --git a/ocaml/quicktest/dune b/ocaml/quicktest/dune index 7230101b552..51840f8e471 100644 --- a/ocaml/quicktest/dune +++ b/ocaml/quicktest/dune @@ -7,6 +7,8 @@ alcotest astring dune-build-info + ezxenstore + ezxenstore.watch fmt forkexec http_lib diff --git a/ocaml/quicktest/quicktest.ml b/ocaml/quicktest/quicktest.ml index b4ca5725dc6..9300eaa4bd0 100644 --- a/ocaml/quicktest/quicktest.ml +++ b/ocaml/quicktest/quicktest.ml @@ -20,6 +20,7 @@ let () = let suite = [ ("Quicktest_example", Quicktest_example.tests ()) + ; ("xenstore", Quicktest_xenstore.tests ()) ; ("cbt", Quicktest_cbt.tests ()) ; ("event", Quicktest_event.tests ()) ; ("import_raw_vdi", Quicktest_import_raw_vdi.tests ()) diff --git a/ocaml/quicktest/quicktest_xenstore.ml b/ocaml/quicktest/quicktest_xenstore.ml new file mode 100644 index 00000000000..9ef1114c104 --- /dev/null +++ b/ocaml/quicktest/quicktest_xenstore.ml @@ -0,0 +1,63 @@ +(* + * 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 test_basic () = + let open Ezxenstore_core.Xenstore in + let result = with_xs (fun xs -> xs.write "/foo" "bar" ; xs.read "/foo") in + if result <> "bar" then + Alcotest.failf "Bad xenstore reply: %S" result + +let test_watch_within_timeout () = + let open Ezxenstore_core in + Xenstore.with_xs @@ fun xs -> + let key = "/towatch" in + xs.rm key ; + let expected = "valuewritten" in + let t = Thread.create (fun (xs : Xenstore.xsh) -> xs.write key expected) xs in + let finally () = Thread.join t in + Fun.protect ~finally @@ fun () -> + let watch = Watch.value_to_appear key in + let actual = Ezxenstore_core.Watch.wait_for ~xs ~timeout:5.0 watch in + Alcotest.check' Alcotest.string ~expected ~actual + ~msg:"xenstore value matches" + +let test_watch_exceed_timeout () = + let open Ezxenstore_core in + Xenstore.with_xs @@ fun xs -> + let key = "/towatch2" in + xs.rm key ; + let expected = "valuewritten" in + let timeout = 0.3 in + let t = + Thread.create + (fun (xs : Xenstore.xsh) -> + Unix.sleepf (2. *. timeout) ; + xs.write key expected + ) + xs + in + let finally () = Thread.join t in + Fun.protect ~finally @@ fun () -> + let watch = Watch.value_to_appear key in + Alcotest.check_raises "timeout" (Ezxenstore_core.Watch.Timeout timeout) + @@ fun () -> + let (_actual : string) = Ezxenstore_core.Watch.wait_for ~xs ~timeout watch in + () + +let tests () = + [ + ("basic", `Quick, test_basic) + ; ("watch_within_timeout", `Quick, test_watch_within_timeout) + ; ("watch_exceed_timeout", `Quick, test_watch_exceed_timeout) + ] diff --git a/ocaml/quicktest/quicktest_xenstore.mli b/ocaml/quicktest/quicktest_xenstore.mli new file mode 100644 index 00000000000..677cf8346a4 --- /dev/null +++ b/ocaml/quicktest/quicktest_xenstore.mli @@ -0,0 +1 @@ +val tests : unit -> (unit -> unit) Qt_filter.test_case list From 923581bb8ff89f592fd4775780d23dc2ffff18a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 11 Jun 2024 15:43:57 +0100 Subject: [PATCH 47/65] master_connection: log why we failed to connect MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Previously the exception would've been completely ignored, so all we've seen in the logs was the successful connection attempt, and then closing the connection after sending 0 bytes. We were not seeing that Thread.wait_timed_read raised an exception due to a file descriptor having a value >1024. Signed-off-by: Edwin Török --- ocaml/database/master_connection.ml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/ocaml/database/master_connection.ml b/ocaml/database/master_connection.ml index 01a413a512d..2547ae53182 100644 --- a/ocaml/database/master_connection.ml +++ b/ocaml/database/master_connection.ml @@ -271,7 +271,7 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : !Db_globs.permanent_master_failure_retry_interval ; Thread.delay !Db_globs.permanent_master_failure_retry_interval ; !Db_globs.restart_fn () - | e -> ( + | e -> error "Caught %s" (Printexc.to_string e) ; (* RPC failed - there's no way we can recover from this so try reopening connection every 2s + backoff delay *) ( match !my_connection with @@ -322,9 +322,7 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : debug "%s: Sleep interrupted, retrying master connection now" __FUNCTION__ ; update_backoff_delay () ; - try open_secure_connection () with _ -> () - (* oh well, maybe nextime... *) - ) + D.log_and_ignore_exn open_secure_connection done ; !result From 3500e5a026addcfe7ed3e1bb4ecf6aa1232742e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 30 May 2024 18:17:17 +0100 Subject: [PATCH 48/65] xapi.conf: introduce test_open MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We'll check statically that we are not using Unix.select, but it is good to have a runtime check too, in case some library (C or OCaml) indirectly uses it. Default is 0 but can be set to 1024 to test for the absence of Unix.select. Signed-off-by: Edwin Török --- .../lib/xapi-stdext-unix/test/unixext_test.ml | 1 + .../xapi-stdext/lib/xapi-stdext-unix/unixext.ml | 17 +++++++++++++++++ .../lib/xapi-stdext-unix/unixext.mli | 11 +++++++++++ ocaml/xapi/xapi.ml | 8 ++++++++ ocaml/xapi/xapi_globs.ml | 3 +++ ocaml/xenopsd/lib/xenopsd.ml | 16 ++++++++++++++++ 6 files changed, 56 insertions(+) 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 2acad9396fd..e0f2726f303 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,4 +192,5 @@ 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 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 160cfe46b67..204fde34a4d 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -858,6 +858,23 @@ let domain_of_addr str = Some (Unix.domain_of_sockaddr (Unix.ADDR_INET (addr, 1))) with _ -> None +let test_open_called = Atomic.make false + +let test_open n = + if not (Atomic.compare_and_set test_open_called false true) then + invalid_arg "test_open can only be called once" ; + (* we could make this conditional on whether ulimit was increased or not, + but that could hide bugs if we think the CI has tested this, but due to ulimit it hasn't. + *) + if n > 0 then ( + let socket = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + at_exit (fun () -> Unix.close socket) ; + for _ = 2 to n do + let fd = Unix.dup socket in + at_exit (fun () -> Unix.close fd) + done + ) + module Direct = struct type t = Unix.file_descr 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 df81171a3b4..10aa0ea0493 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli @@ -248,6 +248,17 @@ val statvfs : string -> statvfs_t val domain_of_addr : string -> Unix.socket_domain option (** Returns Some Unix.PF_INET or Some Unix.PF_INET6 if passed a valid IP address, otherwise returns None. *) +val test_open : int -> unit +(** [test_open n] opens n file descriptors. This is useful for testing that the application makes no calls + to [Unix.select] that use file descriptors, because such calls will then immediately fail. + + This assumes that [ulimit -n] has been suitably increased in the test environment. + + Can only be called once in a program, and will raise an exception otherwise. + + The file descriptors will stay open until the program exits. + *) + module Direct : sig (** Perform I/O in O_DIRECT mode using 4KiB page-aligned buffers *) diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml index 128910151ed..bc6004a3586 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -930,12 +930,20 @@ let report_tls_verification ~__context = let value = Stunnel_client.get_verify_by_default () in Db.Host.set_tls_verification_enabled ~__context ~self ~value +let test_open count = + if count > 0 then ( + debug "%s: opening %d file descriptors" __FUNCTION__ count ; + Xapi_stdext_unix.Unixext.test_open count ; + debug "%s: opened %d files" __FUNCTION__ count + ) + let server_init () = let print_server_starting_message () = debug "(Re)starting xapi, pid: %d" (Unix.getpid ()) ; debug "on_system_boot=%b pool_role=%s" !Xapi_globs.on_system_boot (Pool_role.string_of (Pool_role.get_role ())) in + test_open !Xapi_globs.test_open ; Unixext.unlink_safe "/etc/xensource/boot_time_info_updated" ; (* Record the initial value of Master_connection.connection_timeout and set it to 'never'. When we are a slave who has just started up we want to wait forever for the master to appear. (See CA-25481) *) diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index c31ed490a0d..97e087e59d8 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -1031,6 +1031,8 @@ let observer_experimental_components = let disable_webserver = ref false +let test_open = ref 0 + let xapi_globs_spec = [ ( "master_connection_reset_timeout" @@ -1114,6 +1116,7 @@ let xapi_globs_spec = ; ("max_spans", Int max_spans) ; ("max_traces", Int max_traces) ; ("max_observer_file_size", Int max_observer_file_size) + ; ("test-open", Int test_open) (* for consistency with xenopsd *) ] let options_of_xapi_globs_spec = diff --git a/ocaml/xenopsd/lib/xenopsd.ml b/ocaml/xenopsd/lib/xenopsd.ml index 98c88561572..2052d367585 100644 --- a/ocaml/xenopsd/lib/xenopsd.ml +++ b/ocaml/xenopsd/lib/xenopsd.ml @@ -128,6 +128,8 @@ let max_bytes_of_xenstore_entries entries = let vm_guest_agent_xenstore_quota_bytes = ref (25 * 1024 * 1024) +let test_open = ref 0 + let options = [ ( "queue" @@ -276,6 +278,11 @@ let options = , "Maximum size in bytes of VM xenstore-data field, and guest metrics \ copied from guest's vm-data/ and data/ xenstore tree" ) + ; ( "test-open" + , Arg.Set_int test_open + , (fun () -> string_of_int !test_open) + , "TESTING only: open N file descriptors" + ) ] let path () = Filename.concat !sockets_path "xenopsd" @@ -424,9 +431,18 @@ let log_uncaught_exception e bt = error "xenopsd exitted with an uncaught exception: %s" (Printexc.to_string e) ; log_raw_backtrace bt +let test_open () = + let count = !test_open in + if count > 0 then ( + debug "TEST: opening %d file descriptors" count ; + Xapi_stdext_unix.Unixext.test_open count ; + debug "TEST: opened %d file descriptors" count + ) + let main backend = Printexc.record_backtrace true ; Printexc.set_uncaught_exception_handler log_uncaught_exception ; + test_open () ; (* Set service name for Tracing *) Tracing_export.set_service_name "xenopsd" ; (* Listen for transferred file descriptors *) From 12f4b05404e61d8771fd27eddedcecac3b2c710a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 19 Jun 2024 09:52:01 +0100 Subject: [PATCH 49/65] xapi_main: enable backtraces earlier to get backtraces from early startup failures MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit If 'server_init' raised an exception previously we wouldn't be able to log the full stacktrace. Enable backtraces earlier to ensure that we can. We need to use Debug.with_thread_associated instead of just Backtrace.with_backtraces, because if the thread is not registered, then xapi-backtrace won't print the backtrace even if it has one. A startup failure now looks like this in the logs: ``` Jun 19 04:58:41 lcy2-dt72 xapi: [error||0 ||backtrace] Xapi.watchdog failed with exception Unix.Unix_error(Unix.EMFILE, "dup", "") Jun 19 04:58:41 lcy2-dt72 xapi: [error||0 ||backtrace] Raised Unix.Unix_error(Unix.EMFILE, "dup", "") Jun 19 04:58:41 lcy2-dt72 xapi: [error||0 ||backtrace] 1/7 xapi Raised at file ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml, line 873 Jun 19 04:58:41 lcy2-dt72 xapi: [error||0 ||backtrace] 2/7 xapi Called from file ocaml/xapi/xapi.ml, line 936 Jun 19 04:58:41 lcy2-dt72 xapi: [error||0 ||backtrace] 3/7 xapi Called from file ocaml/xapi/xapi.ml, line 946 Jun 19 04:58:41 lcy2-dt72 xapi: [error||0 ||backtrace] 4/7 xapi Called from file ocaml/xapi/xapi.ml, line 1535 Jun 19 04:58:41 lcy2-dt72 xapi: [error||0 ||backtrace] 5/7 xapi Called from file ocaml/xapi/xapi.ml, line 1541 Jun 19 04:58:41 lcy2-dt72 xapi: [error||0 ||backtrace] 6/7 xapi Called from file ocaml/xapi/xapi.ml, line 1548 Jun 19 04:58:41 lcy2-dt72 xapi: [error||0 ||backtrace] 7/7 xapi Called from file ocaml/libs/log/debug.ml, line 250 ``` Signed-off-by: Edwin Török --- ocaml/xapi/xapi.ml | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml index bc6004a3586..0b1c213e993 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -1541,12 +1541,11 @@ let delay_on_eintr f = Backtrace.is_important e ; raise e let watchdog f = - if !Xapi_globs.nowatchdog then ( - try - ignore (Unix.sigprocmask Unix.SIG_UNBLOCK [Sys.sigint]) ; - delay_on_eintr f ; - exit 127 - with e -> - Debug.log_backtrace e (Backtrace.get e) ; - exit 2 - ) + let run () = + ignore (Unix.sigprocmask Unix.SIG_UNBLOCK [Sys.sigint]) ; + delay_on_eintr f ; + exit 127 + in + if !Xapi_globs.nowatchdog then + (* backtrace already logged by the Debug module, so ignore the exception here *) + try Debug.with_thread_associated __FUNCTION__ run () with _ -> exit 2 From 547d762c56ecce3d22ca1706ef6b8a6ec422f905 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 26 Jun 2024 16:30:18 +0100 Subject: [PATCH 50/65] fixup! xapi.conf: introduce test_open MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This commit got split between the 3 epoll PRs, and the Makefile part got missed: f4baafad85 ("Test for absence of select: introduce open_1024 in tests") The build still worked locally because I have ulimit > 1024 (and apparently in the CI too?), but it failed in Koji where we had a 1024 limit. Signed-off-by: Edwin Török --- Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile b/Makefile index 9a07e362a89..20ae94e75b6 100644 --- a/Makefile +++ b/Makefile @@ -62,6 +62,7 @@ TEST_TIMEOUT=600 TEST_TIMEOUT2=1200 test: ulimit -S -t $(TEST_TIMEOUT); \ + ulimit -n 2048; \ (sleep $(TEST_TIMEOUT) && ps -ewwlyF --forest)& \ PSTREE_SLEEP_PID=$$!; \ trap "kill $${PSTREE_SLEEP_PID}" INT TERM EXIT; \ From c4603600176d158c1f264cd93f1569940339f2c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 1 Jul 2024 16:34:09 +0100 Subject: [PATCH 51/65] fix(XenAPI.py): fix pylint warning MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This code snippet was unchanged since the beginning, but pylint complained: ``` R1720: Unnecessary "else" after "raise", remove the "else" and de-indent the code inside it (no-else-raise) ``` Signed-off-by: Edwin Török --- scripts/examples/python/XenAPI/XenAPI.py | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/scripts/examples/python/XenAPI/XenAPI.py b/scripts/examples/python/XenAPI/XenAPI.py index 9bb4431bb14..b39239cc285 100644 --- a/scripts/examples/python/XenAPI/XenAPI.py +++ b/scripts/examples/python/XenAPI/XenAPI.py @@ -216,8 +216,7 @@ def _login(self, method, params): # pytype false positive: there is a socket.errno in both py2 and py3 if e.errno == socket.errno.ETIMEDOUT: # pytype: disable=module-attr raise xmlrpclib.Fault(504, 'The connection timed out') - else: - raise e + raise e def _logout(self): try: From 84c2ba642ecbc072d462d1bae4e164df396270ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 1 Jul 2024 16:36:55 +0100 Subject: [PATCH 52/65] fix(XenAPI.py): fix pylint warning MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes: 500a1f70a6 ("XenAPI: suppress pytype false positives") Signed-off-by: Edwin Török --- scripts/examples/python/XenAPI/XenAPI.py | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/scripts/examples/python/XenAPI/XenAPI.py b/scripts/examples/python/XenAPI/XenAPI.py index b39239cc285..6c97f499b5d 100644 --- a/scripts/examples/python/XenAPI/XenAPI.py +++ b/scripts/examples/python/XenAPI/XenAPI.py @@ -222,7 +222,9 @@ def _logout(self): try: if self.last_login_method.startswith("slave_local"): # Proxied function, pytype can't see it - return _parse_result(self.session.local_logout(self._session)) # pytype: disable=attribute-error + # pytype: disable=attribute-error + return _parse_result(self.session.local_logout(self._session)) + # pytype: enable=attribute-error else: return _parse_result(self.session.logout(self._session)) finally: From ff08a18dc446d3e69220c8fc8540a05683e9fa41 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Wed, 22 May 2024 16:09:03 +0100 Subject: [PATCH 53/65] Refactor watcher creation code Signed-off-by: Vincent Liu --- ocaml/xapi/xapi_cluster.ml | 2 +- ocaml/xapi/xapi_cluster_host.ml | 4 +- ocaml/xapi/xapi_clustering.ml | 255 ++++++++++++++++---------------- 3 files changed, 133 insertions(+), 128 deletions(-) diff --git a/ocaml/xapi/xapi_cluster.ml b/ocaml/xapi/xapi_cluster.ml index dda26d201f4..cfc9147434b 100644 --- a/ocaml/xapi/xapi_cluster.ml +++ b/ocaml/xapi/xapi_cluster.ml @@ -115,7 +115,7 @@ let create ~__context ~pIF ~cluster_stack ~pool_auto_join ~token_timeout ~verify ; (* Create the watcher here in addition to resync_host since pool_create in resync_host only calls cluster_host.create for pool member nodes *) - create_cluster_watcher_on_master ~__context ~host ; + Watcher.create_as_necessary ~__context ~host ; Xapi_cluster_host_helpers.update_allowed_operations ~__context ~self:cluster_host_ref ; D.debug "Created Cluster: %s and Cluster_host: %s" diff --git a/ocaml/xapi/xapi_cluster_host.ml b/ocaml/xapi/xapi_cluster_host.ml index 782d5a240f5..291a522fe89 100644 --- a/ocaml/xapi/xapi_cluster_host.ml +++ b/ocaml/xapi/xapi_cluster_host.ml @@ -232,7 +232,7 @@ let resync_host ~__context ~host = (* If we have just joined, enable will prevent concurrent clustering ops *) if not (Db.Cluster_host.get_joined ~__context ~self) then ( join_internal ~__context ~self ; - create_cluster_watcher_on_master ~__context ~host ; + Watcher.create_as_necessary ~__context ~host ; Xapi_observer.initialise_observer ~__context Xapi_observer_components.Xapi_clusterd ) else if Db.Cluster_host.get_enabled ~__context ~self then ( @@ -375,7 +375,7 @@ let enable ~__context ~self = "Cluster_host.enable: xapi-clusterd not running - attempting to start" ; Xapi_clustering.Daemon.enable ~__context ) ; - create_cluster_watcher_on_master ~__context ~host ; + Watcher.create_as_necessary ~__context ~host ; Xapi_observer.initialise_observer ~__context Xapi_observer_components.Xapi_clusterd ; let verify = Stunnel_client.get_verify_by_default () in diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index 4fc9314aa2e..8886984cf7a 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -426,133 +426,138 @@ let compute_corosync_max_host_failures ~__context = in corosync_ha_max_hosts -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) ; - let m = - Cluster_client.LocalClient.diagnostics (rpc ~__context) - "update quorum api fields with diagnostics" - in - match Idl.IdM.run @@ Cluster_client.IDL.T.get m with - | Ok diag -> - Db.Cluster.set_is_quorate ~__context ~self:cluster ~value:diag.is_quorate ; - let all_cluster_hosts = Db.Cluster_host.get_all ~__context in - let ip_ch = - List.map - (fun ch -> - let pIF = Db.Cluster_host.get_PIF ~__context ~self:ch in - let ipstr = - ip_of_pif (pIF, Db.PIF.get_record ~__context ~self:pIF) - |> ipstr_of_address - in - (ipstr, ch) - ) - all_cluster_hosts - in - let current_time = API.Date.now () in - ( match diag.quorum_members with - | None -> - List.iter - (fun self -> - Db.Cluster_host.set_live ~__context ~self ~value:false ; - Db.Cluster_host.set_last_update_live ~__context ~self - ~value:current_time +module Watcher = struct + 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) ; + let m = + Cluster_client.LocalClient.diagnostics (rpc ~__context) + "update quorum api fields with diagnostics" + in + match Idl.IdM.run @@ Cluster_client.IDL.T.get m with + | Ok diag -> + Db.Cluster.set_is_quorate ~__context ~self:cluster + ~value:diag.is_quorate ; + let all_cluster_hosts = Db.Cluster_host.get_all ~__context in + let ip_ch = + List.map + (fun ch -> + let pIF = Db.Cluster_host.get_PIF ~__context ~self:ch in + let ipstr = + ip_of_pif (pIF, Db.PIF.get_record ~__context ~self:pIF) + |> ipstr_of_address + in + (ipstr, ch) ) all_cluster_hosts - | Some nodel -> - let quorum_hosts = - List.filter_map - (fun {addr; _} -> - let ipstr = ipstr_of_address addr in - match List.assoc_opt ipstr ip_ch with - | None -> - error - "%s: cannot find cluster host with network address %s, \ - ignoring this host" - __FUNCTION__ ipstr ; - None - | Some ch -> - Some ch + in + let current_time = API.Date.now () in + ( match diag.quorum_members with + | None -> + List.iter + (fun self -> + Db.Cluster_host.set_live ~__context ~self ~value:false ; + Db.Cluster_host.set_last_update_live ~__context ~self + ~value:current_time ) - nodel - in - let missing_hosts = - List.filter - (fun h -> not (List.mem h quorum_hosts)) all_cluster_hosts - in - let new_hosts = - List.filter - (fun h -> not (Db.Cluster_host.get_live ~__context ~self:h)) - quorum_hosts - in - List.iter - (fun self -> - Db.Cluster_host.set_live ~__context ~self ~value:true ; - Db.Cluster_host.set_last_update_live ~__context ~self - ~value:current_time - ) - new_hosts ; - List.iter - (fun self -> - Db.Cluster_host.set_live ~__context ~self ~value:false ; - Db.Cluster_host.set_last_update_live ~__context ~self - ~value:current_time - ) - missing_hosts ; - maybe_generate_alert ~__context ~missing_hosts ~new_hosts - ~num_hosts:(List.length quorum_hosts) ~quorum:diag.quorum - ) ; - Db.Cluster.set_quorum ~__context ~self:cluster - ~value:(Int64.of_int diag.quorum) ; - Db.Cluster.set_live_hosts ~__context ~self:cluster - ~value:(Int64.of_int diag.total_votes) - | Error (InternalError message) | Error (Unix_error message) -> - warn "%s Cannot query diagnostics due to %s, not performing update" - __FUNCTION__ message - | exception exn -> - warn - "%s: Got exception %s while retrieving diagnostics info, not \ - performing update" - __FUNCTION__ (Printexc.to_string exn) - -let create_cluster_watcher_on_master ~__context ~host = - if Helpers.is_pool_master ~__context ~host then - let watch () = - while !Daemon.enabled do - let m = - Cluster_client.LocalClient.UPDATES.get (rpc ~__context) - "call cluster watcher" 3. - in - match Idl.IdM.run @@ Cluster_client.IDL.T.get m with - | Ok 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 -> - () - ) - | Error (InternalError "UPDATES.Timeout") -> - (* UPDATES.get timed out, this is normal, now retry *) + | Some nodel -> + let quorum_hosts = + List.filter_map + (fun {addr; _} -> + let ipstr = ipstr_of_address addr in + match List.assoc_opt ipstr ip_ch with + | None -> + error + "%s: cannot find cluster host with network address %s, \ + ignoring this host" + __FUNCTION__ ipstr ; + None + | Some ch -> + Some ch + ) + nodel + in + let missing_hosts = + List.filter + (fun h -> not (List.mem h quorum_hosts)) + all_cluster_hosts + in + let new_hosts = + List.filter + (fun h -> not (Db.Cluster_host.get_live ~__context ~self:h)) + quorum_hosts + in + List.iter + (fun self -> + Db.Cluster_host.set_live ~__context ~self ~value:true ; + Db.Cluster_host.set_last_update_live ~__context ~self + ~value:current_time + ) + new_hosts ; + List.iter + (fun self -> + Db.Cluster_host.set_live ~__context ~self ~value:false ; + Db.Cluster_host.set_last_update_live ~__context ~self + ~value:current_time + ) + missing_hosts ; + maybe_generate_alert ~__context ~missing_hosts ~new_hosts + ~num_hosts:(List.length quorum_hosts) ~quorum:diag.quorum + ) ; + Db.Cluster.set_quorum ~__context ~self:cluster + ~value:(Int64.of_int diag.quorum) ; + Db.Cluster.set_live_hosts ~__context ~self:cluster + ~value:(Int64.of_int diag.total_votes) + | Error (InternalError message) | Error (Unix_error message) -> + warn "%s Cannot query diagnostics due to %s, not performing update" + __FUNCTION__ message + | exception exn -> + warn + "%s: Got exception %s while retrieving diagnostics info, not \ + performing update" + __FUNCTION__ (Printexc.to_string exn) + + let watch_cluster_change ~__context ~host = + while !Daemon.enabled do + let m = + Cluster_client.LocalClient.UPDATES.get (rpc ~__context) + "call cluster watcher" 3. + in + match Idl.IdM.run @@ Cluster_client.IDL.T.get m with + | Ok 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 -> () - | Error (InternalError message) | Error (Unix_error message) -> - warn "%s: Cannot query cluster host updates with error %s" - __FUNCTION__ message - | exception exn -> - warn - "%s: Got exception %s while query cluster host updates, retrying" - __FUNCTION__ (Printexc.to_string exn) ; - Thread.delay 3. - done - in - if Xapi_cluster_helpers.cluster_health_enabled ~__context then ( - debug "%s: create watcher for corosync-notifyd on master" __FUNCTION__ ; - ignore @@ Thread.create watch () - ) else - debug - "%s: not creating watcher for corosync-notifyd: feature cluster_health \ - not enabled" - __FUNCTION__ + ) + | Error (InternalError "UPDATES.Timeout") -> + (* UPDATES.get timed out, this is normal, now retry *) + () + | Error (InternalError message) | Error (Unix_error message) -> + warn "%s: Cannot query cluster host updates with error %s" + __FUNCTION__ message + | exception exn -> + warn "%s: Got exception %s while query cluster host updates, retrying" + __FUNCTION__ (Printexc.to_string exn) ; + Thread.delay 3. + done + + (** [create_as_necessary] will create cluster watchers on the coordinator if they are not + already created. + There is no need to destroy them: once the clustering daemon is disabled, + these threads will exit as well. *) + let create_as_necessary ~__context ~host = + if Helpers.is_pool_master ~__context ~host then + if Xapi_cluster_helpers.cluster_health_enabled ~__context then ( + debug "%s: create watcher for corosync-notifyd on coordinator" + __FUNCTION__ ; + + ignore + @@ Thread.create (fun () -> watch_cluster_change ~__context ~host) () + ) +end From 733882a2c3a2d026024e354b28918be3382a5ead Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Wed, 22 May 2024 16:57:47 +0100 Subject: [PATCH 54/65] Only create watcher once Use the Atomic module to track whether a watcher has been created. Signed-off-by: Vincent Liu --- ocaml/xapi/xapi_clustering.ml | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index 8886984cf7a..d355b0b731a 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -520,6 +520,8 @@ module Watcher = struct performing update" __FUNCTION__ (Printexc.to_string exn) + let cluster_change_watcher : bool Atomic.t = Atomic.make false + let watch_cluster_change ~__context ~host = while !Daemon.enabled do let m = @@ -545,7 +547,8 @@ module Watcher = struct warn "%s: Got exception %s while query cluster host updates, retrying" __FUNCTION__ (Printexc.to_string exn) ; Thread.delay 3. - done + done ; + Atomic.set cluster_change_watcher false (** [create_as_necessary] will create cluster watchers on the coordinator if they are not already created. @@ -553,11 +556,16 @@ module Watcher = struct these threads will exit as well. *) let create_as_necessary ~__context ~host = if Helpers.is_pool_master ~__context ~host then - if Xapi_cluster_helpers.cluster_health_enabled ~__context then ( - debug "%s: create watcher for corosync-notifyd on coordinator" - __FUNCTION__ ; - - ignore - @@ Thread.create (fun () -> watch_cluster_change ~__context ~host) () - ) + if Xapi_cluster_helpers.cluster_health_enabled ~__context then + if Atomic.compare_and_set cluster_change_watcher false true then ( + debug "%s: create watcher for corosync-notifyd on coordinator" + __FUNCTION__ ; + ignore + @@ Thread.create (fun () -> watch_cluster_change ~__context ~host) () + ) else + (* someone else must have gone into the if branch above and created the thread + before us, leave it to them *) + debug + "%s: not create watcher for corosync-notifyd as it already exists" + __FUNCTION__ end From e612873d7e3a7d552f97b603fa6ad2a60e67e9ee Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Wed, 19 Jun 2024 22:33:20 +0100 Subject: [PATCH 55/65] Refactor cluster change watcher interval Signed-off-by: Vincent Liu --- ocaml/xapi/xapi_clustering.ml | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index d355b0b731a..a470546135d 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -522,11 +522,16 @@ 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 + it to a relatively long value since the call will return immediately if there + is an update *) + let cluster_change_interval = Mtime.Span.min + let watch_cluster_change ~__context ~host = while !Daemon.enabled do let m = Cluster_client.LocalClient.UPDATES.get (rpc ~__context) - "call cluster watcher" 3. + "call cluster watcher" (Clock.Timer.span_to_s cluster_change_interval) in match Idl.IdM.run @@ Cluster_client.IDL.T.get m with | Ok updates -> ( @@ -546,7 +551,7 @@ module Watcher = struct | exception exn -> warn "%s: Got exception %s while query cluster host updates, retrying" __FUNCTION__ (Printexc.to_string exn) ; - Thread.delay 3. + Thread.delay (Clock.Timer.span_to_s cluster_change_interval) done ; Atomic.set cluster_change_watcher false From af142fc413928250c14fcb2b38f04fe8ba27ce73 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Thu, 20 Jun 2024 20:00:40 +0100 Subject: [PATCH 56/65] Add new internal API cstack_sync This allows one to force sync the state of xapi db with the cluster stack, useful for cluster API methods change the state of the cluster. Signed-off-by: Vincent Liu --- ocaml/idl/datamodel_cluster.ml | 11 +++++++++++ ocaml/xapi/message_forwarding.ml | 8 ++++++++ ocaml/xapi/xapi_cluster.ml | 5 +++++ ocaml/xapi/xapi_cluster.mli | 10 ++++++++++ ocaml/xapi/xapi_clustering.ml | 3 ++- 5 files changed, 36 insertions(+), 1 deletion(-) diff --git a/ocaml/idl/datamodel_cluster.ml b/ocaml/idl/datamodel_cluster.ml index 10c30bb540b..dba9b76c73b 100644 --- a/ocaml/idl/datamodel_cluster.ml +++ b/ocaml/idl/datamodel_cluster.ml @@ -169,6 +169,16 @@ let pool_resync = ~params:[(Ref _cluster, "self", "The cluster to resync")] ~lifecycle ~allowed_roles:_R_POOL_OP ~errs:[] () +let cstack_sync = + call ~name:"cstack_sync" + ~doc: + "Sync xapi db with the cluster stack synchronously, and generate alerts \ + as needed. Only happens on the coordinator as this is where the cluster \ + watcher performs updates." + ~params:[(Ref _cluster, "self", "The cluster to sync")] + ~hide_from_docs:true ~pool_internal:true ~lifecycle + ~allowed_roles:_R_POOL_OP ~errs:[] () + let t = create_obj ~name:_cluster ~descr:"Cluster-wide Cluster metadata" ~doccomments:[] ~gen_constructor_destructor:false ~gen_events:true @@ -245,5 +255,6 @@ let t = ; pool_force_destroy ; pool_destroy ; pool_resync + ; cstack_sync ] () diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index e323bd4248b..34e420259b8 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -6419,6 +6419,14 @@ functor ) ; debug "Cluster.pool_resync for host %s" (Ref.string_of host) ) + + let cstack_sync ~__context ~self = + info "Cluster.cstack_sync cluster %s" (Ref.string_of self) ; + let local_fn = Local.Cluster.cstack_sync ~self in + let coor = Helpers.get_master ~__context in + do_op_on ~local_fn ~__context ~host:coor (fun session_id rpc -> + Client.Cluster.cstack_sync ~rpc ~session_id ~self + ) end module Cluster_host = struct diff --git a/ocaml/xapi/xapi_cluster.ml b/ocaml/xapi/xapi_cluster.ml index cfc9147434b..26fc0317ac2 100644 --- a/ocaml/xapi/xapi_cluster.ml +++ b/ocaml/xapi/xapi_cluster.ml @@ -294,3 +294,8 @@ let pool_resync ~__context ~self:_ = ) (* If host.clustering_enabled then resync_host should successfully find or create a matching cluster_host which is also enabled *) + +let cstack_sync ~__context ~self = + debug "%s: sync db data with cluster stack" __FUNCTION__ ; + Watcher.on_corosync_update ~__context ~cluster:self + ["Updates due to cluster api calls"] diff --git a/ocaml/xapi/xapi_cluster.mli b/ocaml/xapi/xapi_cluster.mli index a9a71f275ad..bcdc029c49b 100644 --- a/ocaml/xapi/xapi_cluster.mli +++ b/ocaml/xapi/xapi_cluster.mli @@ -74,3 +74,13 @@ val pool_resync : __context:Context.t -> self:API.ref_Cluster -> unit Cluster_host objects (ie., one for each host in the pool if the Cluster has [pool_auto_join] set. If there is a failure, this function must return an error that enables the administrator to fix the problem. *) + +val cstack_sync : __context:Context.t -> self:API.ref_Cluster -> unit +(** [cstack_sync ~__context ~self] is the implementation of the internal XenAPI method, +which synchronously performs a diagnostics call to xapi-clusterd and updates the +xapi db according to the call. This is used internally by cluster-host-create/destroy +to generate the correct alert as a result of the API call. The other part of the +alerts generated due to network failure (e.g. a host left as its network is down) +is handled by the cluster watcher. This call only happens on the coordinator as that +is where the cluster watcher performs the updates, which shares the code with +this function. *) diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index a470546135d..eedc60290bc 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -531,7 +531,8 @@ module Watcher = struct while !Daemon.enabled do let m = Cluster_client.LocalClient.UPDATES.get (rpc ~__context) - "call cluster watcher" (Clock.Timer.span_to_s cluster_change_interval) + "call cluster watcher" + (Clock.Timer.span_to_s cluster_change_interval) in match Idl.IdM.run @@ Cluster_client.IDL.T.get m with | Ok updates -> ( From 3dc79e0c4435ae9535dabc39e8c93b4a61fc6bc6 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Wed, 19 Jun 2024 22:14:53 +0100 Subject: [PATCH 57/65] CP-394109: Alert only once for cluster host leave/join Previously there were two ways an alert for a cluster host join/leave can be raised: 1. through the cluster change watcher; 2. through the api call. These two can generate duplicate alerts as an API call can cause the cluster change watcher to notice the change as well. The idea of the fix here is still to let API and watcher raise alerts separately, but now add synchronous API calls to allow API call (cluster-host-join, etc) to call the cluster change update code at the right time so that the cluster change watcher won't see the change again, hence not generating duplicate alerts. Signed-off-by: Vincent Liu --- ocaml/tests/test_cluster.ml | 4 + ocaml/xapi/xapi_cluster_helpers.ml | 8 +- ocaml/xapi/xapi_cluster_host.ml | 29 ++---- ocaml/xapi/xapi_clustering.ml | 141 ++++++++++++++++------------- 4 files changed, 97 insertions(+), 85 deletions(-) diff --git a/ocaml/tests/test_cluster.ml b/ocaml/tests/test_cluster.ml index d34258c512c..b42621a300f 100644 --- a/ocaml/tests/test_cluster.ml +++ b/ocaml/tests/test_cluster.ml @@ -95,6 +95,10 @@ let test_rpc ~__context call = Rpc.{success= true; contents= Rpc.String ""; is_notification= false} | "Cluster_host.get_cluster_config", _ -> Rpc.{success= true; contents= Rpc.String ""; is_notification= false} + | "Cluster.cstack_sync", [_session; self] -> + let open API in + Xapi_cluster.cstack_sync ~__context ~self:(ref_Cluster_of_rpc self) ; + Rpc.{success= true; contents= Rpc.String ""; is_notification= false} | name, params -> Alcotest.failf "Unexpected RPC: %s(%s)" name (String.concat " " (List.map Rpc.to_string params)) diff --git a/ocaml/xapi/xapi_cluster_helpers.ml b/ocaml/xapi/xapi_cluster_helpers.ml index 31a655a3e72..f7ea78eab9d 100644 --- a/ocaml/xapi/xapi_cluster_helpers.ml +++ b/ocaml/xapi/xapi_cluster_helpers.ml @@ -114,7 +114,7 @@ let corosync3_enabled ~__context = let restrictions = Db.Pool.get_restrictions ~__context ~self:pool in List.assoc_opt "restrict_corosync3" restrictions = Some "false" -let maybe_generate_alert ~__context ~num_hosts ~missing_hosts ~new_hosts ~quorum +let maybe_generate_alert ~__context ~num_hosts ~hosts_left ~hosts_joined ~quorum = let generate_alert join cluster_host = let host = Db.Cluster_host.get_host ~__context ~self:cluster_host in @@ -148,10 +148,10 @@ let maybe_generate_alert ~__context ~num_hosts ~missing_hosts ~new_hosts ~quorum ) in if cluster_health_enabled ~__context then ( - List.iter (generate_alert false) missing_hosts ; - List.iter (generate_alert true) new_hosts ; + List.iter (generate_alert false) hosts_left ; + List.iter (generate_alert true) hosts_joined ; (* only generate this alert when the number of hosts is decreasing *) - if missing_hosts <> [] && num_hosts <= quorum then + if hosts_left <> [] && num_hosts <= quorum then let pool = Helpers.get_pool ~__context in let pool_uuid = Db.Pool.get_uuid ~__context ~self:pool in let name, priority = Api_messages.cluster_quorum_approaching_lost in diff --git a/ocaml/xapi/xapi_cluster_host.ml b/ocaml/xapi/xapi_cluster_host.ml index 291a522fe89..c55d789b8d9 100644 --- a/ocaml/xapi/xapi_cluster_host.ml +++ b/ocaml/xapi/xapi_cluster_host.ml @@ -13,7 +13,6 @@ *) open Xapi_clustering -open Xapi_cluster_helpers open Ipaddr_rpc_type module D = Debug.Make (struct let name = "xapi_cluster_host" end) @@ -55,20 +54,6 @@ let call_api_function_with_alert ~__context ~msg ~cls ~obj_uuid ~body raise err ) -let alert_for_cluster_host ~__context ~cluster_host ~missing_hosts ~new_hosts = - let num_hosts = Db.Cluster_host.get_all ~__context |> List.length in - let cluster = Db.Cluster_host.get_cluster ~__context ~self:cluster_host in - let quorum = Db.Cluster.get_quorum ~__context ~self:cluster |> Int64.to_int in - maybe_generate_alert ~__context ~missing_hosts ~new_hosts ~num_hosts ~quorum - -let alert_for_cluster_host_leave ~__context ~cluster_host = - alert_for_cluster_host ~__context ~cluster_host ~missing_hosts:[cluster_host] - ~new_hosts:[] - -let alert_for_cluster_host_join ~__context ~cluster_host = - alert_for_cluster_host ~__context ~cluster_host ~missing_hosts:[] - ~new_hosts:[cluster_host] - (* Create xapi db object for cluster_host, resync_host calls clusterd *) let create_internal ~__context ~cluster ~host ~pIF : API.ref_Cluster_host = with_clustering_lock __LOC__ (fun () -> @@ -81,7 +66,6 @@ let create_internal ~__context ~cluster ~host ~pIF : API.ref_Cluster_host = ~enabled:false ~current_operations:[] ~allowed_operations:[] ~other_config:[] ~joined:false ~live:false ~last_update_live:API.Date.epoch ; - alert_for_cluster_host_join ~__context ~cluster_host:ref ; ref ) @@ -269,16 +253,21 @@ let destroy_op ~__context ~self ~force = (Cluster_client.LocalClient.leave, "destroy") in let result = local_fn (rpc ~__context) dbg in + let cluster = Db.Cluster_host.get_cluster ~__context ~self in match Idl.IdM.run @@ Cluster_client.IDL.T.get result with | Ok () -> - alert_for_cluster_host_leave ~__context ~cluster_host:self ; + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.Cluster.cstack_sync ~rpc ~session_id ~self:cluster + ) ; Db.Cluster_host.destroy ~__context ~self ; debug "Cluster_host.%s was successful" fn_str ; Xapi_clustering.Daemon.disable ~__context | Error error -> warn "Error occurred during Cluster_host.%s" fn_str ; if force then ( - alert_for_cluster_host_leave ~__context ~cluster_host:self ; + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.Cluster.cstack_sync ~rpc ~session_id ~self:cluster + ) ; let ref_str = Ref.string_of self in Db.Cluster_host.destroy ~__context ~self ; debug "Cluster_host %s force destroyed." ref_str @@ -326,7 +315,9 @@ let forget ~__context ~self = Db.Cluster.set_pending_forget ~__context ~self:cluster ~value:[] ; (* must not disable the daemon here, because we declared another unreachable node dead, * not the current one *) - alert_for_cluster_host_leave ~__context ~cluster_host:self ; + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.Cluster.cstack_sync ~rpc ~session_id ~self:cluster + ) ; Db.Cluster_host.destroy ~__context ~self ; debug "Cluster_host.forget was successful" | Error error -> diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index eedc60290bc..21794537268 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -438,74 +438,87 @@ module Watcher = struct in match Idl.IdM.run @@ Cluster_client.IDL.T.get m with | Ok diag -> - Db.Cluster.set_is_quorate ~__context ~self:cluster - ~value:diag.is_quorate ; - let all_cluster_hosts = Db.Cluster_host.get_all ~__context in - let ip_ch = - List.map - (fun ch -> - let pIF = Db.Cluster_host.get_PIF ~__context ~self:ch in - let ipstr = - ip_of_pif (pIF, Db.PIF.get_record ~__context ~self:pIF) - |> ipstr_of_address - in - (ipstr, ch) - ) - all_cluster_hosts - in - let current_time = API.Date.now () in - ( match diag.quorum_members with - | None -> - List.iter - (fun self -> - Db.Cluster_host.set_live ~__context ~self ~value:false ; - Db.Cluster_host.set_last_update_live ~__context ~self - ~value:current_time + ( Db.Cluster.set_is_quorate ~__context ~self:cluster + ~value:diag.is_quorate ; + let all_cluster_hosts = Db.Cluster_host.get_all ~__context in + let live_hosts = + Db.Cluster_host.get_refs_where ~__context + ~expr:(Eq (Field "live", Literal "true")) + in + let dead_hosts = + List.filter (fun h -> not (List.mem h live_hosts)) all_cluster_hosts + in + let ip_ch = + List.map + (fun ch -> + let pIF = Db.Cluster_host.get_PIF ~__context ~self:ch in + let ipstr = + ip_of_pif (pIF, Db.PIF.get_record ~__context ~self:pIF) + |> ipstr_of_address + in + (ipstr, ch) ) all_cluster_hosts - | Some nodel -> - let quorum_hosts = - List.filter_map - (fun {addr; _} -> - let ipstr = ipstr_of_address addr in - match List.assoc_opt ipstr ip_ch with - | None -> - error - "%s: cannot find cluster host with network address %s, \ - ignoring this host" - __FUNCTION__ ipstr ; - None - | Some ch -> - Some ch + in + let current_time = API.Date.now () in + match diag.quorum_members with + | None -> + List.iter + (fun self -> + Db.Cluster_host.set_live ~__context ~self ~value:false ; + Db.Cluster_host.set_last_update_live ~__context ~self + ~value:current_time ) - nodel - in - let missing_hosts = + all_cluster_hosts + | Some nodel -> + (* nodel contains the current members of the cluster, according to corosync *) + let quorum_hosts = + List.filter_map + (fun {addr; _} -> + let ipstr = ipstr_of_address addr in + match List.assoc_opt ipstr ip_ch with + | None -> + error + "%s: cannot find cluster host with network address \ + %s, ignoring this host" + __FUNCTION__ ipstr ; + None + | Some ch -> + Some ch + ) + nodel + in + + (* hosts_left contains the hosts that were live, but not in the list + of live hosts according to the cluster stack *) + let hosts_left = + List.filter (fun h -> not (List.mem h quorum_hosts)) live_hosts + in + (* hosts_joined contains the hosts that were dead but exists in the db, + and is now viewed as a member of the cluster by the cluster stack *) + let hosts_joined = + List.filter (fun h -> List.mem h quorum_hosts) dead_hosts + in + debug "%s: there are %d hosts joined and %d hosts left" + __FUNCTION__ (List.length hosts_joined) (List.length hosts_left) ; + + List.iter + (fun self -> + Db.Cluster_host.set_live ~__context ~self ~value:true ; + Db.Cluster_host.set_last_update_live ~__context ~self + ~value:current_time + ) + quorum_hosts ; List.filter (fun h -> not (List.mem h quorum_hosts)) all_cluster_hosts - in - let new_hosts = - List.filter - (fun h -> not (Db.Cluster_host.get_live ~__context ~self:h)) - quorum_hosts - in - List.iter - (fun self -> - Db.Cluster_host.set_live ~__context ~self ~value:true ; - Db.Cluster_host.set_last_update_live ~__context ~self - ~value:current_time - ) - new_hosts ; - List.iter - (fun self -> - Db.Cluster_host.set_live ~__context ~self ~value:false ; - Db.Cluster_host.set_last_update_live ~__context ~self - ~value:current_time - ) - missing_hosts ; - maybe_generate_alert ~__context ~missing_hosts ~new_hosts - ~num_hosts:(List.length quorum_hosts) ~quorum:diag.quorum + |> List.iter (fun self -> + Db.Cluster_host.set_live ~__context ~self ~value:false ; + Db.Cluster_host.set_last_update_live ~__context ~self + ~value:current_time + ) ; + maybe_generate_alert ~__context ~hosts_left ~hosts_joined + ~num_hosts:(List.length quorum_hosts) ~quorum:diag.quorum ) ; Db.Cluster.set_quorum ~__context ~self:cluster ~value:(Int64.of_int diag.quorum) ; @@ -527,6 +540,10 @@ module Watcher = struct is an update *) let cluster_change_interval = Mtime.Span.min + (* we handle unclean hosts join and leave in the watcher, i.e. hosts joining and leaving + due to network problems, power cut, etc. Join and leave initiated by the + API will be handled in the API call themselves, but they share the same code + as the watcher. *) let watch_cluster_change ~__context ~host = while !Daemon.enabled do let m = From cca43a4956c3e1db8584622d322d456d34beab74 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Wed, 10 Jul 2024 11:25:39 +0100 Subject: [PATCH 58/65] Feature flag the cstack_sync call Signed-off-by: Vincent Liu --- ocaml/xapi/xapi_cluster.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/ocaml/xapi/xapi_cluster.ml b/ocaml/xapi/xapi_cluster.ml index 26fc0317ac2..cfa55fde2c7 100644 --- a/ocaml/xapi/xapi_cluster.ml +++ b/ocaml/xapi/xapi_cluster.ml @@ -296,6 +296,8 @@ let pool_resync ~__context ~self:_ = find or create a matching cluster_host which is also enabled *) let cstack_sync ~__context ~self = - debug "%s: sync db data with cluster stack" __FUNCTION__ ; - Watcher.on_corosync_update ~__context ~cluster:self - ["Updates due to cluster api calls"] + if Xapi_cluster_helpers.cluster_health_enabled ~__context then ( + debug "%s: sync db data with cluster stack" __FUNCTION__ ; + Watcher.on_corosync_update ~__context ~cluster:self + ["Updates due to cluster api calls"] + ) From d8fa301fab466d1a15fea69f9f2ff1d522c594a4 Mon Sep 17 00:00:00 2001 From: Steven Woods Date: Tue, 9 Jul 2024 14:48:10 +0100 Subject: [PATCH 59/65] CP-50193: Update new fingerprint fields on DB upgrade The new fingerprint_sha256 and fingerprint_sha1 fields will be empty when upgrading from a version without the fields. This commit checks for this and fills them in, stopping the certificate from being needlessly reinstalled. Signed-off-by: Steven Woods --- ocaml/idl/datamodel_certificate.ml | 4 +-- ocaml/idl/datamodel_common.ml | 2 +- ocaml/idl/datamodel_lifecycle.ml | 4 +++ ocaml/idl/schematest.ml | 2 +- ocaml/xapi/certificates.ml | 11 ++++---- ocaml/xapi/certificates.mli | 3 +++ ocaml/xapi/certificates_sync.ml | 43 +++++++++++++++++++++--------- 7 files changed, 47 insertions(+), 22 deletions(-) diff --git a/ocaml/idl/datamodel_certificate.ml b/ocaml/idl/datamodel_certificate.ml index 409d35e8233..bfbdd2b60b5 100644 --- a/ocaml/idl/datamodel_certificate.ml +++ b/ocaml/idl/datamodel_certificate.ml @@ -69,10 +69,10 @@ let t = [(Published, rel_stockholm, ""); (Deprecated, "24.19.0", "")] ~ty:String "fingerprint" ~default_value:(Some (VString "")) "Use fingerprint_sha256 instead" - ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint_sha256" + ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:String "fingerprint_sha256" ~default_value:(Some (VString "")) "The certificate's SHA256 fingerprint / hash" - ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint_sha1" + ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:String "fingerprint_sha1" ~default_value:(Some (VString "")) "The certificate's SHA1 fingerprint / hash" ] diff --git a/ocaml/idl/datamodel_common.ml b/ocaml/idl/datamodel_common.ml index de22cf2e5ad..9afd7bd37c0 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 = 779 +let schema_minor_vsn = 780 (* Historical schema versions just in case this is useful later *) let rio_schema_major_vsn = 5 diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index 92316d8ee26..763b3944caa 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -27,6 +27,10 @@ let prototyped_of_field = function Some "23.14.0" | "Repository", "gpgkey_path" -> Some "22.12.0" + | "Certificate", "fingerprint_sha1" -> + Some "24.19.1-next" + | "Certificate", "fingerprint_sha256" -> + Some "24.19.1-next" | "Cluster_host", "last_update_live" -> Some "24.3.0" | "Cluster_host", "live" -> diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index f2ee8fe4be2..4ba16fbfe1c 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 = "efdb1c7e536362523741ccdb7f33f797" +let last_known_schema_hash = "7885f7b085e4a5e32977a4b222030412" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 4f6747762ea..effb154877e 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -80,6 +80,9 @@ let pp_hash hash = in String.init length value_of +let pp_fingerprint ~hash_type cert = + X509.Certificate.fingerprint hash_type cert |> pp_hash + let safe_char c = match c with | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '.' | '_' | '-' -> @@ -218,12 +221,8 @@ end = struct let not_before, not_after = dates_of_ptimes (X509.Certificate.validity certificate) in - let fingerprint_sha256 = - X509.Certificate.fingerprint `SHA256 certificate |> pp_hash - in - let fingerprint_sha1 = - X509.Certificate.fingerprint `SHA1 certificate |> pp_hash - in + let fingerprint_sha256 = pp_fingerprint ~hash_type:`SHA256 certificate in + let fingerprint_sha1 = pp_fingerprint ~hash_type:`SHA1 certificate in let uuid = Uuidx.(to_string (make ())) in let ref' = Ref.make () in Db.Certificate.create ~__context ~ref:ref' ~uuid ~host ~not_before diff --git a/ocaml/xapi/certificates.mli b/ocaml/xapi/certificates.mli index ddb2677df1c..486ada825e2 100644 --- a/ocaml/xapi/certificates.mli +++ b/ocaml/xapi/certificates.mli @@ -20,6 +20,9 @@ val pem_of_string : string -> X509.Certificate.t val pp_hash : Cstruct.t -> string +val pp_fingerprint : + hash_type:Mirage_crypto.Hash.hash -> X509.Certificate.t -> string + val validate_name : t_trusted -> string -> unit val hostnames_of_pem_cert : diff --git a/ocaml/xapi/certificates_sync.ml b/ocaml/xapi/certificates_sync.ml index 735b1a9c936..e1bf42630a0 100644 --- a/ocaml/xapi/certificates_sync.ml +++ b/ocaml/xapi/certificates_sync.ml @@ -29,16 +29,26 @@ let install ~__context ~host:_ ~type' cert = error "certificates_sync.install exception: %s" (Printexc.to_string e) ; Error (`Msg ("installation of host certificate failed", [])) +type to_update = Certificate | Hashes of {sha256: string; sha1: string} + (** determine if the database is up to date by comparing the fingerprint of xapi-ssl.pem with the entry in the database *) -let is_unchanged ~__context cert_ref cert = +let to_update ~__context cert_ref cert = let ref_hash = Db.Certificate.get_fingerprint_sha256 ~__context ~self:cert_ref in - let cert_hash = - X509.Certificate.fingerprint `SHA256 cert |> Certificates.pp_hash - in - cert_hash = ref_hash + let sha256 = Certificates.pp_fingerprint ~hash_type:`SHA256 cert in + if ref_hash = "" then + (* We must be upgrading from a version predating fingerprint_sha256, so check fingerprint instead *) + if sha256 = Db.Certificate.get_fingerprint ~__context ~self:cert_ref then + let sha1 = Certificates.pp_fingerprint ~hash_type:`SHA1 cert in + Some (Hashes {sha256; sha1}) + else + Some Certificate + else if sha256 = ref_hash then + None + else + Some Certificate (** [get_server_cert] loads [path] from the file system and returns it decoded *) @@ -76,17 +86,26 @@ let sync ~__context ~type' = | [] -> info "Host %s has no active server certificate" host_uuid ; install ~__context ~host ~type' cert - | [cert_ref] -> - let unchanged = is_unchanged ~__context cert_ref cert in - if unchanged then ( - info "Active server certificate for host %s is unchanged" host_uuid ; - Ok () - ) else ( + | [cert_ref] -> ( + match to_update ~__context cert_ref cert with + | Some Certificate -> info "Server certificate for host %s changed - updating" host_uuid ; let* () = install ~__context ~host ~type' cert in uninstall ~__context cert_ref ; Ok () - ) + | Some (Hashes {sha256; sha1}) -> + info "Active server certificate for host %s is unchanged" host_uuid ; + Db.Certificate.set_fingerprint_sha256 ~__context ~self:cert_ref + ~value:sha256 ; + Db.Certificate.set_fingerprint_sha1 ~__context ~self:cert_ref + ~value:sha1 ; + info "Populated new fingerprint fields: sha256= %s; sha1= %s" sha256 + sha1 ; + Ok () + | None -> + info "Active server certificate for host %s is unchanged" host_uuid ; + Ok () + ) | cert_refs -> warn "The host has more than one certificate: %s" (String.concat ", " (List.map Ref.string_of cert_refs)) ; From 55963c420b1d2846da9cc560dbbf808421c25ccb Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Mon, 8 Jul 2024 10:36:40 +0100 Subject: [PATCH 60/65] CP-50108: Use Ipaddr instead of string-based CIDR handling In nm.ml; helpers.ml. Expands test cases, keeps the existent exception behaviour. Signed-off-by: Andrii Sultanov --- ocaml/tests/test_helpers.ml | 19 +++++++ ocaml/xapi-idl/network/dune | 1 + ocaml/xapi-idl/network/network_interface.ml | 30 +++++++---- ocaml/xapi/dune | 1 + ocaml/xapi/helpers.ml | 60 ++++++++++++++------- ocaml/xapi/nm.ml | 31 ++++++----- 6 files changed, 101 insertions(+), 41 deletions(-) diff --git a/ocaml/tests/test_helpers.ml b/ocaml/tests/test_helpers.ml index 42028c0d072..b856bb363e3 100644 --- a/ocaml/tests/test_helpers.ml +++ b/ocaml/tests/test_helpers.ml @@ -320,6 +320,14 @@ module IPCheckers = Generic.MakeStateless (struct ; ( (`ipv6, "address5", "ze80::bae8:56ff:fe29:894a") , Error (Server_error (invalid_ip_address_specified, ["address5"])) ) + ; ((`ipv4or6, "address5", "192.168.0.1"), Ok ()) + ; ((`ipv4or6, "address6", "fe80::bae8:56ff:fe29:894a"), Ok ()) + ; ( (`ipv4or6, "address7", "ze80::bae8:56ff:fe29:894a") + , Error (Server_error (invalid_ip_address_specified, ["address7"])) + ) + ; ( (`ipv4or6, "address8", "192.168.0.300") + , Error (Server_error (invalid_ip_address_specified, ["address8"])) + ) ] end) @@ -399,6 +407,17 @@ module CIDRCheckers = Generic.MakeStateless (struct ; ( (`ipv6, "address5", "ze80::bae8:56ff:fe29:894a/64") , Error (Server_error (invalid_cidr_address_specified, ["address5"])) ) + ; ( (`ipv4or6, "address6", "bad-address/64") + , Error (Server_error (invalid_cidr_address_specified, ["address6"])) + ) + ; ((`ipv4or6, "address7", "fe80::bae8:56ff:fe29:894a/64"), Ok ()) + ; ( (`ipv4or6, "address8", "ze80::bae8:56ff:fe29:894a/64") + , Error (Server_error (invalid_cidr_address_specified, ["address8"])) + ) + ; ((`ipv4or6, "address9", "255.255.255.0/32"), Ok ()) + ; ( (`ipv4or6, "address10", "192.168.0.2/33") + , Error (Server_error (invalid_cidr_address_specified, ["address10"])) + ) ] end) diff --git a/ocaml/xapi-idl/network/dune b/ocaml/xapi-idl/network/dune index 4fb1a78f213..eb321c114e3 100644 --- a/ocaml/xapi-idl/network/dune +++ b/ocaml/xapi-idl/network/dune @@ -10,6 +10,7 @@ threads.posix xapi-idl xapi-log + ipaddr ) (wrapped false) (preprocess (pps ppx_deriving_rpc))) diff --git a/ocaml/xapi-idl/network/network_interface.ml b/ocaml/xapi-idl/network/network_interface.ml index 8fd2553ea07..6b27e31f5bf 100644 --- a/ocaml/xapi-idl/network/network_interface.ml +++ b/ocaml/xapi-idl/network/network_interface.ml @@ -34,19 +34,27 @@ let comp f g x = f (g x) let ( ++ ) f g x = comp f g x let netmask_to_prefixlen netmask = - Scanf.sscanf netmask "%d.%d.%d.%d" (fun a b c d -> - let rec length l x = if x > 0 then length (succ l) (x lsr 1) else l in - let masks = List.map (( - ) 255) [a; b; c; d] in - 32 - List.fold_left length 0 masks + let raise_on_ipaddr_err = function + | `Msg str -> + failwith + (Printf.sprintf "%s: Failed to parse the netmask %s (%s)" __FUNCTION__ + netmask str + ) + in + Ipaddr.V4.( + match of_string netmask with + | Ok ip_t -> ( + match Prefix.of_netmask ~address:ip_t ~netmask:ip_t with + | Ok x -> + Prefix.bits x + | Error e -> + raise_on_ipaddr_err e + ) + | Error e -> + raise_on_ipaddr_err e ) -let prefixlen_to_netmask len = - let mask l = - if l <= 0 then 0 else if l > 8 then 255 else 256 - (1 lsl (8 - l)) - in - let lens = [len; len - 8; len - 16; len - 24] in - let masks = List.map (string_of_int ++ mask) lens in - String.concat "." masks +let prefixlen_to_netmask len = Ipaddr.V4.(Prefix.mask len |> to_string) module Unix = struct include Unix diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index b7dcd95dc79..22b37b509ac 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -77,6 +77,7 @@ http_lib httpsvr ipaddr + ipaddr.unix magic-mime message-switch-core message-switch-unix diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 6c0a5d59075..c3111cae93a 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -1114,31 +1114,55 @@ let assert_is_valid_ip kind field address = if not (is_valid_ip kind address) then raise Api_errors.(Server_error (invalid_ip_address_specified, [field])) +module type AbstractIpaddr = sig + type t + + module Prefix : sig + type addr = t + + type t + + val of_string : string -> (t, [> `Msg of string]) result + + val address : t -> addr + + val bits : t -> int + end + + val to_string : t -> string +end + let parse_cidr kind cidr = - try - let address, prefixlen = Scanf.sscanf cidr "%s@/%d" (fun a p -> (a, p)) in - if not (is_valid_ip kind address) then ( - error "Invalid address in CIDR (%s)" address ; - None - ) else if - prefixlen < 0 - || (kind = `ipv4 && prefixlen > 32) - || (kind = `ipv6 && prefixlen > 128) - then ( - error "Invalid prefix length in CIDR (%d)" prefixlen ; - None - ) else + let select_ip_family = function + | `ipv4 -> + (module Ipaddr.V4 : AbstractIpaddr) + | `ipv6 -> + (module Ipaddr.V6) + in + let module AddrParse = (val select_ip_family kind) in + match AddrParse.Prefix.of_string cidr with + | Ok ip_t -> + let address = AddrParse.Prefix.address ip_t |> AddrParse.to_string in + let prefixlen = AddrParse.Prefix.bits ip_t in Some (address, prefixlen) - with _ -> - error "Invalid CIDR format (%s)" cidr ; - None + | Error e -> + let msg = match e with `Msg str -> str in + error "Invalid address in CIDR (%s). %s" cidr msg ; + None + +let valid_cidr_aux kind cidr = + match kind with + | `ipv4or6 -> + parse_cidr `ipv4 cidr = None && parse_cidr `ipv6 cidr = None + | (`ipv4 | `ipv6) as kind -> + parse_cidr kind cidr = None let assert_is_valid_cidr kind field cidr = - if parse_cidr kind cidr = None then + if valid_cidr_aux kind cidr then raise Api_errors.(Server_error (invalid_cidr_address_specified, [field])) let assert_is_valid_ip_addr kind field address = - if (not (is_valid_ip kind address)) && parse_cidr kind address = None then + if (not (is_valid_ip kind address)) && valid_cidr_aux kind address then raise Api_errors.(Server_error (invalid_ip_address_specified, [field])) (** Return true if the MAC is in the right format XX:XX:XX:XX:XX:XX *) diff --git a/ocaml/xapi/nm.ml b/ocaml/xapi/nm.ml index 5db9cb9a29f..d2f121bd3f1 100644 --- a/ocaml/xapi/nm.ml +++ b/ocaml/xapi/nm.ml @@ -613,18 +613,18 @@ let bring_pif_up ~__context ?(management_interface = false) (pif : API.ref_PIF) let addresses = List.filter_map (fun addr_and_prefixlen -> - try - let n = String.index addr_and_prefixlen '/' in - let addr = - Unix.inet_addr_of_string - (String.sub addr_and_prefixlen 0 n) + let ( let* ) = Option.bind in + Ipaddr.V6.( + let* ip_t = + Result.to_option + (Prefix.of_string addr_and_prefixlen) in - let prefixlen = - int_of_string - (String.sub_to_end addr_and_prefixlen (n + 1)) + let addr = + Prefix.address ip_t |> Ipaddr_unix.V6.to_inet_addr in + let prefixlen = Prefix.bits ip_t in Some (addr, prefixlen) - with _ -> None + ) ) rc.API.pIF_IPv6 in @@ -714,9 +714,16 @@ let bring_pif_up ~__context ?(management_interface = false) (pif : API.ref_PIF) | [] -> "" | hd :: _ -> ( - (* IPv6 addresses are stored with this format: / *) - match String.split_on_char '/' hd with [ip; _] -> ip | _ -> "" - ) + (* IPv6 addresses are stored with this format: / *) + Ipaddr.V6.( + match Prefix.of_string hd with + | Ok ip_t -> + Prefix.address ip_t |> to_string + | _ -> + debug "%s not an IPv6 prefix: %s" __FUNCTION__ hd ; + "" + ) + ) ) in if new_ip <> pif_ip then ( From 471141de18124ce448ff43d1bdfd0a0ce3294d95 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 12 Jul 2024 11:11:11 +0100 Subject: [PATCH 61/65] dune: fix tests to packages Otherwise the tests are run as part of every package when installing them using opam, leading to failures Signed-off-by: Pau Ruiz Safont --- ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune | 1 + ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune | 1 + ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune | 4 +++- ocaml/tests/record_util/dune | 1 + 4 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune index 9a8fdf9dc73..a70e4820c9b 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-fdcaps/test/dune @@ -5,5 +5,6 @@ ) (cram + (package xapi-stdext-unix) (deps (package xapi-stdext-unix)) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune index 4db49ea52e2..f7e9141c3a9 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune @@ -10,6 +10,7 @@ ) (test (name threadext_test) + (package xapi-stdext-threads) (modules threadext_test) (libraries xapi_stdext_threads alcotest mtime.clock.os mtime fmt) ) 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 1e00c17bef6..407d025a8a8 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/test/dune @@ -1,5 +1,6 @@ (test (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) ; use fixed seed to avoid causing random failures in CI and package builds @@ -12,9 +13,10 @@ (action (run %{dep:unixext_test.exe} -v -bt)) ) -(executable +(test (modes exe) (name test_systemd) + (package xapi-stdext-unix) (modules test_systemd) (libraries xapi-stdext-unix)) diff --git a/ocaml/tests/record_util/dune b/ocaml/tests/record_util/dune index ec5847bc3e8..a91a104da5c 100644 --- a/ocaml/tests/record_util/dune +++ b/ocaml/tests/record_util/dune @@ -1,5 +1,6 @@ (test (name test_record_util) + (package xapi) (libraries alcotest xapi_cli_server rpclib.core xapi_consts xapi_types astring fmt) (action (run %{test} --show-errors)) ) From 527f57c89f82f4fc6cafc308d3dd7cf642aa53da Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 12 Jul 2024 10:02:52 +0100 Subject: [PATCH 62/65] CP-50259 simplify raising error in record_util Use a function accepting printf-style arguments to raise an error and simplify all the call sites. Signed-off-by: Christian Lindig --- ocaml/xapi-cli-server/record_util.ml | 175 ++++++++++----------------- 1 file changed, 66 insertions(+), 109 deletions(-) diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml index f06e789c932..4b91cbf388e 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -15,6 +15,9 @@ exception Record_failure of string +let record_failure fmt = + Printf.ksprintf (fun msg -> raise (Record_failure msg)) fmt + let to_str = function Rpc.String x -> x | _ -> failwith "Invalid" let certificate_type_to_string = function @@ -157,7 +160,7 @@ let vm_uefi_mode_of_string = function | "user" -> `user | s -> - raise (Record_failure ("Expected 'user','setup', got " ^ s)) + record_failure "Expected 'user','setup', got %s" s let vm_secureboot_readiness_to_string = function | `not_supported -> @@ -385,12 +388,8 @@ let string_to_vif_locking_mode = function | "disabled" -> `disabled | s -> - raise - (Record_failure - ("Expected 'network_default', 'locked', 'unlocked', 'disabled', got " - ^ s - ) - ) + record_failure + "Expected 'network_default', 'locked', 'unlocked', 'disabled', got %s" s let vmss_type_to_string = function | `snapshot -> @@ -408,12 +407,8 @@ let string_to_vmss_type = function | "snapshot_with_quiesce" -> `snapshot_with_quiesce | s -> - raise - (Record_failure - ("Expected 'snapshot', 'checkpoint', 'snapshot_with_quiesce', got " - ^ s - ) - ) + record_failure + "Expected 'snapshot', 'checkpoint', 'snapshot_with_quiesce', got %s" s let vmss_frequency_to_string = function | `hourly -> @@ -431,7 +426,7 @@ let string_to_vmss_frequency = function | "weekly" -> `weekly | s -> - raise (Record_failure ("Expected 'hourly', 'daily', 'weekly', got " ^ s)) + record_failure "Expected 'hourly', 'daily', 'weekly', got %s" s let network_default_locking_mode_to_string = function | `unlocked -> @@ -445,7 +440,7 @@ let string_to_network_default_locking_mode = function | "disabled" -> `disabled | s -> - raise (Record_failure ("Expected 'unlocked' or 'disabled', got " ^ s)) + record_failure "Expected 'unlocked' or 'disabled', got %s" s let network_purpose_to_string : API.network_purpose -> string = function | `nbd -> @@ -459,7 +454,7 @@ let string_to_network_purpose : string -> API.network_purpose = function | "insecure_nbd" -> `insecure_nbd | s -> - raise (Record_failure ("Expected a network purpose string; got " ^ s)) + record_failure "Expected a network purpose string; got %s" s let vm_appliance_operation_to_string = function | `start -> @@ -647,7 +642,7 @@ let string_to_on_normal_exit s = | "restart" -> `restart | _ -> - raise (Record_failure ("Expected 'destroy' or 'restart', got " ^ s)) + record_failure "Expected 'destroy' or 'restart', got %s" s let on_crash_behaviour_to_string x = match x with @@ -679,14 +674,11 @@ let string_to_on_crash_behaviour s = | "rename_restart" -> `rename_restart | _ -> - raise - (Record_failure - ("Expected 'destroy', 'coredump_and_destroy'," - ^ "'restart', 'coredump_and_restart', 'preserve' or \ - 'rename_restart', got " - ^ s - ) - ) + record_failure + "Expected 'destroy', 'coredump_and_destroy', \ + 'restart','coredump_and_restart', 'preserve' or 'rename_restart', got \ + %s" + s let on_softreboot_behaviour_to_string x = match x with @@ -710,14 +702,11 @@ let string_to_on_softreboot_behaviour s = | "soft_reboot" -> `soft_reboot | _ -> - raise - (Record_failure - ("Expected 'destroy', 'coredump_and_destroy'," - ^ "'restart', 'coredump_and_restart', 'preserve', 'soft_reboot' or \ - 'rename_restart', got " - ^ s - ) - ) + record_failure + "Expected 'destroy', 'coredump_and_destroy', 'restart', \ + 'coredump_and_restart', 'preserve', 'soft_reboot' or \ + 'rename_restart', got %s" + s let host_display_to_string h = match h with @@ -739,7 +728,7 @@ let host_sched_gran_of_string s = | "socket" -> `socket | _ -> - raise (Record_failure ("Expected 'core','cpu', 'socket', got " ^ s)) + record_failure "Expected 'core','cpu', 'socket', got %s" s let host_sched_gran_to_string = function | `core -> @@ -766,10 +755,8 @@ let host_numa_affinity_policy_of_string a = | "default_policy" -> `default_policy | s -> - raise - (Record_failure - ("Expected 'any', 'best_effort' or 'default_policy', got " ^ s) - ) + record_failure "Expected 'any', 'best_effort' or 'default_policy', got %s" + s let pci_dom0_access_to_string x = host_display_to_string x @@ -780,7 +767,7 @@ let string_to_vdi_onboot s = | "reset" -> `reset | _ -> - raise (Record_failure ("Expected 'persist' or 'reset', got " ^ s)) + record_failure "Expected 'persist' or 'reset', got %s" s let string_to_vbd_mode s = match String.lowercase_ascii s with @@ -789,7 +776,7 @@ let string_to_vbd_mode s = | "rw" -> `RW | _ -> - raise (Record_failure ("Expected 'RO' or 'RW', got " ^ s)) + record_failure "Expected 'RO' or 'RW', got %s" s let vbd_mode_to_string = function `RO -> "ro" | `RW -> "rw" @@ -802,7 +789,7 @@ let string_to_vbd_type s = | "floppy" -> `Floppy | _ -> - raise (Record_failure ("Expected 'CD' or 'Disk', got " ^ s)) + record_failure "Expected 'CD' or 'Disk', got %s" s let power_to_string h = match h with @@ -861,7 +848,7 @@ let ip_configuration_mode_of_string m = | "static" -> `Static | s -> - raise (Record_failure ("Expected 'dhcp','none' or 'static', got " ^ s)) + record_failure "Expected 'dhcp','none' or 'static', got %s" s let vif_ipv4_configuration_mode_to_string = function | `None -> @@ -876,7 +863,7 @@ let vif_ipv4_configuration_mode_of_string m = | "static" -> `Static | s -> - raise (Record_failure ("Expected 'none' or 'static', got " ^ s)) + record_failure "Expected 'none' or 'static', got %s" s let ipv6_configuration_mode_to_string = function | `None -> @@ -899,10 +886,7 @@ let ipv6_configuration_mode_of_string m = | "autoconf" -> `Autoconf | s -> - raise - (Record_failure - ("Expected 'dhcp','none' 'autoconf' or 'static', got " ^ s) - ) + record_failure "Expected 'dhcp','none' 'autoconf' or 'static', got %s" s let vif_ipv6_configuration_mode_to_string = function | `None -> @@ -917,7 +901,7 @@ let vif_ipv6_configuration_mode_of_string m = | "static" -> `Static | s -> - raise (Record_failure ("Expected 'none' or 'static', got " ^ s)) + record_failure "Expected 'none' or 'static', got %s" s let primary_address_type_to_string = function | `IPv4 -> @@ -932,7 +916,7 @@ let primary_address_type_of_string m = | "ipv6" -> `IPv6 | s -> - raise (Record_failure ("Expected 'ipv4' or 'ipv6', got " ^ s)) + record_failure "Expected 'ipv4' or 'ipv6', got %s" s let bond_mode_to_string = function | `balanceslb -> @@ -951,7 +935,7 @@ let bond_mode_of_string m = | "lacp" -> `lacp | s -> - raise (Record_failure ("Invalid bond mode. Got " ^ s)) + record_failure "Invalid bond mode. Got %s" s let allocation_algorithm_to_string = function | `depth_first -> @@ -966,7 +950,7 @@ let allocation_algorithm_of_string a = | "breadth-first" -> `breadth_first | s -> - raise (Record_failure ("Invalid allocation algorithm. Got " ^ s)) + record_failure "Invalid allocation algorithm. Got %s" s let pvs_proxy_status_to_string = function | `stopped -> @@ -992,12 +976,8 @@ let bool_of_string s = | "false" | "f" | "no" | "n" | "0" -> false | _ -> - raise - (Record_failure - ("Expected 'true','t','yes','y','1','false','f','no','n','0' got " - ^ s - ) - ) + record_failure + "Expected 'true','t','yes','y','1','false','f','no','n','0' got %s" s let sdn_protocol_of_string s = match String.lowercase_ascii s with @@ -1006,7 +986,7 @@ let sdn_protocol_of_string s = | "pssl" -> `pssl | _ -> - raise (Record_failure ("Expected 'ssl','pssl', got " ^ s)) + record_failure "Expected 'ssl','pssl', got %s" s let sdn_protocol_to_string = function `ssl -> "ssl" | `pssl -> "pssl" @@ -1017,7 +997,7 @@ let tunnel_protocol_of_string s = | "vxlan" -> `vxlan | _ -> - raise (Record_failure ("Expected 'gre','vxlan', got " ^ s)) + record_failure "Expected 'gre','vxlan', got %s" s let tunnel_protocol_to_string = function `gre -> "gre" | `vxlan -> "vxlan" @@ -1090,7 +1070,7 @@ let domain_type_of_string x = | "pvh" -> `pvh | s -> - raise (Record_failure ("Invalid domain type. Got " ^ s)) + record_failure "Invalid domain type. Got %s" s let vtpm_operation_to_string (op : API.vtpm_operations) = match op with `destroy -> "destroy" @@ -1106,36 +1086,25 @@ let bytes_of_string field x = try Int64.of_string s with _ -> if s = "" then - raise - (Record_failure - (Printf.sprintf - "Failed to parse field '%s': expecting an integer (possibly \ - with suffix)" - field - ) - ) ; + record_failure + "Failed to parse field '%s': expecting an integer (possibly with \ + suffix)" + field ; + let alldigit = ref true and i = ref (String.length s - 1) in while !alldigit && !i > 0 do alldigit := Astring.Char.Ascii.is_digit s.[!i] ; decr i done ; if !alldigit then - raise - (Record_failure - (Printf.sprintf - "Failed to parse field '%s': number too big (maximum = %Ld TiB)" - field max_size_TiB - ) - ) + record_failure + "Failed to parse field '%s': number too big (maximum = %Ld TiB)" field + max_size_TiB else - raise - (Record_failure - (Printf.sprintf - "Failed to parse field '%s': expecting an integer (possibly \ - with suffix)" - field - ) - ) + record_failure + "Failed to parse field '%s': expecting an integer (possibly with \ + suffix)" + field in match Astring.( @@ -1159,14 +1128,10 @@ let bytes_of_string field x = | [number] -> int64_of_string number | _ -> - raise - (Record_failure - (Printf.sprintf - "Failed to parse field '%s': expecting an integer \ - (possibly with suffix)" - field - ) - ) + record_failure + "Failed to parse field '%s': expecting an integer (possibly with \ + suffix)" + field in let multiplier = match suffix with @@ -1181,26 +1146,18 @@ let bytes_of_string field x = | "TiB" -> 1024L ** 1024L ** 1024L ** 1024L | x -> - raise - (Record_failure - (Printf.sprintf - "Failed to parse field '%s': Unknown suffix: '%s' (try \ - KiB, MiB, GiB or TiB)" - field x - ) - ) + record_failure + "Failed to parse field '%s': Unknown suffix: '%s' (try KiB, MiB, \ + GiB or TiB)" + field x in (* FIXME: detect overflow *) number ** multiplier | _ -> - raise - (Record_failure - (Printf.sprintf - "Failed to parse field '%s': expecting an integer (possibly with \ - suffix)" - field - ) - ) + record_failure + "Failed to parse field '%s': expecting an integer (possibly with \ + suffix)" + field (* Vincent's random mac utils *) @@ -1226,7 +1183,7 @@ let update_sync_frequency_of_string s = | "weekly" -> `weekly | _ -> - raise (Record_failure ("Expected 'daily', 'weekly', got " ^ s)) + record_failure "Expected 'daily', 'weekly', got %s" s let vm_placement_policy_to_string = function | `normal -> @@ -1241,4 +1198,4 @@ let vm_placement_policy_of_string a = | "anti-affinity" -> `anti_affinity | s -> - raise (Record_failure ("Invalid VM placement policy, got " ^ s)) + record_failure "Invalid VM placement policy, got %s" s From 2e5902967b2660bbf90dc76265015dc2d8e4479d Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 12 Jul 2024 10:02:52 +0100 Subject: [PATCH 63/65] CP-50259 simplify parsing size with kib, mib, etc suffix Simplify the implementation. Signed-off-by: Christian Lindig --- ocaml/xapi-cli-server/record_util.ml | 112 +++++++-------------------- 1 file changed, 29 insertions(+), 83 deletions(-) diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml index 4b91cbf388e..6d25858d135 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -1075,91 +1075,37 @@ let domain_type_of_string x = let vtpm_operation_to_string (op : API.vtpm_operations) = match op with `destroy -> "destroy" -(** Parse a string which might have a units suffix on the end *) -let bytes_of_string field x = +(** parse [0-9]*(b|bytes|kib|mib|gib|tib)* to bytes *) +let bytes_of_string str = let ( ** ) a b = Int64.mul a b in - let max_size_TiB = - Int64.div Int64.max_int (1024L ** 1024L ** 1024L ** 1024L) - in - (* detect big number that cannot be represented by Int64. *) - let int64_of_string s = - try Int64.of_string s - with _ -> - if s = "" then - record_failure - "Failed to parse field '%s': expecting an integer (possibly with \ - suffix)" - field ; - - let alldigit = ref true and i = ref (String.length s - 1) in - while !alldigit && !i > 0 do - alldigit := Astring.Char.Ascii.is_digit s.[!i] ; - decr i - done ; - if !alldigit then - record_failure - "Failed to parse field '%s': number too big (maximum = %Ld TiB)" field - max_size_TiB - else - record_failure - "Failed to parse field '%s': expecting an integer (possibly with \ - suffix)" - field - in - match - Astring.( - String.fields ~empty:false ~is_sep:(fun c -> - Char.Ascii.(is_white c || is_digit c) - ) - ) - x - with - | [] -> - (* no suffix on the end *) - int64_of_string x - | [suffix] -> - let number = - match - Astring.( - String.fields ~empty:false ~is_sep:(Fun.negate Char.Ascii.is_digit) - ) - x - with - | [number] -> - int64_of_string number - | _ -> - record_failure - "Failed to parse field '%s': expecting an integer (possibly with \ - suffix)" - field - in - let multiplier = - match suffix with - | "bytes" -> - 1L - | "KiB" -> - 1024L - | "MiB" -> - 1024L ** 1024L - | "GiB" -> - 1024L ** 1024L ** 1024L - | "TiB" -> - 1024L ** 1024L ** 1024L ** 1024L - | x -> - record_failure - "Failed to parse field '%s': Unknown suffix: '%s' (try KiB, MiB, \ - GiB or TiB)" - field x - in - (* FIXME: detect overflow *) - number ** multiplier - | _ -> - record_failure - "Failed to parse field '%s': expecting an integer (possibly with \ - suffix)" - field + let invalid msg = raise (Invalid_argument msg) in + try + Scanf.sscanf str "%Ld%s" @@ fun size suffix -> + match String.lowercase_ascii suffix with + | _ when size < 0L -> + invalid str + | "bytes" | "b" | "" -> + size + | "kib" | "kb" | "k" -> + size ** 1024L + | "mib" | "mb" | "m" -> + size ** 1024L ** 1024L + | "gib" | "gb" | "g" -> + size ** 1024L ** 1024L ** 1024L + | "tib" | "tb" | "t" -> + size ** 1024L ** 1024L ** 1024L ** 1024L + | _ -> + invalid suffix + with _ -> invalid str -(* Vincent's random mac utils *) +(** Parse a string which might have a units suffix on the end *) +let bytes_of_string field x = + try bytes_of_string x + with Invalid_argument _ -> + record_failure + "Failed to parse field '%s': expecting an integer (possibly with suffix \ + KiB, MiB, GiB, TiB), got '%s'" + field x let mac_from_int_array macs = (* make sure bit 1 (local) is set and bit 0 (unicast) is clear *) From d2046564f723f5c5665b973c4dbc778e720991d1 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 12 Jul 2024 13:36:28 +0000 Subject: [PATCH 64/65] Update datamodel lifecycle Signed-off-by: Rob Hoes --- ocaml/idl/datamodel_lifecycle.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index 763b3944caa..089986a5625 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -1,6 +1,6 @@ let prototyped_of_class = function | "VM_group" -> - Some "24.18.0-next" + Some "24.19.1" | "Observer" -> Some "23.14.0" | "VTPM" -> @@ -10,9 +10,9 @@ let prototyped_of_class = function let prototyped_of_field = function | "VM_group", "VMs" -> - Some "24.18.0-next" + Some "24.19.1" | "VM_group", "placement" -> - Some "24.18.0-next" + Some "24.19.1" | "Observer", "enabled" -> Some "23.14.0" | "Observer", "components" -> @@ -66,7 +66,7 @@ let prototyped_of_field = function | "host", "last_software_update" -> Some "22.20.0" | "VM", "groups" -> - Some "24.18.0-next" + Some "24.19.1" | "VM", "pending_guidances_full" -> Some "24.10.0" | "VM", "pending_guidances_recommended" -> @@ -76,7 +76,7 @@ let prototyped_of_field = function | "VM", "actions__after_softreboot" -> Some "23.1.0" | "pool", "recommendations" -> - Some "24.18.0-next" + Some "24.19.1" | "pool", "update_sync_enabled" -> Some "23.18.0" | "pool", "update_sync_day" -> @@ -154,7 +154,7 @@ let prototyped_of_message = function | "VM", "restart_device_models" -> Some "23.30.0" | "VM", "set_groups" -> - Some "24.18.0-next" + Some "24.19.1" | "pool", "get_guest_secureboot_readiness" -> Some "24.17.0" | "pool", "set_ext_auth_max_threads" -> From f0bbfa57cd80070bd26fce444fe0b0a9540557a3 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 12 Jul 2024 15:47:48 +0100 Subject: [PATCH 65/65] fixup! CP-50259 simplify parsing size with kib, mib, etc suffix Signed-off-by: Christian Lindig --- ocaml/xapi-cli-server/record_util.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml index 6d25858d135..105615fedfd 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -1080,7 +1080,7 @@ let bytes_of_string str = let ( ** ) a b = Int64.mul a b in let invalid msg = raise (Invalid_argument msg) in try - Scanf.sscanf str "%Ld%s" @@ fun size suffix -> + Scanf.sscanf str "%Ld %s" @@ fun size suffix -> match String.lowercase_ascii suffix with | _ when size < 0L -> invalid str