From 99c43569a02cbfd7d4635309cd5b9a517f0d99f0 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 19 Jun 2024 16:34:20 +0100 Subject: [PATCH 1/5] Transition from exception-raising Unix.getenv to Sys.getenv_opt with explicit handling of failure cases. OCaml's stdlib has Sys.getenv_opt since 4.05. Some of the newer code already uses it, and some of the old code handled exceptions (so could nicely be transitioned to handling options instead). Some, however, did not handle failure at all. This commit remedies that. In most cases, getenv is used to query the PATH variable (before adding another directory to it, for example), in which case there is a nice default value of "". In some cases, the environment variable is required to be present to proceed, then there is a failure of some kind raised with the appropriate message. A test case was added to the quality-gate.sh script to prevent introduction of the exception-raising Unix.getenv into new code. Signed-off-by: Andrii Sultanov --- ocaml/libs/stunnel/stunnel.ml | 54 +++++++++++-------- ocaml/networkd/lib/network_utils.ml | 6 ++- ocaml/tapctl/tapctl.ml | 11 ++-- ocaml/xapi-idl/lib/coverage/enabled.ml | 11 ++-- ocaml/xapi-idl/lib/xcp_service.ml | 20 ++++--- .../org.xen.xcp.storage.plainlvm/common.ml | 12 +++-- ocaml/xapi/helpers.ml | 6 ++- ocaml/xapi/xapi_host.ml | 2 +- ocaml/xapi/xapi_support.ml | 2 +- ocaml/xapi/xha_scripts.ml | 8 ++- ocaml/xe-cli/newcli.ml | 4 +- ocaml/xe-cli/options.ml | 2 +- ocaml/xenopsd/cli/xn.ml | 3 +- ocaml/xsh/xsh.ml | 6 ++- quality-gate.sh | 12 +++++ 15 files changed, 108 insertions(+), 51 deletions(-) diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index aaaf3dd7d2a..7003efe2d9f 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -35,27 +35,38 @@ let stunnel_logger = ref ignore let timeoutidle = ref None let init_stunnel_path () = - try cached_stunnel_path := Some (Unix.getenv "XE_STUNNEL") - with Not_found -> - let choices = - [ - "/opt/xensource/libexec/stunnel/stunnel" - ; "/usr/sbin/stunnel4" - ; "/usr/sbin/stunnel" - ; "/usr/bin/stunnel4" - ; "/usr/bin/stunnel" - ] - in - let rec choose l = - match l with - | [] -> - raise Stunnel_binary_missing - | p :: ps -> ( - try Unix.access p [Unix.X_OK] ; p with _ -> choose ps + cached_stunnel_path := + Some + ( match Sys.getenv_opt "XE_STUNNEL" with + | Some x -> + x + | None -> + let choices = + [ + "/opt/xensource/libexec/stunnel/stunnel" + ; "/usr/sbin/stunnel4" + ; "/usr/sbin/stunnel" + ; "/usr/bin/stunnel4" + ; "/usr/bin/stunnel" + ] + in + + let choose l = + match + List.find_opt + (fun el -> + try Unix.access el [Unix.X_OK] ; true with _ -> false + ) + l + with + | Some p -> + p + | None -> + raise Stunnel_binary_missing + in + let path = choose choices in + path ) - in - let path = choose choices in - cached_stunnel_path := Some path let stunnel_path () = if Option.is_none !cached_stunnel_path then @@ -150,7 +161,8 @@ let debug_conf_of_bool verbose : string = if verbose then "debug=authpriv.7" else "debug=authpriv.5" let debug_conf_of_env () : string = - (try Unix.getenv "debug_stunnel" with _ -> "") |> String.lowercase_ascii + Option.value (Sys.getenv_opt "debug_stunnel") ~default:"" + |> String.lowercase_ascii |> fun x -> List.mem x ["yes"; "true"; "1"] |> debug_conf_of_bool let config_file ?(accept = None) config host port = diff --git a/ocaml/networkd/lib/network_utils.ml b/ocaml/networkd/lib/network_utils.ml index 1c7479e83e5..fe371e694de 100644 --- a/ocaml/networkd/lib/network_utils.ml +++ b/ocaml/networkd/lib/network_utils.ml @@ -112,7 +112,11 @@ let check_n_run ?(on_error = default_error_handler) ?(log = true) run_func try Unix.access script [Unix.X_OK] ; (* Use the same $PATH as xapi *) - let env = [|"PATH=" ^ Sys.getenv "PATH"|] in + let env = + Option.fold ~none:[||] + ~some:(fun p -> [|"PATH=" ^ p|]) + (Sys.getenv_opt "PATH") + in if log then info "%s %s" script (String.concat " " args) ; run_func env script args diff --git a/ocaml/tapctl/tapctl.ml b/ocaml/tapctl/tapctl.ml index 109e95df3f6..5e043c49270 100644 --- a/ocaml/tapctl/tapctl.ml +++ b/ocaml/tapctl/tapctl.ml @@ -336,9 +336,12 @@ let canonicalise x = if not (Filename.is_relative x) then x else (* Search the PATH and XCP_PATH for the executable *) - let paths = Astring.String.cuts ~sep:":" ~empty:false (Sys.getenv "PATH") in + let path_env_var = Option.value (Sys.getenv_opt "PATH") ~default:"" in + let paths = Astring.String.cuts ~sep:":" ~empty:false path_env_var in let xen_paths = - try Astring.String.cuts ~sep:":" ~empty:false (Sys.getenv "XCP_PATH") + try + Astring.String.cuts ~sep:":" ~empty:false + (Option.value (Sys.getenv_opt "XCP_PATH") ~default:"") with _ -> [] in let first_hit = @@ -361,7 +364,9 @@ let canonicalise x = let tap_ctl = canonicalise "tap-ctl" let invoke_tap_ctl _ cmd args = - let find x = try [x ^ "=" ^ Sys.getenv x] with _ -> [] in + let find x = + match Sys.getenv_opt x with Some v -> [x ^ "=" ^ v] | None -> [] + in let env = Array.of_list (find "PATH" @ find "TAPDISK" @ find "TAPDISK2") in let stdout, _ = execute_command_get_output ~env tap_ctl (cmd :: args) in stdout diff --git a/ocaml/xapi-idl/lib/coverage/enabled.ml b/ocaml/xapi-idl/lib/coverage/enabled.ml index ac128055d75..461221db512 100644 --- a/ocaml/xapi-idl/lib/coverage/enabled.ml +++ b/ocaml/xapi-idl/lib/coverage/enabled.ml @@ -9,7 +9,13 @@ module Bisect = struct let bisect_file = "BISECT_FILE" let dump jobid = - let bisect_prefix = Unix.getenv bisect_file in + let bisect_prefix = + match Sys.getenv_opt bisect_file with + | Some x -> + x + | None -> + D.warn "No $BISECT_FILE default set: %s" __LOC__ + in (* dump coverage information in same location as it would normally get dumped on exit, except also embed the jobid to make it easier to group. Relies on [open_temp_file] generating a unique filename given a @@ -39,8 +45,7 @@ module Bisect = struct let init_env name = let ( // ) = Filename.concat in let tmpdir = Filename.get_temp_dir_name () in - try ignore (Sys.getenv bisect_file) - with Not_found -> + if Option.is_none (Sys.getenv_opt bisect_file) then Unix.putenv bisect_file (tmpdir // Printf.sprintf "bisect-%s-" name) let process body = diff --git a/ocaml/xapi-idl/lib/xcp_service.ml b/ocaml/xapi-idl/lib/xcp_service.ml index 123acd4a249..d0cfc658de2 100644 --- a/ocaml/xapi-idl/lib/xcp_service.ml +++ b/ocaml/xapi-idl/lib/xcp_service.ml @@ -364,24 +364,22 @@ let canonicalise x = if not (Filename.is_relative x) then x else (* Search the PATH and XCP_PATH for the executable *) - let paths = split_c ':' (Sys.getenv "PATH") in + let paths = + split_c ':' (Option.value (Sys.getenv_opt "PATH") ~default:"") + in let first_hit = - List.fold_left - (fun found path -> - match found with - | Some _hit -> - found - | None -> - let possibility = Filename.concat path x in - if Sys.file_exists possibility then Some possibility else None + List.find_opt + (fun path -> + let possibility = Filename.concat path x in + Sys.file_exists possibility ) - None (paths @ !extra_search_path) in match first_hit with | None -> warn "Failed to find %s on $PATH ( = %s) or search_path option ( = %s)" - x (Sys.getenv "PATH") + x + (Option.value (Sys.getenv_opt "PATH") ~default:"unset") (String.concat ":" !extra_search_path) ; x | Some hit -> diff --git a/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml b/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml index fe7b15258aa..298099be057 100644 --- a/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml +++ b/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml @@ -126,9 +126,13 @@ let canonicalise x = if not (Filename.is_relative x) then x else (* Search the PATH and XCP_PATH for the executable *) - let paths = Re_str.split colon (Sys.getenv "PATH") in + let paths = + Re_str.split colon (Option.value (Sys.getenv_opt "PATH") ~default:"") + in let xen_paths = - try Re_str.split colon (Sys.getenv "XCP_PATH") with _ -> [] + try + Re_str.split colon (Option.value (Sys.getenv_opt "XCP_PATH") ~default:"") + with _ -> [] in let first_hit = List.fold_left @@ -148,8 +152,8 @@ let canonicalise x = match first_hit with | None -> warn "Failed to find %s on $PATH ( = %s) or $XCP_PATH ( = %s)" x - (Sys.getenv "PATH") - (try Sys.getenv "XCP_PATH" with Not_found -> "unset") ; + (Option.value (Sys.getenv_opt "PATH") ~default:"unset") + (Option.value (Sys.getenv_opt "XCP_PATH") ~default:"unset") ; x | Some hit -> hit diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 69e2ba3ce24..e8ef361edf4 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -85,7 +85,11 @@ let call_script ?(log_output = Always) ?env ?stdin ?timeout script args = Unix.access script [Unix.X_OK] ; (* Use the same $PATH as xapi *) let env = - match env with None -> [|"PATH=" ^ Sys.getenv "PATH"|] | Some env -> env + match env with + | None -> + [|"PATH=" ^ Option.value (Sys.getenv_opt "PATH") ~default:""|] + | Some env -> + env in let output, _ = match stdin with diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 7e767dbd035..a0958a8dd21 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -123,7 +123,7 @@ let bugreport_upload ~__context ~host:_ ~url ~options = if List.mem_assoc "http_proxy" options then List.assoc "http_proxy" options else - try Unix.getenv "http_proxy" with _ -> "" + Option.value (Sys.getenv_opt "http_proxy") ~default:"" in let cmd = Printf.sprintf "%s %s %s" diff --git a/ocaml/xapi/xapi_support.ml b/ocaml/xapi/xapi_support.ml index 7d073b33020..5e65d586776 100644 --- a/ocaml/xapi/xapi_support.ml +++ b/ocaml/xapi/xapi_support.ml @@ -29,7 +29,7 @@ let do_upload label file url options = if List.mem_assoc "http_proxy" options then List.assoc "http_proxy" options else - try Unix.getenv "http_proxy" with _ -> "" + Option.value (Sys.getenv_opt "http_proxy") ~default:"" in let env = Helpers.env_with_path [("URL", url); ("PROXY", proxy)] in match diff --git a/ocaml/xapi/xha_scripts.ml b/ocaml/xapi/xha_scripts.ml index f5c2cae514e..c8f87e412c1 100644 --- a/ocaml/xapi/xha_scripts.ml +++ b/ocaml/xapi/xha_scripts.ml @@ -60,7 +60,13 @@ let ha_script_m = Mutex.create () let call_script ?log_output script args = let path = ha_dir () in let script' = Filename.concat path script in - let env = [|Printf.sprintf "PATH=%s:%s" (Sys.getenv "PATH") path|] in + let env = + [| + Printf.sprintf "PATH=%s:%s" + (Option.value (Sys.getenv_opt "PATH") ~default:"") + path + |] + in try Xapi_stdext_threads.Threadext.Mutex.execute ha_script_m (fun () -> Helpers.call_script ?log_output ~env script' args diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index 3cf21e39abb..a10225cebc0 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -280,7 +280,9 @@ let parse_args = (List.filter (fun (k, v) -> not (set_keyword (k, v))) rcs) in let extras = - let extra_args = try Sys.getenv "XE_EXTRA_ARGS" with Not_found -> "" in + let extra_args = + Option.value (Sys.getenv_opt "XE_EXTRA_ARGS") ~default:"" + in let l = ref [] and pos = ref 0 and i = ref 0 in while !pos < String.length extra_args do if extra_args.[!pos] = ',' then ( diff --git a/ocaml/xe-cli/options.ml b/ocaml/xe-cli/options.ml index e089a30c164..f19067bf3fa 100644 --- a/ocaml/xe-cli/options.ml +++ b/ocaml/xe-cli/options.ml @@ -34,7 +34,7 @@ let parse_lines ls = let read_rc () = try - let home = Sys.getenv "HOME" in + let home = Option.value (Sys.getenv_opt "HOME") ~default:"" in let rc_file = open_in (home ^ "/.xe") in let rec getlines cur = try diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index 0eb6ef5ac1b..a8b10706504 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -1061,7 +1061,8 @@ let xenconsoles = let vncviewer_binary = let n = "vncviewer" in let dirs = - Re.Str.split_delim (Re.Str.regexp_string ":") (Unix.getenv "PATH") + Re.Str.split_delim (Re.Str.regexp_string ":") + (Option.value (Sys.getenv_opt "PATH") ~default:"") in List.fold_left (fun result dir -> diff --git a/ocaml/xsh/xsh.ml b/ocaml/xsh/xsh.ml index 4f563373857..982ff6c346f 100644 --- a/ocaml/xsh/xsh.ml +++ b/ocaml/xsh/xsh.ml @@ -100,7 +100,11 @@ let _ = let host = Sys.argv.(1) in let cmd = Sys.argv.(2) in let session = - try Sys.getenv "XSH_SESSION" with _ -> failwith "Session not provided" + match Sys.getenv_opt "XSH_SESSION" with + | Some x -> + x + | None -> + failwith "Session not provided" in let args = List.map diff --git a/quality-gate.sh b/quality-gate.sh index b504ed69d1b..f12113a215f 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -93,6 +93,17 @@ ocamlyacc () { fi } +unixgetenv () { + N=1 + UNIXGETENV=$(git grep -P -r -o --count 'getenv(?!_opt)' -- **/*.ml | wc -l) + if [ "$UNIXGETENV" -eq "$N" ]; then + echo "OK found $UNIXGETENV usages of exception-raising Unix.getenv in OCaml files." + else + echo "ERROR expected $N usages of exception-raising Unix.getenv in OCaml files, got $UNIXGETENV" 1>&2 + exit 1 + fi +} + list-hd verify-cert mli-files @@ -100,4 +111,5 @@ structural-equality vtpm-unimplemented vtpm-fields ocamlyacc +unixgetenv From 7be240fa5817bd728a1c3897fe223c4e1618ef56 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 26 Jun 2024 16:34:35 +0100 Subject: [PATCH 2/5] Replace Hashtbl.find with Hashtbl.find_opt in trivial cases This avoids two traversals in the cases where Hashtbl.mem is used right before Hashtbl.find: avoiding two traversals, possible data races and the possibility where one would be changed without the other, introducing bugs. Additionally, it handles failure explicitly where it wasn't handled before, and moves from exception handling to matching on options resulting in intentions becoming clearer. This commit only changes trivial cases where little refactoring was necessary. Signed-off-by: Andrii Sultanov --- configure.ml | 17 ++-- ocaml/database/db_backend.ml | 5 +- ocaml/database/db_conn_store.ml | 14 ++-- ocaml/database/stats.ml | 7 +- ocaml/idl/dtd_backend.ml | 15 ++-- ocaml/libs/http-lib/http_svr.ml | 7 +- ocaml/libs/http-lib/mime.ml | 2 +- ocaml/libs/stunnel/stunnel_cache.ml | 7 +- .../vhd/vhd_format_lwt_test/parse_test.ml | 13 ++-- ocaml/libs/xapi-inventory/lib/inventory.ml | 8 +- ocaml/message-switch/core/make.ml | 12 +-- ocaml/message-switch/switch/mswitch.ml | 5 +- ocaml/message-switch/unix/protocol_unix.ml | 12 +-- ocaml/networkd/bin/network_monitor_thread.ml | 70 ++++++++--------- ocaml/perftest/tests.ml | 6 +- ocaml/rrd2csv/src/rrd2csv.ml | 46 +++++------ ocaml/sdk-gen/csharp/gen_csharp_binding.ml | 4 +- ocaml/squeezed/lib/squeeze.ml | 36 +++++---- ocaml/squeezed/src/squeeze_xen.ml | 24 +++--- ocaml/tapctl/tapctl.ml | 7 +- ocaml/tests/test_xapi_vbd_helpers.ml | 8 +- ocaml/xapi-cli-server/cli_frontend.ml | 76 +++++++++--------- ocaml/xapi-cli-server/cli_operations.ml | 4 +- ocaml/xapi-cli-server/cli_util.ml | 49 ++++++------ ocaml/xapi-idl/lib/xcp_service.ml | 3 + ocaml/xapi-storage-script/main.ml | 14 ++-- ocaml/xapi/binpack.ml | 12 +-- ocaml/xapi/db_gc.ml | 19 ++--- ocaml/xapi/db_gc_util.ml | 15 ++-- ocaml/xapi/eventgen.ml | 7 +- ocaml/xapi/export.ml | 9 ++- ocaml/xapi/helpers.ml | 9 ++- ocaml/xapi/localdb.ml | 16 ++-- ocaml/xapi/monitor_dbcalls_cache.ml | 16 ++-- ocaml/xapi/rbac.ml | 10 ++- ocaml/xapi/slave_backup.ml | 16 ++-- ocaml/xapi/sm.ml | 9 ++- ocaml/xapi/storage_access.ml | 2 +- ocaml/xapi/storage_migrate.ml | 2 +- ocaml/xapi/storage_mux.ml | 49 +++++++----- ocaml/xapi/storage_smapiv1.ml | 11 ++- ocaml/xapi/storage_smapiv1_wrapper.ml | 23 +++--- ocaml/xapi/system_domains.ml | 2 +- ocaml/xapi/xapi_dr.ml | 7 +- ocaml/xapi/xapi_event.ml | 77 ++++++++++--------- ocaml/xapi/xapi_guest_agent.ml | 50 ++++++------ ocaml/xapi/xapi_ha_vm_failover.ml | 9 ++- ocaml/xapi/xapi_host_helpers.ml | 29 +++---- ocaml/xapi/xapi_pci_helpers.ml | 10 ++- ocaml/xapi/xapi_pool_helpers.ml | 29 +++---- ocaml/xapi/xapi_pool_update.ml | 8 +- ocaml/xapi/xapi_role.ml | 44 +++++------ ocaml/xapi/xapi_sr_operations.ml | 31 ++++---- ocaml/xapi/xapi_vbd_helpers.ml | 31 ++++---- ocaml/xapi/xapi_vdi_helpers.ml | 38 ++++----- ocaml/xapi/xapi_vif_helpers.ml | 28 +++---- ocaml/xapi/xapi_vm.ml | 10 +-- ocaml/xapi/xapi_vusb_helpers.ml | 29 +++---- ocaml/xapi/xapi_xenops.ml | 12 +-- ocaml/xapi/xha_interface.ml | 57 ++++++++------ ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml | 7 +- ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml | 61 +++++++-------- ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml | 75 +++++++++--------- ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml | 8 +- ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml | 22 +++--- ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml | 5 +- ocaml/xcp-rrdd/lib/rrdd/stats.ml | 15 ++-- ocaml/xenopsd/list_domains/list_domains.ml | 8 +- ocaml/xenopsd/xc/device.ml | 5 +- ocaml/xenopsd/xc/readln.ml | 4 +- ocaml/xenopsd/xc/stats.ml | 15 ++-- ocaml/xenopsd/xc/xenops_server_xen.ml | 5 +- 72 files changed, 740 insertions(+), 687 deletions(-) diff --git a/configure.ml b/configure.ml index cfd797beb6b..e5c37d55fbc 100644 --- a/configure.ml +++ b/configure.ml @@ -84,11 +84,12 @@ let () = in List.iter print_endline lines ; (* Expand @LIBEXEC@ in udev rules *) - try - let xenopsd_libexecdir = Hashtbl.find config "XENOPSD_LIBEXECDIR" in - expand "@LIBEXEC@" xenopsd_libexecdir "ocaml/xenopsd/scripts/vif.in" - "ocaml/xenopsd/scripts/vif" ; - expand "@LIBEXEC@" xenopsd_libexecdir - "ocaml/xenopsd/scripts/xen-backend.rules.in" - "ocaml/xenopsd/scripts/xen-backend.rules" - with Not_found -> failwith "xenopsd_libexecdir not set" + match Hashtbl.find_opt config "XENOPSD_LIBEXECDIR" with + | Some xenopsd_libexecdir -> + expand "@LIBEXEC@" xenopsd_libexecdir "ocaml/xenopsd/scripts/vif.in" + "ocaml/xenopsd/scripts/vif" ; + expand "@LIBEXEC@" xenopsd_libexecdir + "ocaml/xenopsd/scripts/xen-backend.rules.in" + "ocaml/xenopsd/scripts/xen-backend.rules" + | None -> + failwith "xenopsd_libexecdir not set" diff --git a/ocaml/database/db_backend.ml b/ocaml/database/db_backend.ml index c5270f68169..92954540c33 100644 --- a/ocaml/database/db_backend.ml +++ b/ocaml/database/db_backend.ml @@ -104,8 +104,5 @@ let is_session_registered session = let get_registered_database session = with_lock db_registration_mutex (fun () -> - if Hashtbl.mem foreign_databases session then - Some (Hashtbl.find foreign_databases session) - else - None + Hashtbl.find_opt foreign_databases session ) diff --git a/ocaml/database/db_conn_store.ml b/ocaml/database/db_conn_store.ml index 0bf1536649e..035020695a0 100644 --- a/ocaml/database/db_conn_store.ml +++ b/ocaml/database/db_conn_store.ml @@ -41,12 +41,14 @@ let read_db_connections () = !db_connections let with_db_conn_lock db_conn f = let db_conn_m = with_lock db_conn_locks_m (fun () -> - try Hashtbl.find db_conn_locks db_conn - with _ -> - (* If we don't have a lock already for this connection then go make one dynamically and use that from then on *) - let new_dbconn_mutex = Mutex.create () in - Hashtbl.replace db_conn_locks db_conn new_dbconn_mutex ; - new_dbconn_mutex + match Hashtbl.find_opt db_conn_locks db_conn with + | Some x -> + x + | None -> + (* If we don't have a lock already for this connection then go make one dynamically and use that from then on *) + let new_dbconn_mutex = Mutex.create () in + Hashtbl.replace db_conn_locks db_conn new_dbconn_mutex ; + new_dbconn_mutex ) in with_lock db_conn_m (fun () -> f ()) diff --git a/ocaml/database/stats.ml b/ocaml/database/stats.ml index 8e7711810c8..8bf4f55de4d 100644 --- a/ocaml/database/stats.ml +++ b/ocaml/database/stats.ml @@ -77,10 +77,9 @@ let sample (name : string) (x : float) : unit = let x' = log x in with_lock timings_m (fun () -> let p = - if Hashtbl.mem timings name then - Hashtbl.find timings name - else - Normal_population.empty + Option.value + (Hashtbl.find_opt timings name) + ~default:Normal_population.empty in let p' = Normal_population.sample p x' in Hashtbl.replace timings name p' diff --git a/ocaml/idl/dtd_backend.ml b/ocaml/idl/dtd_backend.ml index e94cf4a9178..c3b79e91f54 100644 --- a/ocaml/idl/dtd_backend.ml +++ b/ocaml/idl/dtd_backend.ml @@ -110,14 +110,13 @@ let rec strings_of_dtd_element known_els = function let element known_els name children atts = let existing_children = - if Hashtbl.mem known_els name then - match Hashtbl.find known_els name with - | Element (_, c, att) -> - (c, att) - | _ -> - assert false - else - ([], []) + match Hashtbl.find_opt known_els name with + | Some (Element (_, c, att)) -> + (c, att) + | None -> + ([], []) + | _ -> + assert false in let open Xapi_stdext_std.Listext in let el = diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index c824277e5be..e19d1a230e0 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -651,8 +651,11 @@ exception Socket_not_found (* Stop an HTTP server running on a socket *) let stop (socket, _name) = let server = - try Hashtbl.find socket_table socket - with Not_found -> raise Socket_not_found + match Hashtbl.find_opt socket_table socket with + | Some x -> + x + | None -> + raise Socket_not_found in Hashtbl.remove socket_table socket ; server.Server_io.shutdown () diff --git a/ocaml/libs/http-lib/mime.ml b/ocaml/libs/http-lib/mime.ml index c48599c65ad..e8dabaca132 100644 --- a/ocaml/libs/http-lib/mime.ml +++ b/ocaml/libs/http-lib/mime.ml @@ -42,7 +42,7 @@ let default_mime = "text/plain" (** Map a file extension to a MIME type *) let mime_of_ext mime ext = - try Hashtbl.find mime (lowercase ext) with Not_found -> default_mime + Option.value (Hashtbl.find_opt mime (lowercase ext)) ~default:default_mime (** Figure out a mime type from a full filename *) let mime_of_file_name mime fname = diff --git a/ocaml/libs/stunnel/stunnel_cache.ml b/ocaml/libs/stunnel/stunnel_cache.ml index eaf85be89a0..57f361d26ce 100644 --- a/ocaml/libs/stunnel/stunnel_cache.ml +++ b/ocaml/libs/stunnel/stunnel_cache.ml @@ -187,12 +187,7 @@ let add (x : Stunnel.t) = ; verified= x.Stunnel.verified } in - let existing = - if Hashtbl.mem !index ep then - Hashtbl.find !index ep - else - [] - in + let existing = Option.value (Hashtbl.find_opt !index ep) ~default:[] in Hashtbl.replace !index ep (idx :: existing) ; debug "Adding stunnel id %s (idle %.2f) to the cache" (id_of_stunnel x) 0. ; unlocked_gc () diff --git a/ocaml/libs/vhd/vhd_format_lwt_test/parse_test.ml b/ocaml/libs/vhd/vhd_format_lwt_test/parse_test.ml index 02d9b32d456..458c0c7cce6 100644 --- a/ocaml/libs/vhd/vhd_format_lwt_test/parse_test.ml +++ b/ocaml/libs/vhd/vhd_format_lwt_test/parse_test.ml @@ -173,12 +173,13 @@ let initial = {to_close= []; to_unlink= []; child= None; contents= []} let sectors = Hashtbl.create 16 let sector_lookup message = - if Hashtbl.mem sectors message then - Hashtbl.find sectors message - else - let data = fill_sector_with message in - Hashtbl.replace sectors message data ; - data + match Hashtbl.find_opt sectors message with + | Some x -> + x + | None -> + let data = fill_sector_with message in + Hashtbl.replace sectors message data ; + data let execute state = function | Create size -> diff --git a/ocaml/libs/xapi-inventory/lib/inventory.ml b/ocaml/libs/xapi-inventory/lib/inventory.ml index 374780a09f8..867d4a2483e 100644 --- a/ocaml/libs/xapi-inventory/lib/inventory.ml +++ b/ocaml/libs/xapi-inventory/lib/inventory.ml @@ -116,14 +116,16 @@ exception Missing_inventory_key of string let lookup ?default key = M.execute inventory_m (fun () -> if not !loaded_inventory then read_inventory_contents () ; - if Hashtbl.mem inventory key then - Hashtbl.find inventory key - else + match Hashtbl.find_opt inventory key with + | Some x -> + x + | None -> ( match default with | None -> raise (Missing_inventory_key key) | Some v -> v + ) ) let flush_to_disk_locked () = diff --git a/ocaml/message-switch/core/make.ml b/ocaml/message-switch/core/make.ml index 224012909ac..43b7e301a9b 100644 --- a/ocaml/message-switch/core/make.ml +++ b/ocaml/message-switch/core/make.ml @@ -189,14 +189,14 @@ functor (fun (i, m) -> M.Mutex.with_lock requests_m (fun () -> match m.Message.kind with - | Message.Response j -> - if Hashtbl.mem wakener j then + | Message.Response j -> ( + match Hashtbl.find_opt wakener j with + | Some x -> let rec loop events_conn = Connection.rpc events_conn (In.Ack i) >>= function | Ok (_ : string) -> - M.Ivar.fill (Hashtbl.find wakener j) (Ok m) ; - return (Ok ()) + M.Ivar.fill x (Ok m) ; return (Ok ()) | Error _ -> reconnect () >>|= fun (requests_conn, events_conn) -> @@ -205,7 +205,7 @@ functor loop events_conn in loop events_conn - else ( + | None -> Printf.printf "no wakener for id %s, %Ld\n%!" (fst i) (snd i) ; Hashtbl.iter @@ -216,7 +216,7 @@ functor ) wakener ; return (Ok ()) - ) + ) | Message.Request _ -> return (Ok ()) ) diff --git a/ocaml/message-switch/switch/mswitch.ml b/ocaml/message-switch/switch/mswitch.ml index fe57a978382..b674ae65059 100644 --- a/ocaml/message-switch/switch/mswitch.ml +++ b/ocaml/message-switch/switch/mswitch.ml @@ -65,10 +65,7 @@ end let next_transfer_expected : (string, int64) Hashtbl.t = Hashtbl.create 128 let get_next_transfer_expected name = - if Hashtbl.mem next_transfer_expected name then - Some (Hashtbl.find next_transfer_expected name) - else - None + Hashtbl.find_opt next_transfer_expected name let record_transfer time name = Hashtbl.replace next_transfer_expected name time diff --git a/ocaml/message-switch/unix/protocol_unix.ml b/ocaml/message-switch/unix/protocol_unix.ml index 485964a40ec..a9b4984e4f4 100644 --- a/ocaml/message-switch/unix/protocol_unix.ml +++ b/ocaml/message-switch/unix/protocol_unix.ml @@ -294,17 +294,17 @@ module Client = struct (* If the Ack doesn't belong to us then assume it's another thread *) IO.Mutex.with_lock requests_m (fun () -> match m.Message.kind with - | Message.Response j -> - if Hashtbl.mem wakener j then ( + | Message.Response j -> ( + match Hashtbl.find_opt wakener j with + | Some x -> do_rpc t.events_conn (In.Ack i) >>|= fun (_ : string) -> - IO.Ivar.fill (Hashtbl.find wakener j) (Ok m) ; - Ok () - ) else ( + IO.Ivar.fill x (Ok m) ; Ok () + | None -> Printf.printf "no wakener for id %s,%Ld\n%!" (fst i) (snd i) ; Ok () - ) + ) | Message.Request _ -> Ok () ) diff --git a/ocaml/networkd/bin/network_monitor_thread.ml b/ocaml/networkd/bin/network_monitor_thread.ml index 7ec920f329c..43b471be21a 100644 --- a/ocaml/networkd/bin/network_monitor_thread.ml +++ b/ocaml/networkd/bin/network_monitor_thread.ml @@ -63,43 +63,41 @@ let send_bond_change_alert _dev interfaces message = let check_for_changes ~(dev : string) ~(stat : Network_monitor.iface_stats) = let open Network_monitor in match Astring.String.is_prefix ~affix:"vif" dev with - | true -> - () - | false -> - if stat.nb_links > 1 then - if (* It is a bond. *) - Hashtbl.mem bonds_status dev then ( - (* Seen before. *) - let nb_links_old, links_up_old = Hashtbl.find bonds_status dev in - if links_up_old <> stat.links_up then ( - info "Bonds status changed: %s nb_links %d up %d up_old %d" dev - stat.nb_links stat.links_up links_up_old ; - Hashtbl.replace bonds_status dev (stat.nb_links, stat.links_up) ; - let msg = - Printf.sprintf "changed: %d/%d up (was %d/%d)" stat.links_up - stat.nb_links links_up_old nb_links_old - in - try send_bond_change_alert dev stat.interfaces msg - with e -> - debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" - (Printexc.to_string e) - (Printexc.get_backtrace ()) - ) - ) else ( - (* Seen for the first time. *) - Hashtbl.add bonds_status dev (stat.nb_links, stat.links_up) ; - info "New bonds status: %s nb_links %d up %d" dev stat.nb_links - stat.links_up ; - if stat.links_up <> stat.nb_links then - let msg = - Printf.sprintf "is: %d/%d up" stat.links_up stat.nb_links - in - try send_bond_change_alert dev stat.interfaces msg - with e -> - debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" - (Printexc.to_string e) - (Printexc.get_backtrace ()) + | false when stat.nb_links > 1 -> ( + (* It is a bond. *) + match Hashtbl.find_opt bonds_status dev with + | Some (nb_links_old, links_up_old) -> + (* Seen before. *) + if links_up_old <> stat.links_up then ( + info "Bonds status changed: %s nb_links %d up %d up_old %d" dev + stat.nb_links stat.links_up links_up_old ; + Hashtbl.replace bonds_status dev (stat.nb_links, stat.links_up) ; + let msg = + Printf.sprintf "changed: %d/%d up (was %d/%d)" stat.links_up + stat.nb_links links_up_old nb_links_old + in + try send_bond_change_alert dev stat.interfaces msg + with e -> + debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" + (Printexc.to_string e) + (Printexc.get_backtrace ()) ) + | None -> ( + (* Seen for the first time. *) + Hashtbl.add bonds_status dev (stat.nb_links, stat.links_up) ; + info "New bonds status: %s nb_links %d up %d" dev stat.nb_links + stat.links_up ; + if stat.links_up <> stat.nb_links then + let msg = Printf.sprintf "is: %d/%d up" stat.links_up stat.nb_links in + try send_bond_change_alert dev stat.interfaces msg + with e -> + debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" + (Printexc.to_string e) + (Printexc.get_backtrace ()) + ) + ) + | _ -> + () let failed_again = ref false diff --git a/ocaml/perftest/tests.ml b/ocaml/perftest/tests.ml index 5262d4be0ec..d0463e9f60a 100644 --- a/ocaml/perftest/tests.ml +++ b/ocaml/perftest/tests.ml @@ -112,13 +112,13 @@ let parallel_with_vms async_op opname n vms rpc session_id test subtest_name = List.iter (fun task -> if List.mem task !active_tasks then ( - ( if not (Hashtbl.mem tasks_to_vm task) then + ( match Hashtbl.find_opt tasks_to_vm task with + | None -> debug ~out:stderr "Ignoring completed task which doesn't correspond to a \ VM %s" opname - else - let uuid = Hashtbl.find tasks_to_vm task in + | Some uuid -> let started = Hashtbl.find vm_to_start_time uuid in let time_taken = Unix.gettimeofday () -. started in results := time_taken :: !results ; diff --git a/ocaml/rrd2csv/src/rrd2csv.ml b/ocaml/rrd2csv/src/rrd2csv.ml index 4e36e581e5b..13fdef256c4 100644 --- a/ocaml/rrd2csv/src/rrd2csv.ml +++ b/ocaml/rrd2csv/src/rrd2csv.ml @@ -110,30 +110,32 @@ let vm_uuid_to_name_label_map = Hashtbl.create 20 let host_uuid_to_name_label_map = Hashtbl.create 10 let get_vm_name_label vm_uuid = - if Hashtbl.mem vm_uuid_to_name_label_map vm_uuid then - Hashtbl.find vm_uuid_to_name_label_map vm_uuid - else - let name_label, _session_id = - XAPI.retry_with_session - (fun session_id () -> XAPI.get_vm_name_label ~session_id ~uuid:vm_uuid) - () - in - Hashtbl.replace vm_uuid_to_name_label_map vm_uuid name_label ; - name_label + match Hashtbl.find_opt vm_uuid_to_name_label_map vm_uuid with + | Some x -> + x + | None -> + let name_label, _session_id = + XAPI.retry_with_session + (fun session_id () -> XAPI.get_vm_name_label ~session_id ~uuid:vm_uuid) + () + in + Hashtbl.replace vm_uuid_to_name_label_map vm_uuid name_label ; + name_label let get_host_name_label host_uuid = - if Hashtbl.mem host_uuid_to_name_label_map host_uuid then - Hashtbl.find host_uuid_to_name_label_map host_uuid - else - let name_label, _session_id = - XAPI.retry_with_session - (fun session_id () -> - XAPI.get_host_name_label ~session_id ~uuid:host_uuid - ) - () - in - Hashtbl.replace host_uuid_to_name_label_map host_uuid name_label ; - name_label + match Hashtbl.find_opt host_uuid_to_name_label_map host_uuid with + | Some x -> + x + | None -> + let name_label, _session_id = + XAPI.retry_with_session + (fun session_id () -> + XAPI.get_host_name_label ~session_id ~uuid:host_uuid + ) + () + in + Hashtbl.replace host_uuid_to_name_label_map host_uuid name_label ; + name_label module Ds_selector = struct type t = { diff --git a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml index 21483260f5b..0c8b016cb5c 100644 --- a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml +++ b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml @@ -136,8 +136,8 @@ and gen_relations () = and process_relations ((oneClass, oneField), (manyClass, manyField)) = let value = - try (manyField, oneClass, oneField) :: Hashtbl.find relations manyClass - with Not_found -> [(manyField, oneClass, oneField)] + (manyField, oneClass, oneField) + :: Option.value (Hashtbl.find_opt relations manyClass) ~default:[] in Hashtbl.replace relations manyClass value diff --git a/ocaml/squeezed/lib/squeeze.ml b/ocaml/squeezed/lib/squeeze.ml index 30b203c7e8c..bb308c45639 100644 --- a/ocaml/squeezed/lib/squeeze.ml +++ b/ocaml/squeezed/lib/squeeze.ml @@ -171,16 +171,23 @@ module Stuckness_monitor = struct direction_of_actual domain.inaccuracy_kib domain.memory_actual_kib domain.target_kib in - if not (Hashtbl.mem x.per_domain domain.domid) then - Hashtbl.replace x.per_domain domain.domid - (* new domains are considered to be making progress now and not - stuck *) - { - last_actual_kib= domain.memory_actual_kib - ; last_makingprogress_time= now - ; stuck= false - } ; - let state = Hashtbl.find x.per_domain domain.domid in + let state = + match Hashtbl.find_opt x.per_domain domain.domid with + | Some x -> + x + | None -> + (* new domains are considered to be making + progress now and not stuck *) + let new_data = + { + last_actual_kib= domain.memory_actual_kib + ; last_makingprogress_time= now + ; stuck= false + } + in + Hashtbl.replace x.per_domain domain.domid new_data ; + new_data + in let delta_actual = domain.memory_actual_kib -* state.last_actual_kib in state.last_actual_kib <- domain.memory_actual_kib ; (* If memory_actual is moving towards the target then we say we are @@ -229,10 +236,11 @@ module Stuckness_monitor = struct progress. If it is not making progress it may have either hit its target or it may have failed. *) let domid_is_active (x : t) domid (_ : float) = - if not (Hashtbl.mem x.per_domain domid) then - false (* it must have been destroyed *) - else - not (Hashtbl.find x.per_domain domid).stuck + match Hashtbl.find_opt x.per_domain domid with + | Some x -> + not x.stuck + | None -> + false (* it must have been destroyed *) end type fistpoint = diff --git a/ocaml/squeezed/src/squeeze_xen.ml b/ocaml/squeezed/src/squeeze_xen.ml index f4ba7e5accd..496e7d03ea0 100644 --- a/ocaml/squeezed/src/squeeze_xen.ml +++ b/ocaml/squeezed/src/squeeze_xen.ml @@ -125,9 +125,8 @@ module Domain = struct (* get_per_domain can return None if the domain is deleted by someone else while we are processing some other event handlers *) let get_per_domain xc domid = - if Hashtbl.mem cache domid then - Some (Hashtbl.find cache domid) - else + match Hashtbl.find_opt cache domid with + | None -> ( try let path = Printf.sprintf "/local/domain/%d" domid in let di = Xenctrl.domain_getinfo xc domid in @@ -143,6 +142,9 @@ module Domain = struct Hashtbl.replace cache domid d ; Some d with Xenctrl.Error _ -> Hashtbl.remove cache domid ; None + ) + | x -> + x let remove_gone_domains_cache xc = let current_domains = Xenctrl.domain_getinfolist xc 0 in @@ -385,10 +387,11 @@ module Domain = struct match get_per_domain xc domid with | None -> None - | Some per_domain -> - if Hashtbl.mem per_domain.keys key then - Hashtbl.find per_domain.keys key - else + | Some per_domain -> ( + match Hashtbl.find_opt per_domain.keys key with + | Some x -> + x + | None -> let x = try Some @@ -400,6 +403,7 @@ module Domain = struct in Hashtbl.replace per_domain.keys key x ; x + ) ) in match x with Some y -> y | None -> raise (Xs_protocol.Enoent key) @@ -412,10 +416,8 @@ module Domain = struct | None -> () | Some per_domain -> ( - if - (not (Hashtbl.mem per_domain.keys key)) - || Hashtbl.find per_domain.keys key <> Some value - then + if Option.join (Hashtbl.find_opt per_domain.keys key) <> Some value then + (* Don't update if there is the same value bound already *) try Client.transaction (get_client ()) (fun t -> (* Fail if the directory has been deleted *) diff --git a/ocaml/tapctl/tapctl.ml b/ocaml/tapctl/tapctl.ml index 5e043c49270..075eea8aba2 100644 --- a/ocaml/tapctl/tapctl.ml +++ b/ocaml/tapctl/tapctl.ml @@ -339,10 +339,9 @@ let canonicalise x = let path_env_var = Option.value (Sys.getenv_opt "PATH") ~default:"" in let paths = Astring.String.cuts ~sep:":" ~empty:false path_env_var in let xen_paths = - try - Astring.String.cuts ~sep:":" ~empty:false - (Option.value (Sys.getenv_opt "XCP_PATH") ~default:"") - with _ -> [] + (* Can't raise an exception since the separator string isn't empty *) + Astring.String.cuts ~sep:":" ~empty:false + (Option.value (Sys.getenv_opt "XCP_PATH") ~default:"") in let first_hit = List.fold_left diff --git a/ocaml/tests/test_xapi_vbd_helpers.ml b/ocaml/tests/test_xapi_vbd_helpers.ml index 08ea79fda38..0aa4ef0a6d1 100644 --- a/ocaml/tests/test_xapi_vbd_helpers.ml +++ b/ocaml/tests/test_xapi_vbd_helpers.ml @@ -34,11 +34,9 @@ let run_assert_equal_with_vdi ~__context msg ?(expensive_sharing_checks = true) Xapi_vbd_helpers.valid_operations ~__context ~expensive_sharing_checks vbd_record vbd_ref in - match Hashtbl.find valid_ops op with - | Some (code, _) -> - Some code - | None -> - None + Option.map + (fun (code, _) -> code) + (Option.join (Hashtbl.find_opt valid_ops op)) in Alcotest.(check (option string)) msg expected_error_if_any (get_error_code_of op) diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index 3c2c617fddf..ca36ed76d82 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -3887,44 +3887,44 @@ let make_list l = let rio_help printer minimal cmd = let docmd cmd = - try - let cmd_spec = Hashtbl.find cmdtable cmd in - let vm_selectors = List.mem Vm_selectors cmd_spec.flags in - let host_selectors = List.mem Host_selectors cmd_spec.flags in - let sr_selectors = List.mem Sr_selectors cmd_spec.flags in - let optional = - cmd_spec.optn - @ (if vm_selectors then vmselectors else []) - @ (if sr_selectors then srselectors else []) - @ if host_selectors then hostselectors else [] - in - let desc = - match (vm_selectors, host_selectors, sr_selectors) with - | false, false, false -> - cmd_spec.help - | true, false, false -> - cmd_spec.help ^ vmselectorsinfo - | false, true, false -> - cmd_spec.help ^ hostselectorsinfo - | false, false, true -> - cmd_spec.help ^ srselectorsinfo - | _ -> - cmd_spec.help - (* never happens currently *) - in - let recs = - [ - ("command name ", cmd) - ; ("reqd params ", String.concat ", " cmd_spec.reqd) - ; ("optional params ", String.concat ", " optional) - ; ("description ", desc) - ] - in - printer (Cli_printer.PTable [recs]) - with Not_found as e -> - Debug.log_backtrace e (Backtrace.get e) ; - error "Responding with Unknown command %s" cmd ; - printer (Cli_printer.PList ["Unknown command '" ^ cmd ^ "'"]) + match Hashtbl.find_opt cmdtable cmd with + | Some cmd_spec -> + let vm_selectors = List.mem Vm_selectors cmd_spec.flags in + let host_selectors = List.mem Host_selectors cmd_spec.flags in + let sr_selectors = List.mem Sr_selectors cmd_spec.flags in + let optional = + cmd_spec.optn + @ (if vm_selectors then vmselectors else []) + @ (if sr_selectors then srselectors else []) + @ if host_selectors then hostselectors else [] + in + let desc = + match (vm_selectors, host_selectors, sr_selectors) with + | false, false, false -> + cmd_spec.help + | true, false, false -> + cmd_spec.help ^ vmselectorsinfo + | false, true, false -> + cmd_spec.help ^ hostselectorsinfo + | false, false, true -> + cmd_spec.help ^ srselectorsinfo + | _ -> + cmd_spec.help + (* never happens currently *) + in + let recs = + [ + ("command name ", cmd) + ; ("reqd params ", String.concat ", " cmd_spec.reqd) + ; ("optional params ", String.concat ", " optional) + ; ("description ", desc) + ] + in + printer (Cli_printer.PTable [recs]) + | None -> + D.log_backtrace () ; + error "Responding with Unknown command %s" cmd ; + printer (Cli_printer.PList ["Unknown command '" ^ cmd ^ "'"]) in let cmds = List.filter diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 6aee526f497..2e19df44a4c 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -650,7 +650,9 @@ let make_param_funs getallrecs getbyuuid record class_name def_filters set_in_map key v | None, Some set_map -> let existing_params = - try Hashtbl.find set_map_table set_map with Not_found -> [] + Option.value + (Hashtbl.find_opt set_map_table set_map) + ~default:[] in Hashtbl.replace set_map_table set_map ((key, v) :: existing_params) | None, None -> diff --git a/ocaml/xapi-cli-server/cli_util.ml b/ocaml/xapi-cli-server/cli_util.ml index 5d7e9ef3e6d..035494a2957 100644 --- a/ocaml/xapi-cli-server/cli_util.ml +++ b/ocaml/xapi-cli-server/cli_util.ml @@ -254,31 +254,30 @@ let ref_convert x = (* Marshal an API-style server-error *) let get_server_error code params = - try - let error = Hashtbl.find Datamodel.errors code in - (* There ought to be a bijection between parameters mentioned in - datamodel.ml and those in the exception but this is unchecked and - false in some cases, defined here. *) - let required = - if code = Api_errors.vms_failed_to_cooperate then - List.map (fun _ -> "VM") params - else - error.Datamodel_types.err_params - in - (* For the rest we attempt to pretty-print the list even when it's short/long *) - let rec pp_params = function - | t :: ts, v :: vs -> - (t ^ ": " ^ v) :: pp_params (ts, vs) - | [], v :: vs -> - (": " ^ v) :: pp_params ([], vs) - | t :: ts, [] -> - (t ^ ": ") :: pp_params (ts, []) - | [], [] -> - [] - in - let errparams = pp_params (required, List.map ref_convert params) in - Some (error.Datamodel_types.err_doc, errparams) - with _ -> None + let ( let* ) = Option.bind in + let* error = Hashtbl.find_opt Datamodel.errors code in + (* There ought to be a bijection between parameters mentioned in + datamodel.ml and those in the exception but this is unchecked and + false in some cases, defined here. *) + let required = + if code = Api_errors.vms_failed_to_cooperate then + List.map (fun _ -> "VM") params + else + error.Datamodel_types.err_params + in + (* For the rest we attempt to pretty-print the list even when it's short/long *) + let rec pp_params = function + | t :: ts, v :: vs -> + (t ^ ": " ^ v) :: pp_params (ts, vs) + | [], v :: vs -> + (": " ^ v) :: pp_params ([], vs) + | t :: ts, [] -> + (t ^ ": ") :: pp_params (ts, []) + | [], [] -> + [] + in + let errparams = pp_params (required, List.map ref_convert params) in + Some (error.Datamodel_types.err_doc, errparams) let server_error (code : string) (params : string list) sock = match get_server_error code params with diff --git a/ocaml/xapi-idl/lib/xcp_service.ml b/ocaml/xapi-idl/lib/xcp_service.ml index d0cfc658de2..667e51bd74f 100644 --- a/ocaml/xapi-idl/lib/xcp_service.ml +++ b/ocaml/xapi-idl/lib/xcp_service.ml @@ -365,6 +365,9 @@ let canonicalise x = x else (* Search the PATH and XCP_PATH for the executable *) let paths = + (* Might be worth eliminating split_c function (used in a few + more places in this module and replacing it with + Astring.String.cuts since it's already imported in this module *) split_c ':' (Option.value (Sys.getenv_opt "PATH") ~default:"") in let first_hit = diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index fbfc4796220..8b5673701ba 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -1644,13 +1644,13 @@ let watch_volume_plugins ~volume_root ~switch_path ~pipe = in let destroy volume_plugin_name = info "Removing %s" volume_plugin_name ; - if Hashtbl.mem servers volume_plugin_name then ( - let t = Hashtbl.find_exn servers volume_plugin_name in - Message_switch_async.Protocol_async.Server.shutdown ~t () >>= fun () -> - Hashtbl.remove servers volume_plugin_name ; - return () - ) else - return () + match Hashtbl.find servers volume_plugin_name with + | Some t -> + Message_switch_async.Protocol_async.Server.shutdown ~t () >>= fun () -> + Hashtbl.remove servers volume_plugin_name ; + return () + | None -> + return () in let sync () = Sys.readdir volume_root >>= fun names -> diff --git a/ocaml/xapi/binpack.ml b/ocaml/xapi/binpack.ml index cef4730b1cb..e89a775c749 100644 --- a/ocaml/xapi/binpack.ml +++ b/ocaml/xapi/binpack.ml @@ -51,11 +51,13 @@ let biggest_fit_decreasing (things : ('a * int64) list) let memoise f = let table = Hashtbl.create 10 in let rec lookup x = - if Hashtbl.mem table x then - Hashtbl.find table x - else - let result = f lookup x in - Hashtbl.add table x result ; result + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + let result = f lookup x in + Hashtbl.replace table x result ; + result in lookup diff --git a/ocaml/xapi/db_gc.ml b/ocaml/xapi/db_gc.ml index c7fb5d93373..a0442314448 100644 --- a/ocaml/xapi/db_gc.ml +++ b/ocaml/xapi/db_gc.ml @@ -91,12 +91,11 @@ let check_host_liveness ~__context = let live = Db.Host_metrics.get_live ~__context ~self:hmetric in (* See if the host is using the new HB mechanism, if so we'll use that *) let new_heartbeat_time = - try - with_lock host_table_m (fun () -> - Hashtbl.find host_heartbeat_table host - ) - with _ -> 0.0 - (* never *) + with_lock host_table_m (fun () -> + Option.value + (Hashtbl.find_opt host_heartbeat_table host) + ~default:Clock.Date.(epoch |> to_unix_time) + ) in let old_heartbeat_time = if @@ -141,11 +140,9 @@ let check_host_liveness ~__context = ) ; (* Check for clock skew *) detect_clock_skew ~__context host - ( try - with_lock host_table_m (fun () -> - Hashtbl.find host_skew_table host - ) - with _ -> 0. + (with_lock host_table_m (fun () -> + Option.value (Hashtbl.find_opt host_skew_table host) ~default:0. + ) ) with exn -> debug "Ignoring exception inspecting metrics of host %s: %s" diff --git a/ocaml/xapi/db_gc_util.ml b/ocaml/xapi/db_gc_util.ml index eb86d981291..182eaac00df 100644 --- a/ocaml/xapi/db_gc_util.ml +++ b/ocaml/xapi/db_gc_util.ml @@ -322,12 +322,13 @@ let timeout_tasks ~__context = let pending_old_run, pending_old_hung = List.partition (fun (_, t) -> - try - let pre_progress = - Hashtbl.find probation_pending_tasks t.Db_actions.task_uuid - in - t.Db_actions.task_progress -. pre_progress > min_float - with Not_found -> true + match + Hashtbl.find_opt probation_pending_tasks t.Db_actions.task_uuid + with + | Some pre_progress -> + t.Db_actions.task_progress -. pre_progress > min_float + | None -> + true ) pending_old in @@ -505,7 +506,7 @@ let timeout_sessions ~__context = `Name s.Db_actions.session_auth_user_name in let current_sessions = - try Hashtbl.find session_groups key with Not_found -> [] + Option.value (Hashtbl.find_opt session_groups key) ~default:[] in Hashtbl.replace session_groups key (rs :: current_sessions) ) diff --git a/ocaml/xapi/eventgen.ml b/ocaml/xapi/eventgen.ml index 274e74abb78..f03db1e9bed 100644 --- a/ocaml/xapi/eventgen.ml +++ b/ocaml/xapi/eventgen.ml @@ -22,10 +22,9 @@ let get_record_table : Hashtbl.create 20 let find_get_record x ~__context ~self () : Rpc.t option = - if Hashtbl.mem get_record_table x then - Some (Hashtbl.find get_record_table x ~__context ~self ()) - else - None + Option.map + (fun x -> x ~__context ~self ()) + (Hashtbl.find_opt get_record_table x) (* If a record is created or destroyed, then for any (Ref _) field which is one end of a relationship, need to send diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 326efdaf067..6cb156d21ca 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -157,10 +157,11 @@ let create_table () = Hashtbl.create 10 (** Convert an internal reference into an external one or NULL *) let lookup table r = - if not (Hashtbl.mem table r) then - Ref.null - else - Ref.of_string (Hashtbl.find table r) + match Hashtbl.find_opt table r with + | Some x -> + Ref.of_string x + | None -> + Ref.null (** Convert a list of internal references into external references, filtering out NULLs *) let filter table rs = diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index e8ef361edf4..4504e56fcdb 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -1572,9 +1572,12 @@ module Early_wakeup = struct let signal key = (*debug "Early_wakeup signal key = (%s, %s)" a b;*) with_lock table_m (fun () -> - if Hashtbl.mem table key then - (*debug "Signalling thread blocked on (%s,%s)" a b;*) - Delay.signal (Hashtbl.find table key) + Option.iter + (fun x -> + (*debug "Signalling thread blocked on (%s,%s)" a b;*) + Delay.signal x + ) + (Hashtbl.find_opt table key) ) end diff --git a/ocaml/xapi/localdb.ml b/ocaml/xapi/localdb.ml index 0cfa222138c..3382c42e32a 100644 --- a/ocaml/xapi/localdb.ml +++ b/ocaml/xapi/localdb.ml @@ -66,7 +66,11 @@ let m = Mutex.create () let get (key : string) = with_lock m (fun () -> assert_loaded () ; - try Hashtbl.find db key with Not_found -> raise (Missing_key key) + match Hashtbl.find_opt db key with + | Some x -> + x + | None -> + raise (Missing_key key) ) let get_with_default (key : string) (default : string) = @@ -74,11 +78,11 @@ let get_with_default (key : string) (default : string) = (* Returns true if a change was made and should be flushed *) let put_one (key : string) (v : string) = - if Hashtbl.mem db key && Hashtbl.find db key = v then - false (* no change necessary *) - else ( - Hashtbl.replace db key v ; true - ) + match Hashtbl.find_opt db key with + | Some x when x = v -> + false (* no change necessary *) + | _ -> + Hashtbl.replace db key v ; true let flush () = let b = Buffer.create 256 in diff --git a/ocaml/xapi/monitor_dbcalls_cache.ml b/ocaml/xapi/monitor_dbcalls_cache.ml index 507500b20dc..a0aad3d1766 100644 --- a/ocaml/xapi/monitor_dbcalls_cache.ml +++ b/ocaml/xapi/monitor_dbcalls_cache.ml @@ -96,8 +96,11 @@ let clear_cache () = let transfer_map ?(except = []) ~source ~target () = List.iter (fun ex -> - try Hashtbl.replace source ex (Hashtbl.find target ex) - with Not_found -> Hashtbl.remove source ex + match Hashtbl.find_opt target ex with + | Some elem -> + Hashtbl.replace source ex elem + | None -> + Hashtbl.remove source ex ) except ; Hashtbl.clear target ; @@ -107,10 +110,11 @@ let transfer_map ?(except = []) ~source ~target () = let get_updates ~before ~after ~f = Hashtbl.fold (fun k v acc -> - if try v <> Hashtbl.find before k with Not_found -> true then - f k v acc - else - acc + match Hashtbl.find_opt before k with + | Some x when v = x -> + acc + | _ -> + f k v acc ) after [] diff --git a/ocaml/xapi/rbac.ml b/ocaml/xapi/rbac.ml index c304b5a991d..5b442f11a4a 100644 --- a/ocaml/xapi/rbac.ml +++ b/ocaml/xapi/rbac.ml @@ -149,10 +149,12 @@ let is_permission_in_session ~session_id ~permission ~session = let find_linear elem set = List.exists (fun e -> e = elem) set in let find_log elem set = Permission_set.mem elem set in let permission_tree = - try Some (Hashtbl.find session_permissions_tbl session_id) - with Not_found -> - create_session_permissions_tbl ~session_id - ~rbac_permissions:session.API.session_rbac_permissions + match Hashtbl.find_opt session_permissions_tbl session_id with + | None -> + create_session_permissions_tbl ~session_id + ~rbac_permissions:session.API.session_rbac_permissions + | x -> + x in match permission_tree with | Some permission_tree -> diff --git a/ocaml/xapi/slave_backup.ml b/ocaml/xapi/slave_backup.ml index aeb3e3e1e95..6a8a41c8a90 100644 --- a/ocaml/xapi/slave_backup.ml +++ b/ocaml/xapi/slave_backup.ml @@ -34,13 +34,15 @@ let with_backup_lock f = Xapi_stdext_threads.Threadext.Mutex.execute backup_m f log it in table and return that *) (* IMPORTANT: must be holding backup_m mutex when you call this function.. *) let lookup_write_entry dbconn = - try Hashtbl.find backup_write_table dbconn - with _ -> - let new_write_entry = - {period_start_time= Unix.gettimeofday (); writes_this_period= 0} - in - Hashtbl.replace backup_write_table dbconn new_write_entry ; - new_write_entry + match Hashtbl.find_opt backup_write_table dbconn with + | Some x -> + x + | None -> + let new_write_entry = + {period_start_time= Unix.gettimeofday (); writes_this_period= 0} + in + Hashtbl.replace backup_write_table dbconn new_write_entry ; + new_write_entry (* Reset period_start_time, writes_this_period if period has expired *) let tick_backup_write_table () = diff --git a/ocaml/xapi/sm.ml b/ocaml/xapi/sm.ml index df438a656bd..40e9b11e3e2 100644 --- a/ocaml/xapi/sm.ml +++ b/ocaml/xapi/sm.ml @@ -50,10 +50,11 @@ let register ~__context () = let info_of_driver (name : string) = let name = String.lowercase_ascii name in - if not (Hashtbl.mem driver_info_cache name) then - raise (Unknown_driver name) - else - Hashtbl.find driver_info_cache name + match Hashtbl.find_opt driver_info_cache name with + | Some x -> + x + | None -> + raise (Unknown_driver name) let features_of_driver (name : string) = (info_of_driver name).sr_driver_features diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index 292c96b4f52..02e5545d16e 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -409,7 +409,7 @@ let remove_from_progress_map id = let get_progress_map id = with_lock progress_map_m (fun () -> - try Hashtbl.find progress_map_tbl id with _ -> fun x -> x + Option.value (Hashtbl.find_opt progress_map_tbl id) ~default:Fun.id ) let register_mirror __context mid = diff --git a/ocaml/xapi/storage_migrate.ml b/ocaml/xapi/storage_migrate.ml index eff980cfbe6..468cddb2bf0 100644 --- a/ocaml/xapi/storage_migrate.ml +++ b/ocaml/xapi/storage_migrate.ml @@ -258,7 +258,7 @@ module State = struct let find id table = access_table ~save_after:false - (fun table -> try Some (Hashtbl.find table id) with Not_found -> None) + (fun table -> Hashtbl.find_opt table id) table let remove id table = diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index 0dcef1d201f..3a11ad0077f 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -77,29 +77,35 @@ let unregister sr = ) ) +(* This function is entirely unused, but I am not sure if it should be + deleted or not *) let query_result_of_sr sr = - try with_lock m (fun () -> Some (Hashtbl.find plugins sr).query_result) - with _ -> None + with_lock m (fun () -> + Option.map (fun x -> x.query_result) (Hashtbl.find_opt plugins sr) + ) let sr_has_capability sr capability = - try - with_lock m (fun () -> - Smint.has_capability capability (Hashtbl.find plugins sr).features - ) - with _ -> false + with_lock m (fun () -> + match Hashtbl.find_opt plugins sr with + | Some x -> + Smint.has_capability capability x.features + | None -> + false + ) (* This is the policy: *) let of_sr sr = with_lock m (fun () -> - if not (Hashtbl.mem plugins sr) then ( - error "No storage plugin for SR: %s (currently-registered = [ %s ])" - (s_of_sr sr) - (String.concat ", " - (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) - ) ; - raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) - ) else - (Hashtbl.find plugins sr).processor + match Hashtbl.find_opt plugins sr with + | Some x -> + x.processor + | None -> + error "No storage plugin for SR: %s (currently-registered = [ %s ])" + (s_of_sr sr) + (String.concat ", " + (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) + ) ; + raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) ) type 'a sm_result = SMSuccess of 'a | SMFailure of exn @@ -848,11 +854,12 @@ module Mux = struct module Policy = struct let get_backend_vm () ~dbg:_ ~vm:_ ~sr ~vdi:_ = - if not (Hashtbl.mem plugins sr) then ( - error "No registered plugin for sr = %s" (s_of_sr sr) ; - raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) - ) else - (Hashtbl.find plugins sr).backend_domain + match Hashtbl.find_opt plugins sr with + | Some x -> + x.backend_domain + | None -> + error "No registered plugin for sr = %s" (s_of_sr sr) ; + raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) end module TASK = Storage_smapiv1_wrapper.Impl.TASK diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml index b6abfdcd2c3..465b5d354b1 100644 --- a/ocaml/xapi/storage_smapiv1.ml +++ b/ocaml/xapi/storage_smapiv1.ml @@ -590,10 +590,13 @@ module SMAPIv1 : Server_impl = struct try let read_write = with_lock vdi_read_write_m (fun () -> - if not (Hashtbl.mem vdi_read_write (sr, vdi)) then - error "VDI.activate: doesn't know if sr:%s vdi:%s is RO or RW" - (s_of_sr sr) (s_of_vdi vdi) ; - Hashtbl.find vdi_read_write (sr, vdi) + match Hashtbl.find_opt vdi_read_write (sr, vdi) with + | Some x -> + x + | None -> + error "VDI.activate: doesn't know if sr:%s vdi:%s is RO or RW" + (s_of_sr sr) (s_of_vdi vdi) ; + false ) in for_vdi ~dbg ~sr ~vdi "VDI.activate" (fun device_config _type sr self -> diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml index 8fde6ec60bd..04d0e99ecf8 100644 --- a/ocaml/xapi/storage_smapiv1_wrapper.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -250,10 +250,7 @@ module Sr = struct let m = Mutex.create () - let find vdi sr = - with_lock m (fun () -> - try Some (Hashtbl.find sr.vdis vdi) with Not_found -> None - ) + let find vdi sr = with_lock m (fun () -> Hashtbl.find_opt sr.vdis vdi) let add_or_replace vdi vdi_t sr = with_lock m (fun () -> Hashtbl.replace sr.vdis vdi vdi_t) @@ -289,10 +286,7 @@ module Host = struct let m = Mutex.create () - let find sr h = - with_lock m (fun () -> - try Some (Hashtbl.find h.srs sr) with Not_found -> None - ) + let find sr h = with_lock m (fun () -> Hashtbl.find_opt h.srs sr) let remove sr h = with_lock m (fun () -> Hashtbl.remove h.srs sr) @@ -388,12 +382,13 @@ functor let locks_find sr = let sr_key = s_of_sr sr in with_lock locks_m (fun () -> - if not (Hashtbl.mem locks sr_key) then ( - let result = Storage_locks.make () in - Hashtbl.replace locks sr_key result ; - result - ) else - Hashtbl.find locks sr_key + match Hashtbl.find_opt locks sr_key with + | Some x -> + x + | None -> + let result = Storage_locks.make () in + Hashtbl.replace locks sr_key result ; + result ) let locks_remove sr = diff --git a/ocaml/xapi/system_domains.ml b/ocaml/xapi/system_domains.ml index 2b2b5095c90..5fb394605b1 100644 --- a/ocaml/xapi/system_domains.ml +++ b/ocaml/xapi/system_domains.ml @@ -258,7 +258,7 @@ let unregister_service service = let get_service service = with_lock service_to_queue_m (fun () -> - try Some (Hashtbl.find service_to_queue service) with Not_found -> None + Hashtbl.find_opt service_to_queue service ) let list_services () = diff --git a/ocaml/xapi/xapi_dr.ml b/ocaml/xapi/xapi_dr.ml index b2f80481324..dfe563ec204 100644 --- a/ocaml/xapi/xapi_dr.ml +++ b/ocaml/xapi/xapi_dr.ml @@ -150,12 +150,7 @@ let remove_vdis_from_cache ~__context ~vdis = ) let read_vdi_cache_record ~vdi = - with_lock db_vdi_cache_mutex (fun () -> - if Hashtbl.mem db_vdi_cache vdi then - Some (Hashtbl.find db_vdi_cache vdi) - else - None - ) + with_lock db_vdi_cache_mutex (fun () -> Hashtbl.find_opt db_vdi_cache vdi) let handle_metadata_vdis ~__context ~sr = let sr_uuid = Db.SR.get_uuid ~__context ~self:sr in diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index 4c6a5eac959..b56e4199779 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -224,21 +224,22 @@ module Next = struct one if one doesn't exist already *) let get_subscription session = with_lock m (fun () -> - if Hashtbl.mem subscriptions session then - Hashtbl.find subscriptions session - else - let subscription = - { - last_id= !id - ; subs= [] - ; m= Mutex.create () - ; session - ; session_invalid= false - ; timeout= 0.0 - } - in - Hashtbl.replace subscriptions session subscription ; - subscription + match Hashtbl.find_opt subscriptions session with + | Some x -> + x + | None -> + let subscription = + { + last_id= !id + ; subs= [] + ; m= Mutex.create () + ; session + ; session_invalid= false + ; timeout= 0.0 + } + in + Hashtbl.replace subscriptions session subscription ; + subscription ) let on_session_deleted session_id = @@ -248,11 +249,12 @@ module Next = struct with_lock sub.m (fun () -> sub.session_invalid <- true) ; Condition.broadcast c in - if Hashtbl.mem subscriptions session_id then ( - let sub = Hashtbl.find subscriptions session_id in - mark_invalid sub ; - Hashtbl.remove subscriptions session_id - ) + Option.iter + (fun sub -> + mark_invalid sub ; + Hashtbl.remove subscriptions session_id + ) + (Hashtbl.find_opt subscriptions session_id) ) let session_is_invalid sub = with_lock sub.m (fun () -> sub.session_invalid) @@ -381,10 +383,7 @@ module From = struct in with_lock m (fun () -> let existing = - if Hashtbl.mem calls session then - Hashtbl.find calls session - else - [] + Option.value (Hashtbl.find_opt calls session) ~default:[] in Hashtbl.replace calls session (fresh :: existing) ) ; @@ -392,15 +391,17 @@ module From = struct (fun () -> f fresh) (fun () -> with_lock m (fun () -> - if Hashtbl.mem calls session then - let existing = Hashtbl.find calls session in - let remaining = - List.filter (fun x -> not (x.index = fresh.index)) existing - in - if remaining = [] then - Hashtbl.remove calls session - else - Hashtbl.replace calls session remaining + Option.iter + (fun existing -> + let remaining = + List.filter (fun x -> not (x.index = fresh.index)) existing + in + if remaining = [] then + Hashtbl.remove calls session + else + Hashtbl.replace calls session remaining + ) + (Hashtbl.find_opt calls session) ) ) @@ -412,10 +413,12 @@ module From = struct with_lock sub.m (fun () -> sub.session_invalid <- true) ; Condition.broadcast c in - if Hashtbl.mem calls session_id then ( - List.iter mark_invalid (Hashtbl.find calls session_id) ; - Hashtbl.remove calls session_id - ) + Option.iter + (fun x -> + List.iter mark_invalid x ; + Hashtbl.remove calls session_id + ) + (Hashtbl.find_opt calls session_id) ) let session_is_invalid call = with_lock call.m (fun () -> call.session_invalid) diff --git a/ocaml/xapi/xapi_guest_agent.ml b/ocaml/xapi/xapi_guest_agent.ml index 1de7d904748..ffe5b8ae618 100644 --- a/ocaml/xapi/xapi_guest_agent.ml +++ b/ocaml/xapi/xapi_guest_agent.ml @@ -354,30 +354,32 @@ let all (lookup : string -> string option) (list : string -> string list) let self = Db.VM.get_by_uuid ~__context ~uuid in let guest_metrics_cached = with_lock mutex (fun () -> - try Hashtbl.find cache domid - with _ -> - (* Make sure our cached idea of whether the domain is live or not is correct *) - let vm_guest_metrics = Db.VM.get_guest_metrics ~__context ~self in - let live = - true - && Db.is_valid_ref __context vm_guest_metrics - && Db.VM_guest_metrics.get_live ~__context ~self:vm_guest_metrics - in - if live then - dead_domains := IntSet.remove domid !dead_domains - else - dead_domains := IntSet.add domid !dead_domains ; - { - pv_drivers_version= [] - ; os_version= [] - ; networks= [] - ; other= [] - ; memory= [] - ; device_id= [] - ; last_updated= 0.0 - ; can_use_hotplug_vbd= `unspecified - ; can_use_hotplug_vif= `unspecified - } + match Hashtbl.find_opt cache domid with + | Some x -> + x + | None -> + (* Make sure our cached idea of whether the domain is live or not is correct *) + let vm_guest_metrics = Db.VM.get_guest_metrics ~__context ~self in + let live = + true + && Db.is_valid_ref __context vm_guest_metrics + && Db.VM_guest_metrics.get_live ~__context ~self:vm_guest_metrics + in + if live then + dead_domains := IntSet.remove domid !dead_domains + else + dead_domains := IntSet.add domid !dead_domains ; + { + pv_drivers_version= [] + ; os_version= [] + ; networks= [] + ; other= [] + ; memory= [] + ; device_id= [] + ; last_updated= 0.0 + ; can_use_hotplug_vbd= `unspecified + ; can_use_hotplug_vif= `unspecified + } ) in (* Only if the data is valid, cache it (CA-20353) *) diff --git a/ocaml/xapi/xapi_ha_vm_failover.ml b/ocaml/xapi/xapi_ha_vm_failover.ml index 4aa9ee17128..c834e384251 100644 --- a/ocaml/xapi/xapi_ha_vm_failover.ml +++ b/ocaml/xapi/xapi_ha_vm_failover.ml @@ -1423,10 +1423,11 @@ let restart_auto_run_vms ~__context live_set n = ) ; (* If we tried before and failed, don't retry again within 2 minutes *) let attempt_restart = - if Hashtbl.mem last_start_attempt vm then - Unix.gettimeofday () -. Hashtbl.find last_start_attempt vm > 120. - else - true + match Hashtbl.find_opt last_start_attempt vm with + | Some x -> + Unix.gettimeofday () -. x > 120. + | None -> + true in if attempt_restart then ( Hashtbl.replace last_start_attempt vm (Unix.gettimeofday ()) ; diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index dcac8edc5ce..beb3f2d13b0 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -152,21 +152,22 @@ let valid_operations ~__context record _ref' = table let throw_error table op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_host_helpers.assert_operation_valid unknown operation: %s" - (host_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_host_helpers.assert_operation_valid unknown operation: \ + %s" + (host_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.host_allowed_operations) diff --git a/ocaml/xapi/xapi_pci_helpers.ml b/ocaml/xapi/xapi_pci_helpers.ml index 873031c9f35..4e7009e2bdb 100644 --- a/ocaml/xapi/xapi_pci_helpers.ml +++ b/ocaml/xapi/xapi_pci_helpers.ml @@ -75,10 +75,12 @@ end = struct let make () = Hashtbl.create 100 let is_virtual t addr = - try Hashtbl.find t addr - with Not_found -> - let v = is_virtual addr in - Hashtbl.replace t addr v ; v + match Hashtbl.find_opt t addr with + | Some x -> + x + | None -> + let v = is_virtual addr in + Hashtbl.replace t addr v ; v end (** [is_related_to x y] is true, if two non-virtual PCI devices diff --git a/ocaml/xapi/xapi_pool_helpers.ml b/ocaml/xapi/xapi_pool_helpers.ml index d8c31f7071a..d023cce84d1 100644 --- a/ocaml/xapi/xapi_pool_helpers.ml +++ b/ocaml/xapi/xapi_pool_helpers.ml @@ -128,21 +128,22 @@ let valid_operations ~__context record (pool : API.ref_pool) = table let throw_error table op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_pool_helpers.assert_operation_valid unknown operation: %s" - (pool_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_pool_helpers.assert_operation_valid unknown operation: \ + %s" + (pool_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.pool_allowed_operations) diff --git a/ocaml/xapi/xapi_pool_update.ml b/ocaml/xapi/xapi_pool_update.ml index 1a9b8544bad..84ebbe6e23c 100644 --- a/ocaml/xapi/xapi_pool_update.ml +++ b/ocaml/xapi/xapi_pool_update.ml @@ -125,7 +125,9 @@ let with_dec_refcount ~__context ~uuid ~vdi f = with_lock updates_to_attach_count_tbl_mutex (fun () -> assert_update_vbds_attached ~__context ~vdi ; let count = - try Hashtbl.find updates_to_attach_count_tbl uuid with _ -> 0 + Option.value + (Hashtbl.find_opt updates_to_attach_count_tbl uuid) + ~default:0 in debug "pool_update.detach_helper '%s' count=%d" uuid count ; if count <= 1 then @@ -139,7 +141,9 @@ let with_dec_refcount ~__context ~uuid ~vdi f = let with_inc_refcount ~__context ~uuid ~vdi f = with_lock updates_to_attach_count_tbl_mutex (fun () -> let count = - try Hashtbl.find updates_to_attach_count_tbl uuid with _ -> 0 + Option.value + (Hashtbl.find_opt updates_to_attach_count_tbl uuid) + ~default:0 in debug "pool_update.attach_helper refcount='%d'" count ; if count = 0 then diff --git a/ocaml/xapi/xapi_role.ml b/ocaml/xapi/xapi_role.ml index f63f13caa74..c26ca678f81 100644 --- a/ocaml/xapi/xapi_role.ml +++ b/ocaml/xapi/xapi_role.ml @@ -47,12 +47,12 @@ let _ = (fun r -> Hashtbl.add static_role_by_name_label_tbl r.role_name_label r) get_all_static_roles -let find_role_by_ref ref = Hashtbl.find static_role_by_ref_tbl ref +let find_role_by_ref ref = Hashtbl.find_opt static_role_by_ref_tbl ref -let find_role_by_uuid uuid = Hashtbl.find static_role_by_uuid_tbl uuid +let find_role_by_uuid uuid = Hashtbl.find_opt static_role_by_uuid_tbl uuid let find_role_by_name_label name_label = - Hashtbl.find static_role_by_name_label_tbl name_label + Hashtbl.find_opt static_role_by_name_label_tbl name_label (* val get_all : __context:Context.t -> ref_role_set*) let get_all ~__context = @@ -64,13 +64,13 @@ let get_all ~__context = let is_valid_role ~__context ~role = Hashtbl.mem static_role_by_ref_tbl role let get_common ~__context ~self ~static_fn ~db_fn = - try - (* first look up across the static roles *) - let static_record = find_role_by_ref self in - static_fn static_record - with Not_found -> - (* then look up across the roles in the Db *) - db_fn ~__context ~self + match find_role_by_ref self with + (* first look up across the static roles *) + | Some static_record -> + static_fn static_record + | None -> + (* then look up across the roles in the Db *) + db_fn ~__context ~self (* val get_record : __context:Context.t -> self:ref_role -> role_t*) let get_api_record ~static_record = @@ -121,20 +121,20 @@ let get_all_records ~__context = get_all_records_where ~__context ~expr:"True" (* val get_by_uuid : __context:Context.t -> uuid:string -> ref_role*) let get_by_uuid ~__context ~uuid = - try - let static_record = find_role_by_uuid uuid in - ref_of_role ~role:static_record - with Not_found -> - (* pass-through to Db *) - Db.Role.get_by_uuid ~__context ~uuid + match find_role_by_uuid uuid with + | Some static_record -> + ref_of_role ~role:static_record + | None -> + (* pass-through to Db *) + Db.Role.get_by_uuid ~__context ~uuid let get_by_name_label ~__context ~label = - try - let static_record = find_role_by_name_label label in - [ref_of_role ~role:static_record] - with Not_found -> - (* pass-through to Db *) - Db.Role.get_by_name_label ~__context ~label + match find_role_by_name_label label with + | Some static_record -> + [ref_of_role ~role:static_record] + | None -> + (* pass-through to Db *) + Db.Role.get_by_name_label ~__context ~label (* val get_uuid : __context:Context.t -> self:ref_role -> string*) let get_uuid ~__context ~self = diff --git a/ocaml/xapi/xapi_sr_operations.ml b/ocaml/xapi/xapi_sr_operations.ml index 5d4cc834750..6199507d87c 100644 --- a/ocaml/xapi/xapi_sr_operations.ml +++ b/ocaml/xapi/xapi_sr_operations.ml @@ -98,6 +98,9 @@ let valid_operations ~__context ?op record _ref' : table = (ops : API.storage_operations_set) = List.iter (fun op -> + (* Exception can't be raised since the hash table is + pre-filled for all_ops, and set_errors is applied + to a subset of all_ops (disallowed_during_rpu) *) if Hashtbl.find table op = None then Hashtbl.replace table op (Some (code, params)) ) @@ -221,21 +224,21 @@ let valid_operations ~__context ?op record _ref' : table = table let throw_error (table : table) op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_sr.assert_operation_valid unknown operation: %s" - (sr_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_sr.assert_operation_valid unknown operation: %s" + (sr_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.storage_operations) = diff --git a/ocaml/xapi/xapi_vbd_helpers.ml b/ocaml/xapi/xapi_vbd_helpers.ml index a24a9fb5106..6226b26c34e 100644 --- a/ocaml/xapi/xapi_vbd_helpers.ml +++ b/ocaml/xapi/xapi_vbd_helpers.ml @@ -60,6 +60,9 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = (ops : API.vbd_operations_set) = List.iter (fun op -> + (* Exception can't be raised since the hash table is + pre-filled for all_ops, and set_errors is applied + to a subset of all_ops *) if Hashtbl.find table op = None then Hashtbl.replace table op (Some (code, params)) ) @@ -296,21 +299,21 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = table let throw_error (table : table) op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_vbd_helpers.assert_operation_valid unknown operation: %s" - (vbd_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_vbd_helpers.assert_operation_valid unknown operation: %s" + (vbd_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.vbd_operations) = diff --git a/ocaml/xapi/xapi_vdi_helpers.ml b/ocaml/xapi/xapi_vdi_helpers.ml index 0fe39c68c26..15b00211d73 100644 --- a/ocaml/xapi/xapi_vdi_helpers.ml +++ b/ocaml/xapi/xapi_vdi_helpers.ml @@ -151,25 +151,25 @@ let disable_database_replication ~__context ~vdi = debug "Attempting to disable metadata replication on VDI [%s:%s]." (Db.VDI.get_name_label ~__context ~self:vdi) (Db.VDI.get_uuid ~__context ~self:vdi) ; - if not (Hashtbl.mem metadata_replication vdi) then - debug "Metadata is not being replicated to this VDI." - else - let vbd, log = Hashtbl.find metadata_replication vdi in - Redo_log.shutdown log ; - Redo_log.disable log ; - (* Check the recorded VBD still exists before trying to unplug and destroy it. *) - if Db.is_valid_ref __context vbd then - Helpers.call_api_functions ~__context (fun rpc session_id -> - try - Attach_helpers.safe_unplug rpc session_id vbd ; - Client.VBD.destroy ~rpc ~session_id ~self:vbd - with e -> - debug "Caught %s while trying to dispose of VBD %s." - (Printexc.to_string e) (Ref.string_of vbd) - ) ; - Hashtbl.remove metadata_replication vdi ; - Redo_log.delete log ; - Db.VDI.set_metadata_latest ~__context ~self:vdi ~value:false + match Hashtbl.find_opt metadata_replication vdi with + | None -> + debug "Metadata is not being replicated to this VDI." + | Some (vbd, log) -> + Redo_log.shutdown log ; + Redo_log.disable log ; + (* Check the recorded VBD still exists before trying to unplug and destroy it. *) + if Db.is_valid_ref __context vbd then + Helpers.call_api_functions ~__context (fun rpc session_id -> + try + Attach_helpers.safe_unplug rpc session_id vbd ; + Client.VBD.destroy ~rpc ~session_id ~self:vbd + with e -> + debug "Caught %s while trying to dispose of VBD %s." + (Printexc.to_string e) (Ref.string_of vbd) + ) ; + Hashtbl.remove metadata_replication vdi ; + Redo_log.delete log ; + Db.VDI.set_metadata_latest ~__context ~self:vdi ~value:false ) let database_open_mutex = Mutex.create () diff --git a/ocaml/xapi/xapi_vif_helpers.ml b/ocaml/xapi/xapi_vif_helpers.ml index 751f987a6da..5b1f1f458f5 100644 --- a/ocaml/xapi/xapi_vif_helpers.ml +++ b/ocaml/xapi/xapi_vif_helpers.ml @@ -155,21 +155,21 @@ let valid_operations ~__context record _ref' : table = table let throw_error (table : table) op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_vif_helpers.assert_operation_valid unknown operation: %s" - (vif_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_vif_helpers.assert_operation_valid unknown operation: %s" + (vif_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.vif_operations) = diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 8a03aba27e1..8819d393170 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1117,11 +1117,11 @@ let record_call_plugin_latest vm = List.iter (Hashtbl.remove call_plugin_latest) !to_gc ; (* Then calculate the schedule *) let to_wait = - if Hashtbl.mem call_plugin_latest vm then - let t = Hashtbl.find call_plugin_latest vm in - Int64.sub (Int64.add t interval) now - else - 0L + match Hashtbl.find_opt call_plugin_latest vm with + | Some t -> + Int64.sub (Int64.add t interval) now + | None -> + 0L in if to_wait > 0L then raise diff --git a/ocaml/xapi/xapi_vusb_helpers.ml b/ocaml/xapi/xapi_vusb_helpers.ml index 09de9f80731..4c8b8d5eb2a 100644 --- a/ocaml/xapi/xapi_vusb_helpers.ml +++ b/ocaml/xapi/xapi_vusb_helpers.ml @@ -92,21 +92,22 @@ let valid_operations ~__context record _ref' : table = table let throw_error (table : table) op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_vusb_helpers.assert_operation_valid unknown operation: %s" - (vusb_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_vusb_helpers.assert_operation_valid unknown operation: \ + %s" + (vusb_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let update_allowed_operations ~__context ~self : unit = diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index a186b2e8b76..a6e29efa870 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -1812,12 +1812,12 @@ module Events_from_xenopsd = struct Client.UPDATES.remove_barrier dbg id ; let t = with_lock active_m @@ fun () -> - if not (Hashtbl.mem active id) then ( - warn "Events_from_xenopsd.wakeup: unknown id %d" id ; - None - ) else - let t = Hashtbl.find active id in - Hashtbl.remove active id ; Some t + match Hashtbl.find_opt active id with + | Some t -> + Hashtbl.remove active id ; Some t + | None -> + warn "Events_from_xenopsd.wakeup: unknown id %d" id ; + None in Option.iter (fun t -> diff --git a/ocaml/xapi/xha_interface.ml b/ocaml/xapi/xha_interface.ml index 979ef9288e3..608ae9a64a2 100644 --- a/ocaml/xapi/xha_interface.ml +++ b/ocaml/xapi/xha_interface.ml @@ -276,10 +276,12 @@ module LiveSetInformation = struct | Xml.Element ("host", _, children) -> let table = hash_table_of_leaf_xml_element_list children in let find x = - try Hashtbl.find table x - with Not_found -> - invalid_arg - (Printf.sprintf "Missig entry '%s' within 'host' element" x) + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + invalid_arg + (Printf.sprintf "Missig entry '%s' within 'host' element" x) in let bool s = try bool_of_string (String.lowercase_ascii s) @@ -326,12 +328,14 @@ module LiveSetInformation = struct | Xml.Element ("host_raw_data", _, children) -> let table = hash_table_of_leaf_xml_element_list children in let find x = - try Hashtbl.find table x - with Not_found -> - invalid_arg - (Printf.sprintf - "Missing entry '%s' within 'host_raw_data' element" x - ) + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + invalid_arg + (Printf.sprintf + "Missing entry '%s' within 'host_raw_data' element" x + ) in let int s = try int_of_string (String.lowercase_ascii s) @@ -382,12 +386,15 @@ module LiveSetInformation = struct | Xml.Element ("warning_on_local_host", _, children) -> let table = hash_table_of_leaf_xml_element_list children in let find x = - try Hashtbl.find table x - with Not_found -> - invalid_arg - (Printf.sprintf - "Missing entry '%s' within 'warning_on_local_host' element" x - ) + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + invalid_arg + (Printf.sprintf + "Missing entry '%s' within 'warning_on_local_host' element" + x + ) in let bool x = find x = "TRUE" in Some @@ -423,14 +430,16 @@ module LiveSetInformation = struct | Xml.Element ("raw_status_on_local_host", _, children) -> let table = hash_table_of_leaf_xml_element_list children in let find x = - try Hashtbl.find table x - with Not_found -> - invalid_arg - (Printf.sprintf - "Missing entry '%s' within 'raw_status_on_local_host' \ - element" - x - ) + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + invalid_arg + (Printf.sprintf + "Missing entry '%s' within 'raw_status_on_local_host' \ + element" + x + ) in let int s = try int_of_string (String.lowercase_ascii s) diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml index 9265084e020..4cf580ed590 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml @@ -96,8 +96,11 @@ let get_sr_rrd_handler (req : Http.Request.t) (s : Unix.file_descr) _ = let rrd = with_lock mutex (fun () -> let rrdi = - try Hashtbl.find sr_rrds sr_uuid - with Not_found -> failwith "No SR RRD available!" + match Hashtbl.find_opt sr_rrds sr_uuid with + | Some x -> + x + | None -> + failwith "No SR RRD available!" in Rrd.copy_rrd rrdi.rrd ) diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml index cb356f5bee4..f6a9fa43646 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml @@ -138,31 +138,31 @@ let update_rrds timestamp dss uuid_domids paused_vms = in let dss = StringMap.to_seq dss |> Seq.map snd |> List.of_seq in - try - let domid = StringMap.find vm_uuid uuid_domids in + match StringMap.find_opt vm_uuid uuid_domids with + | Some domid -> ( (* First, potentially update the rrd with any new default dss *) - try - let rrdi = Hashtbl.find vm_rrds vm_uuid in - let rrd = merge_new_dss rrdi.rrd dss in - Hashtbl.replace vm_rrds vm_uuid {rrd; dss; domid} ; - (* CA-34383: Memory updates from paused domains serve no useful - purpose. During a migrate such updates can also cause undesirable - discontinuities in the observed value of memory_actual. Hence, we - ignore changes from paused domains: *) - if not (StringSet.mem vm_uuid paused_vms) then ( - Rrd.ds_update_named rrd timestamp ~new_domid:(domid <> rrdi.domid) - named_updates ; - rrdi.dss <- dss ; - rrdi.domid <- domid - ) - with - | Not_found -> + match Hashtbl.find_opt vm_rrds vm_uuid with + | Some rrdi -> + let rrd = merge_new_dss rrdi.rrd dss in + Hashtbl.replace vm_rrds vm_uuid {rrd; dss; domid} ; + (* CA-34383: Memory updates from paused domains serve no useful + purpose. During a migrate such updates can also cause undesirable + discontinuities in the observed value of memory_actual. Hence, we + ignore changes from paused domains: *) + if not (StringSet.mem vm_uuid paused_vms) then ( + Rrd.ds_update_named rrd timestamp + ~new_domid:(domid <> rrdi.domid) named_updates ; + rrdi.dss <- dss ; + rrdi.domid <- domid + ) + | None -> debug "%s: Creating fresh RRD for VM uuid=%s" __FUNCTION__ vm_uuid ; let rrd = create_fresh_rrd !use_min_max dss in Hashtbl.replace vm_rrds vm_uuid {rrd; dss; domid} - | e -> - raise e - with _ -> log_backtrace () + ) + | None -> + info "%s: VM uuid=%s is not resident in this host, ignoring rrds" + __FUNCTION__ vm_uuid in let process_sr sr_uuid dss = let named_updates = @@ -171,20 +171,17 @@ let update_rrds timestamp dss uuid_domids paused_vms = let dss = StringMap.to_seq dss |> Seq.map snd |> List.of_seq in try (* First, potentially update the rrd with any new default dss *) - try - let rrdi = Hashtbl.find sr_rrds sr_uuid in - let rrd = merge_new_dss rrdi.rrd dss in - Hashtbl.replace sr_rrds sr_uuid {rrd; dss; domid= 0} ; - Rrd.ds_update_named rrd timestamp ~new_domid:false named_updates ; - rrdi.dss <- dss ; - rrdi.domid <- 0 - with - | Not_found -> + match Hashtbl.find_opt sr_rrds sr_uuid with + | Some rrdi -> + let rrd = merge_new_dss rrdi.rrd dss in + Hashtbl.replace sr_rrds sr_uuid {rrd; dss; domid= 0} ; + Rrd.ds_update_named rrd timestamp ~new_domid:false named_updates ; + rrdi.dss <- dss ; + rrdi.domid <- 0 + | None -> debug "%s: Creating fresh RRD for SR uuid=%s" __FUNCTION__ sr_uuid ; let rrd = create_fresh_rrd !use_min_max dss in Hashtbl.replace sr_rrds sr_uuid {rrd; dss; domid= 0} - | e -> - raise e with _ -> log_backtrace () in let process_host dss = diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml index e7556381c8e..f3f56003dad 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml @@ -24,13 +24,13 @@ open D let archive_sr_rrd (sr_uuid : string) : string = let sr_rrd = with_lock mutex (fun () -> - try - let rrd = Hashtbl.find sr_rrds sr_uuid in - Hashtbl.remove sr_rrds sr_uuid ; - rrd - with Not_found -> - let msg = Printf.sprintf "No RRD found for SR: %s." sr_uuid in - raise (Rrdd_error (Archive_failed msg)) + match Hashtbl.find_opt sr_rrds sr_uuid with + | Some rrd -> + Hashtbl.remove sr_rrds sr_uuid ; + rrd + | None -> + let msg = Printf.sprintf "No RRD found for SR: %s." sr_uuid in + raise (Rrdd_error (Archive_failed msg)) ) in try @@ -85,11 +85,13 @@ let archive_rrd vm_uuid (remote_address : string option) : unit = remote_address in with_lock mutex (fun () -> - try - let rrd = (Hashtbl.find vm_rrds vm_uuid).rrd in - Hashtbl.remove vm_rrds vm_uuid ; - archive_rrd_internal ~transport ~uuid:vm_uuid ~rrd () - with Not_found -> () + match Hashtbl.find_opt vm_rrds vm_uuid with + | Some x -> + let rrd = x.rrd in + Hashtbl.remove vm_rrds vm_uuid ; + archive_rrd_internal ~transport ~uuid:vm_uuid ~rrd () + | None -> + () ) (** This functionality is used by xapi to backup rrds to local disk or to the @@ -294,29 +296,27 @@ let remove_rrd (uuid : string) : unit = is assumed to be valid, since it is set by monitor_master. *) let migrate_rrd (session_id : string option) (remote_address : string) (vm_uuid : string) (host_uuid : string) : unit = - try - let rrdi = - with_lock mutex (fun () -> - let rrdi = Hashtbl.find vm_rrds vm_uuid in + with_lock mutex (fun () -> + match Hashtbl.find_opt vm_rrds vm_uuid with + | Some x -> debug "Sending RRD for VM uuid=%s to remote host %s for migrate" vm_uuid host_uuid ; Hashtbl.remove vm_rrds vm_uuid ; - rrdi - ) - in - let transport = - Xmlrpc_client.( - SSL (SSL.make ~verify_cert:None (), remote_address, !https_port) - ) - in - send_rrd ?session_id ~transport ~to_archive:false ~uuid:vm_uuid - ~rrd:rrdi.rrd () - with - | Not_found -> - debug "VM %s RRDs not found on migrate! Continuing anyway..." vm_uuid ; - log_backtrace () - | _ -> - log_backtrace () + Some x + | None -> + debug "VM %s RRDs not found on migrate! Continuing anyway..." vm_uuid ; + log_backtrace () ; + None + ) + |> Option.iter (fun rrdi -> + let transport = + Xmlrpc_client.( + SSL (SSL.make ~verify_cert:None (), remote_address, !https_port) + ) + in + send_rrd ?session_id ~transport ~to_archive:false ~uuid:vm_uuid + ~rrd:rrdi.rrd () + ) (* Called on host shutdown/reboot to send the Host RRD to the master for backup. Note all VMs will have been shutdown by now. *) @@ -756,11 +756,12 @@ module Plugin = struct process its output at most once more. *) let deregister (uid : P.uid) : unit = with_lock registered_m (fun _ -> - if Hashtbl.mem registered uid then ( - let plugin = Hashtbl.find registered uid in - plugin.reader.Rrd_reader.cleanup () ; - Hashtbl.remove registered uid - ) + Option.iter + (fun plugin -> + plugin.reader.Rrd_reader.cleanup () ; + Hashtbl.remove registered uid + ) + (Hashtbl.find_opt registered uid) ) (* Read, parse, and combine metrics from all registered plugins. *) diff --git a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml index 80691b0ab9d..dbfbd8cb73b 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml @@ -619,11 +619,9 @@ let dss_mem_vms doms = ) in let memory_target_opt = - try - with_lock Rrdd_shared.memory_targets_m (fun _ -> - Some (Hashtbl.find Rrdd_shared.memory_targets domid) - ) - with Not_found -> None + with_lock Rrdd_shared.memory_targets_m (fun _ -> + Hashtbl.find_opt Rrdd_shared.memory_targets domid + ) in let mem_target_ds = Option.map diff --git a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml index c718a033d0f..b8c60edec7e 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml +++ b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml @@ -192,11 +192,9 @@ module Iostat = struct (* Now read the values out of dev_values_map for devices for which we have data *) List.filter_map (fun dev -> - if not (Hashtbl.mem dev_values_map dev) then - None - else - let values = Hashtbl.find dev_values_map dev in - Some (dev, values) + Option.map + (fun values -> (dev, values)) + (Hashtbl.find_opt dev_values_map dev) ) devs end @@ -371,13 +369,13 @@ let exec_tap_ctl_list () : ((string * string) * int) list = (* Look up SR and VDI uuids from the physical path *) if not (Hashtbl.mem phypath_to_sr_vdi phypath) then refresh_phypath_to_sr_vdi () ; - if not (Hashtbl.mem phypath_to_sr_vdi phypath) then ( - (* Odd: tap-ctl mentions a device that's not linked from /dev/sm/phy *) - D.error "Could not find device with physical path %s" phypath ; - None - ) else - let sr, vdi = Hashtbl.find phypath_to_sr_vdi phypath in - Some (pid, (minor, (sr, vdi))) + match Hashtbl.find_opt phypath_to_sr_vdi phypath with + | Some (sr, vdi) -> + Some (pid, (minor, (sr, vdi))) + | None -> + (* Odd: tap-ctl mentions a device that's not linked from /dev/sm/phy *) + D.error "Could not find device with physical path %s" phypath ; + None in let process_line str = try Scanf.sscanf str "pid=%d minor=%d state=%s args=%s@:%s" extract_vdis diff --git a/ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml b/ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml index 6c2c11192fb..17b55481410 100644 --- a/ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml +++ b/ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml @@ -50,8 +50,9 @@ let signal_name signum = List.iter (fun (str, key) -> Hashtbl.add t key str) map ; t in - try Hashtbl.find signals signum - with Not_found -> Printf.sprintf "unknown signal (%d)" signum + Option.value + (Hashtbl.find_opt signals signum) + ~default:(Printf.sprintf "unknown signal (%d)" signum) module Utils = Utils diff --git a/ocaml/xcp-rrdd/lib/rrdd/stats.ml b/ocaml/xcp-rrdd/lib/rrdd/stats.ml index b85a9181c7a..c1996dd4e49 100644 --- a/ocaml/xcp-rrdd/lib/rrdd/stats.ml +++ b/ocaml/xcp-rrdd/lib/rrdd/stats.ml @@ -74,10 +74,9 @@ let sample (name : string) (x : float) : unit = let x' = log x in with_lock timings_m (fun () -> let p = - if Hashtbl.mem timings name then - Hashtbl.find timings name - else - Normal_population.empty + Option.value + (Hashtbl.find_opt timings name) + ~default:Normal_population.empty in let p' = Normal_population.sample p x' in Hashtbl.replace timings name p' @@ -143,17 +142,19 @@ let log_db_call task_opt dbcall ty = dbstats_drop_dbcalls in Hashtbl.replace hashtbl dbcall - (1 + try Hashtbl.find hashtbl dbcall with _ -> 0) ; + (1 + Option.value (Hashtbl.find_opt hashtbl dbcall) ~default:0) ; let threadid = Thread.id (Thread.self ()) in Hashtbl.replace dbstats_threads threadid ((dbcall, ty) - :: (try Hashtbl.find dbstats_threads threadid with _ -> []) + :: Option.value + (Hashtbl.find_opt dbstats_threads threadid) + ~default:[] ) ; match task_opt with | Some task -> Hashtbl.replace dbstats_task task ((dbcall, ty) - :: (try Hashtbl.find dbstats_task task with _ -> []) + :: Option.value (Hashtbl.find_opt dbstats_task task) ~default:[] ) | None -> () diff --git a/ocaml/xenopsd/list_domains/list_domains.ml b/ocaml/xenopsd/list_domains/list_domains.ml index 22d18543310..2a4ae05b2ca 100644 --- a/ocaml/xenopsd/list_domains/list_domains.ml +++ b/ocaml/xenopsd/list_domains/list_domains.ml @@ -99,9 +99,11 @@ let hashtbl_of_domaininfo x : (string, string) Hashtbl.t = let select table keys = List.map (fun key -> - if not (Hashtbl.mem table key) then - failwith (Printf.sprintf "Failed to find key: %s" key) ; - Hashtbl.find table key + match Hashtbl.find_opt table key with + | Some x -> + x + | None -> + failwith (Printf.sprintf "Failed to find key: %s" key) ) keys diff --git a/ocaml/xenopsd/xc/device.ml b/ocaml/xenopsd/xc/device.ml index 6d47a2489ef..20f2405a7e7 100644 --- a/ocaml/xenopsd/xc/device.ml +++ b/ocaml/xenopsd/xc/device.ml @@ -2786,10 +2786,9 @@ module Backend = struct Hashtbl.remove ftod (Qmp_protocol.to_fd c) ; Hashtbl.remove dtoc domid - let domid_of fd = try Some (Hashtbl.find ftod fd) with Not_found -> None + let domid_of fd = Hashtbl.find_opt ftod fd - let channel_of domid = - try Some (Hashtbl.find dtoc domid) with Not_found -> None + let channel_of domid = Hashtbl.find_opt dtoc domid end (** File-descriptor event monitor implementation for the epoll library *) diff --git a/ocaml/xenopsd/xc/readln.ml b/ocaml/xenopsd/xc/readln.ml index 9ee995723db..bbd91fb6e47 100644 --- a/ocaml/xenopsd/xc/readln.ml +++ b/ocaml/xenopsd/xc/readln.ml @@ -11,7 +11,9 @@ let read fd = let buffer = Bytes.make buffer_size '\000' in match Unix.read fd buffer 0 buffer_size with | 0 -> - let pending = try Hashtbl.find input fd with Not_found -> Bytes.empty in + let pending = + Option.value (Hashtbl.find_opt input fd) ~default:Bytes.empty + in Hashtbl.remove input fd ; if pending = Bytes.empty then EOF diff --git a/ocaml/xenopsd/xc/stats.ml b/ocaml/xenopsd/xc/stats.ml index 4e25cdca45f..e551e81aaf9 100644 --- a/ocaml/xenopsd/xc/stats.ml +++ b/ocaml/xenopsd/xc/stats.ml @@ -76,10 +76,9 @@ let sample (name : string) (x : float) : unit = let x' = log x in with_lock timings_m (fun () -> let p = - if Hashtbl.mem timings name then - Hashtbl.find timings name - else - Normal_population.empty + Option.value + (Hashtbl.find_opt timings name) + ~default:Normal_population.empty in let p' = Normal_population.sample p x' in Hashtbl.replace timings name p' @@ -143,17 +142,19 @@ let log_db_call task_opt dbcall ty = dbstats_drop_dbcalls in Hashtbl.replace hashtbl dbcall - (1 + try Hashtbl.find hashtbl dbcall with _ -> 0) ; + (1 + Option.value (Hashtbl.find_opt hashtbl dbcall) ~default:0) ; let threadid = Thread.id (Thread.self ()) in Hashtbl.replace dbstats_threads threadid ((dbcall, ty) - :: (try Hashtbl.find dbstats_threads threadid with _ -> []) + :: Option.value + (Hashtbl.find_opt dbstats_threads threadid) + ~default:[] ) ; match task_opt with | Some task -> Hashtbl.replace dbstats_task task ((dbcall, ty) - :: (try Hashtbl.find dbstats_task task with _ -> []) + :: Option.value (Hashtbl.find_opt dbstats_task task) ~default:[] ) | None -> () diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index a3317194f24..44d4e4e942c 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -961,10 +961,7 @@ module HOST = struct get_lines () ; close_in in_chan ; let find key = - if Hashtbl.mem tbl key then - Hashtbl.find tbl key - else - "unknown" + Option.value (Hashtbl.find_opt tbl key) ~default:"unknown" in ( find "vendor_id" , find "model name" From 1869b443a0391f7af71296198eb2b9477d9423a2 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 26 Jun 2024 13:16:36 +0100 Subject: [PATCH 3/5] Refactor Hashtbl.find out of resources/table.ml Signed-off-by: Andrii Sultanov --- ocaml/libs/resources/table.ml | 2 +- ocaml/libs/stunnel/stunnel_cache.ml | 57 +++++++++++++++++++---------- 2 files changed, 38 insertions(+), 21 deletions(-) diff --git a/ocaml/libs/resources/table.ml b/ocaml/libs/resources/table.ml index 9c284f80de8..35aa88082ca 100644 --- a/ocaml/libs/resources/table.ml +++ b/ocaml/libs/resources/table.ml @@ -41,7 +41,7 @@ struct Hashtbl.remove t k ) - let find (t, m) k = with_lock m (fun () -> Hashtbl.find t k) + let find (t, m) k = with_lock m (fun () -> Hashtbl.find_opt t k) let with_find_moved_exn (t, m) k = let v = diff --git a/ocaml/libs/stunnel/stunnel_cache.ml b/ocaml/libs/stunnel/stunnel_cache.ml index 57f361d26ce..36d986b89c3 100644 --- a/ocaml/libs/stunnel/stunnel_cache.ml +++ b/ocaml/libs/stunnel/stunnel_cache.ml @@ -74,10 +74,13 @@ let unlocked_gc () = ( if debug_enabled then let now = Unix.gettimeofday () in let string_of_id id = - let stunnel = Tbl.find !stunnels id in - Printf.sprintf "(id %s / idle %.2f age %.2f)" (id_of_stunnel stunnel) - (now -. Hashtbl.find !times id) - (now -. stunnel.Stunnel.connected_time) + match (Tbl.find !stunnels id, Hashtbl.find_opt !times id) with + | Some stunnel, Some stunnel_id -> + Printf.sprintf "(id %s / idle %.2f age %.2f)" + (id_of_stunnel stunnel) (now -. stunnel_id) + (now -. stunnel.Stunnel.connected_time) + | _ -> + Printf.sprintf "%s: found no entry for id=%d" __FUNCTION__ id in let string_of_endpoint ep = Printf.sprintf "%s:%d" ep.host ep.port in let string_of_index ep xs = @@ -134,11 +137,15 @@ let unlocked_gc () = let oldest_ids = List.map fst oldest in List.iter (fun x -> - let stunnel = Tbl.find !stunnels x in - debug - "Expiring stunnel id %s since we have too many cached tunnels (limit \ - is %d)" - (id_of_stunnel stunnel) max_stunnel + match Tbl.find !stunnels x with + | Some stunnel -> + debug + "Expiring stunnel id %s since we have too many cached tunnels \ + (limit is %d)" + (id_of_stunnel stunnel) max_stunnel + | None -> + debug "%s: Couldn't find an expiring stunnel (id=%d) in the table" + __FUNCTION__ x ) oldest_ids ; to_gc := !to_gc @ oldest_ids @@ -146,8 +153,8 @@ let unlocked_gc () = (* Disconnect all stunnels we wish to GC *) List.iter (fun id -> - let s = Tbl.find !stunnels id in - Stunnel.disconnect s + (* Only remove stunnel if we find it in the table *) + Option.iter (fun s -> Stunnel.disconnect s) (Tbl.find !stunnels id) ) !to_gc ; (* Remove all reference to them from our cache hashtables *) @@ -201,23 +208,33 @@ let with_remove ~host ~port verified f = let get_id () = with_lock m (fun () -> unlocked_gc () ; - let ids = Hashtbl.find !index ep in - let table = List.map (fun id -> (id, Hashtbl.find !times id)) ids in + let ( let* ) = Option.bind in + let* ids = Hashtbl.find_opt !index ep in + let table = + List.filter_map + (fun id -> + Option.map (fun time -> (id, time)) (Hashtbl.find_opt !times id) + ) + ids + in let sorted = List.sort (fun a b -> compare (snd a) (snd b)) table in match sorted with | (id, time) :: _ -> - let stunnel = Tbl.find !stunnels id in - debug "Removing stunnel id %s (idle %.2f) from the cache" - (id_of_stunnel stunnel) - (Unix.gettimeofday () -. time) ; + Option.iter + (fun stunnel -> + debug "Removing stunnel id %s (idle %.2f) from the cache" + (id_of_stunnel stunnel) + (Unix.gettimeofday () -. time) + ) + (Tbl.find !stunnels id) ; Hashtbl.remove !times id ; Hashtbl.replace !index ep (List.filter (fun x -> x <> id) ids) ; - id + Some id | _ -> - raise Not_found + None ) in - let id_opt = try Some (get_id ()) with Not_found -> None in + let id_opt = get_id () in id_opt |> Option.map @@ fun id -> (* cannot call while holding above mutex or we deadlock *) From 47f3c3d68f839176007fb3168d169805d74d48c6 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 26 Jun 2024 13:17:10 +0100 Subject: [PATCH 4/5] Refactor Hashtbl.find out of xenopsd/xc/readln.ml Signed-off-by: Andrii Sultanov --- ocaml/xenopsd/xc/readln.ml | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/ocaml/xenopsd/xc/readln.ml b/ocaml/xenopsd/xc/readln.ml index bbd91fb6e47..928b289881c 100644 --- a/ocaml/xenopsd/xc/readln.ml +++ b/ocaml/xenopsd/xc/readln.ml @@ -23,25 +23,26 @@ let read fd = (Bytes.to_string pending) ) | n -> - let data = Bytes.sub buffer 0 n in - let inpt = try Hashtbl.find input fd with Not_found -> Bytes.empty in - Hashtbl.replace input fd (Bytes.cat inpt data) ; - let rec loop msgs = - let data = Hashtbl.find input fd in - (* never fails *) - match Bytes.index data '\n' with - | exception Not_found -> - Ok (List.rev msgs) - | index -> + let rec loop msgs data = + match Bytes.index_opt data '\n' with + | None -> + (List.rev msgs, data) + | Some index -> let remain = Bytes.sub data (index + 1) (Bytes.length data - index - 1) in - Hashtbl.replace input fd remain ; - (* reset input *) - loop (Bytes.sub_string data 0 index :: msgs) - (* store msg *) + loop + (Bytes.sub_string data 0 index :: msgs) + remain (* reset input *) + in + let data = Bytes.sub buffer 0 n in + let inpt = + Option.value (Hashtbl.find_opt input fd) ~default:Bytes.empty in - loop [] + let inp_data = Bytes.cat inpt data in + let res, data = loop [] inp_data in + Hashtbl.replace input fd data ; + Ok res | exception Unix.Unix_error (error, _, _) -> Error (Unix.error_message error) From d4be15e09702ab5be5bf68c7a2b786a0883b0758 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Thu, 27 Jun 2024 13:40:51 +0100 Subject: [PATCH 5/5] Add a gate for Hashbtl.find Signed-off-by: Andrii Sultanov --- quality-gate.sh | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/quality-gate.sh b/quality-gate.sh index f12113a215f..a3e443d007f 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -104,6 +104,19 @@ unixgetenv () { fi } +hashtblfind () { + N=36 + # Looks for all .ml files except the ones using Core.Hashtbl.find, + # which already returns Option + HASHTBLFIND=$(git grep -P -r --count 'Hashtbl.find(?!_opt)' -- '**/*.ml' ':!ocaml/xapi-storage-script/main.ml' | cut -d ':' -f 2 | paste -sd+ - | bc) + if [ "$HASHTBLFIND" -eq "$N" ]; then + echo "OK counted $HASHTBLFIND usages of exception-raising Hashtbl.find" + else + echo "ERROR expected $N usages of exception-raising Hashtbl.find, got $HASHTBLFIND" 1>&2 + exit 1 + fi +} + list-hd verify-cert mli-files @@ -112,4 +125,5 @@ vtpm-unimplemented vtpm-fields ocamlyacc unixgetenv +hashtblfind