From c4ebeee5053a2f4ac87968121c29b64a596d42aa Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Sun, 11 May 2025 12:37:23 +0100 Subject: [PATCH] Update common submodule Pull in these commits which require minor changes: Richard W.M. Jones (3): mlstdutils: Remove Std_utils.identity mlstdutils: Remove Std_utils.protect mlstdutils: Remove List.filter_map --- common | 2 +- daemon/btrfs.ml | 4 ++-- daemon/cryptsetup.ml | 2 +- daemon/filearch.ml | 2 +- daemon/inspect_utils.ml | 6 +++--- daemon/sfdisk.ml | 2 +- 6 files changed, 9 insertions(+), 9 deletions(-) Submodule common 4c7ae1581..3a05f1a7a: diff --git a/common/mlstdutils/std_utils.ml b/common/mlstdutils/std_utils.ml index 159fc4a..39b5bc9 100644 --- a/common/mlstdutils/std_utils.ml +++ b/common/mlstdutils/std_utils.ml @@ -58,13 +58,6 @@ module List = struct | [x] -> x | _ :: xs -> last xs - let rec filter_map f = function - | [] -> [] - | x :: xs -> - match f x with - | Some y -> y :: filter_map f xs - | None -> filter_map f xs - let rec find_map f = function | [] -> raise Not_found | x :: xs -> @@ -463,8 +456,6 @@ let ( /^ ) = Int64.div let ( &^ ) = Int64.logand let ( ~^ ) = Int64.lognot -external identity : 'a -> 'a = "%identity" - let roundup64 i a = let a = a -^ 1L in (i +^ a) &^ (~^ a) let div_roundup64 i a = (i +^ a -^ 1L) /^ a @@ -628,13 +619,6 @@ let unique = let i = ref 0 in fun () -> incr i; !i type ('a, 'b) maybe = Either of 'a | Or of 'b -let protect ~f ~finally = - let r = - try Either (f ()) - with exn -> Or exn in - finally (); - match r with Either ret -> ret | Or exn -> raise exn - type 'a return = { return: 'b. 'a -> 'b } [@@unboxed] let with_return (type a) f = let exception Return of a in @@ -691,15 +675,15 @@ let wrap () = !wrap let with_open_in filename f = let chan = open_in filename in - protect ~f:(fun () -> f chan) ~finally:(fun () -> close_in chan) + Fun.protect (fun () -> f chan) ~finally:(fun () -> close_in chan) let with_open_out filename f = let chan = open_out filename in - protect ~f:(fun () -> f chan) ~finally:(fun () -> close_out chan) + Fun.protect (fun () -> f chan) ~finally:(fun () -> close_out chan) let with_openfile filename flags perms f = let fd = Unix.openfile filename flags perms in - protect ~f:(fun () -> f fd) ~finally:(fun () -> Unix.close fd) + Fun.protect (fun () -> f fd) ~finally:(fun () -> Unix.close fd) let read_whole_file path = let buf = Buffer.create 16384 in diff --git a/common/mlstdutils/std_utils.mli b/common/mlstdutils/std_utils.mli index 2526100..04c780a 100644 --- a/common/mlstdutils/std_utils.mli +++ b/common/mlstdutils/std_utils.mli @@ -31,6 +31,7 @@ module List : sig val map : ('a -> 'b) -> 'a list -> 'b list val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list val rev_map : ('a -> 'b) -> 'a list -> 'b list + val filter_map : ('a -> 'b option) -> 'a list -> 'b list val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit @@ -90,9 +91,6 @@ module List : sig @raise Invalid_argument if the list is empty *) - val filter_map : ('a -> 'b option) -> 'a list -> 'b list - (** [filter_map f xs] applies [f] to each element of [xs]. If - [f x] returns [Some y] then [y] is added to the returned list. *) val find_map : ('a -> 'b option) -> 'a list -> 'b (** [find_map f xs] applies [f] to each element of [xs] until [f x] returns [Some y]. It returns [y]. If we exhaust the @@ -331,8 +329,6 @@ val ( &^ ) : int64 -> int64 -> int64 val ( ~^ ) : int64 -> int64 (** Various int64 operators. *) -external identity : 'a -> 'a = "%identity" - val roundup64 : int64 -> int64 -> int64 (** [roundup64 i a] returns [i] rounded up to the next multiple of [a]. *) val div_roundup64 : int64 -> int64 -> int64 @@ -371,18 +367,6 @@ val unique : unit -> int type ('a, 'b) maybe = Either of 'a | Or of 'b (** Like the Haskell [Either] type. *) -val protect : f:(unit -> 'a) -> finally:(unit -> unit) -> 'a -(** Execute [~f] and afterwards execute [~finally]. - - If [~f] throws an exception then [~finally] is run and the - original exception from [~f] is re-raised. - - If [~finally] throws an exception, then the original exception - is lost. (NB: Janestreet core {!Exn.protectx}, on which this - function is modelled, doesn't throw away the exception in this - case, but requires a lot more work by the caller. Perhaps we - will change this in future.) *) - type 'a return = { return: 'b. 'a -> 'b } [@@unboxed] val with_return : ('a return -> 'a) -> 'a (** {v diff --git a/common/mlstdutils/std_utils_tests.ml b/common/mlstdutils/std_utils_tests.ml index abe842b..10046bd 100644 --- a/common/mlstdutils/std_utils_tests.ml +++ b/common/mlstdutils/std_utils_tests.ml @@ -40,7 +40,7 @@ let assert_raises exn fn = ) let assert_equal_string = - assert_equal ~printer:identity + assert_equal ~printer:Fun.id let assert_equal_int = assert_equal ~printer:(fun x -> string_of_int x) let assert_equal_int64 = diff --git a/common/mlutils/c_utils_unit_tests.ml b/common/mlutils/c_utils_unit_tests.ml index 961dac5..50c7e44 100644 --- a/common/mlutils/c_utils_unit_tests.ml +++ b/common/mlutils/c_utils_unit_tests.ml @@ -42,7 +42,7 @@ let assert_raises exn fn = (* Test drive_name function. *) let () = - let printer = identity in + let printer = Fun.id in assert_equal ~printer "a" (drive_name 0); assert_equal ~printer "z" (drive_name 25); assert_equal ~printer "aa" (drive_name 26); @@ -74,7 +74,7 @@ let () = (* Test shell_unquote function. *) let () = - let printer = identity in + let printer = Fun.id in assert_equal ~printer "a" (shell_unquote "a"); assert_equal ~printer "b" (shell_unquote "'b'"); assert_equal ~printer "c" (shell_unquote "\"c\""); diff --git a/daemon/btrfs.ml b/daemon/btrfs.ml index 3f9d8308a..35e0b1765 100644 --- a/daemon/btrfs.ml +++ b/daemon/btrfs.ml @@ -48,7 +48,7 @@ let rec with_mounted mountable f = rmdir tmpdir in - protect ~finally ~f:(fun () -> mount_cmd tmpdir; f tmpdir) + Fun.protect ~finally (fun () -> mount_cmd tmpdir; f tmpdir) in match mountable.m_type with @@ -124,4 +124,4 @@ let btrfs_subvolume_get_default mountable = with_mounted mountable ( fun mp -> command "btrfs" ["subvolume"; "get-default"; mp] ) in - sscanf out "ID %Ld" identity + sscanf out "ID %Ld" Fun.id diff --git a/daemon/cryptsetup.ml b/daemon/cryptsetup.ml index ac2cf066e..9c0149b48 100644 --- a/daemon/cryptsetup.ml +++ b/daemon/cryptsetup.ml @@ -56,7 +56,7 @@ let cryptsetup_open ?(readonly = false) ?crypttype ?cipher device key mapname = Option.iter (fun s -> List.push_back_list args ["--cipher"; s]) cipher; (* Make sure we always remove the temporary file. *) - protect ~f:(fun () -> ignore (command "cryptsetup" !args)) + Fun.protect (fun () -> ignore (command "cryptsetup" !args)) ~finally:(fun () -> unlink keyfile); udev_settle () diff --git a/daemon/filearch.ml b/daemon/filearch.ml index 6eed7d396..f45392b5f 100644 --- a/daemon/filearch.ml +++ b/daemon/filearch.ml @@ -116,7 +116,7 @@ and cpio_arch magic orig_path path = let tmpdir = Mkdtemp.temp_dir "filearch" in let finally () = ignore (Sys.command (sprintf "rm -rf %s" (quote tmpdir))) in - protect ~finally ~f:( + Fun.protect ~finally ( fun () -> (* Construct a command to extract named binaries from the initrd file. *) let cmd = diff --git a/daemon/inspect_utils.ml b/daemon/inspect_utils.ml index 1aa762050..5ef8bfa25 100644 --- a/daemon/inspect_utils.ml +++ b/daemon/inspect_utils.ml @@ -57,8 +57,8 @@ let rec with_augeas ?name configfiles f = Augeas.create (Sysroot.sysroot ()) None [Augeas.AugSaveNoop; Augeas.AugNoLoad] in - protect - ~f:(fun () -> + Fun.protect + (fun () -> (* Tell Augeas to only load configfiles and no other files. This * prevents a rogue guest from performing a denial of service attack * by having large, over-complicated configuration files which are @@ -179,4 +179,4 @@ let with_hive hive_filename f = | Some f -> f :: flags in let flags = if verbose () then Hivex.OPEN_VERBOSE :: flags else flags in let h = Hivex.open_file hive_filename flags in - protect ~f:(fun () -> f h (Hivex.root h)) ~finally:(fun () -> Hivex.close h) + Fun.protect (fun () -> f h (Hivex.root h)) ~finally:(fun () -> Hivex.close h) diff --git a/daemon/sfdisk.ml b/daemon/sfdisk.ml index c694c328c..3265d1e83 100644 --- a/daemon/sfdisk.ml +++ b/daemon/sfdisk.ml @@ -35,7 +35,7 @@ let part_get_mbr_id device partnum = udev_settle (); (* It's printed in hex, possibly with a leading space. *) - sscanf out " %x" identity + sscanf out " %x" Fun.id let part_get_gpt_type device partnum = if partnum <= 0 then -- 2.47.1