11:54 a.m.
When rewriting the heavily imperative original inspection code, I
longed for a ‘return’ statement so I could keep the new code as close
as possible to the original. OCaml of course does not have such a
statement, but it's relatively simply to implement it in the language.
The first patch does so, and the second patch rewrites a sample of the
inspection code to use it.
Rich.
11:54 a.m.
New subject: [PATCH 1/2] common/mlstdutils: Add ‘return’ statement for OCaml.
This adds a ‘return’ statement as found in other programming
languages. You can use it like this:
with_return (fun {return} ->
some code ...
)
where ‘some code’ may either return implicitly (as usual), or may call
‘return x’ to immediately return ‘x’. All returned values must have
the same type.
The OCaml >= 4.04 implementation is by Petter A. Urkedal and octachron.
See this thread:
https://sympa.inria.fr/sympa/arc/caml-list/2017-11/msg00017.html
The version that works for any OCaml is by me. (Note that my version
cannot be nested).
---
common/mlstdutils/std_utils.ml | 16 ++++++++++++++++
common/mlstdutils/std_utils.mli | 14 ++++++++++++++
2 files changed, 30 insertions(+)
diff --git a/common/mlstdutils/std_utils.ml b/common/mlstdutils/std_utils.ml
index 32bba4113..ba23f39ed 100644
--- a/common/mlstdutils/std_utils.ml
+++ b/common/mlstdutils/std_utils.ml
@@ -598,6 +598,22 @@ let protect ~f ~finally =
finally ();
match r with Either ret -> ret | Or exn -> raise exn
+type 'a return = { return: 'b. 'a -> 'b } (* OCaml >= 4.03:
[@@unboxed] *)
+(* This requires features in OCaml >= 4.04:
+let with_return (type a) f =
+ let exception Return of a in
+ try f {return = fun ret -> raise (Return ret)} with Return ret -> ret
+*)
+
+(* This should work for any version of OCaml, but it doesn't work
+ * properly for nested with_return statements. When we can assume
+ * OCaml >= 4.04 we should use the above definition instead.
+ *)
+let with_return f =
+ let ret = ref None in
+ try f {return = fun r -> ret := Some r; raise Exit}
+ with Exit -> match !ret with None -> assert false | Some r -> r
+
let failwithf fs = ksprintf failwith fs
exception Executable_not_found of string (* executable *)
diff --git a/common/mlstdutils/std_utils.mli b/common/mlstdutils/std_utils.mli
index b3cfdcd55..96c55a511 100644
--- a/common/mlstdutils/std_utils.mli
+++ b/common/mlstdutils/std_utils.mli
@@ -347,6 +347,20 @@ val protect : f:(unit -> 'a) -> finally:(unit -> unit)
-> 'a
case, but requires a lot more work by the caller. Perhaps we
will change this in future.) *)
+type 'a return = { return: 'b. 'a -> 'b } (* OCaml >= 4.03:
[@@unboxed] *)
+val with_return : ('a return -> 'a) -> 'a
+(** {v
+ with_return (fun {return} ->
+ some code ...
+ )
+ v}
+ emulates the [return] statement found in other programming
+ languages.
+
+ The ‘some code’ part may either return implicitly, or may call
+ [return x] to immediately return the value [x]. All returned
+ values must have the same type. *)
+
val failwithf : ('a, unit, string, 'b) format4 -> 'a
(** Like [failwith] but supports printf-like arguments. *)
--
2.13.2
11:54 a.m.
New subject: [PATCH 2/2] daemon: Rewrite inspection code using ‘return’ statements.
When rewriting this, I revisited the original C code and changed the
OCaml code so it's now reasonably similar to the original.
---
daemon/inspect_fs_unix_fstab.ml | 205 +++++++++++++++++++++-------------------
1 file changed, 107 insertions(+), 98 deletions(-)
diff --git a/daemon/inspect_fs_unix_fstab.ml b/daemon/inspect_fs_unix_fstab.ml
index 658e0cf10..371474d63 100644
--- a/daemon/inspect_fs_unix_fstab.ml
+++ b/daemon/inspect_fs_unix_fstab.ml
@@ -55,111 +55,120 @@ and check_fstab_aug mdadm_conf root_mountable os_type aug =
List.filter_map (check_fstab_entry md_map root_mountable os_type aug) entries
and check_fstab_entry md_map root_mountable os_type aug entry =
- if verbose () then
- eprintf "check_fstab_entry: augeas path: %s\n%!" entry;
+ with_return (fun {return} ->
+ if verbose () then
+ eprintf "check_fstab_entry: augeas path: %s\n%!" entry;
- let is_bsd =
- match os_type with
- | OS_TYPE_FREEBSD | OS_TYPE_NETBSD | OS_TYPE_OPENBSD -> true
- | OS_TYPE_DOS | OS_TYPE_HURD | OS_TYPE_LINUX | OS_TYPE_MINIX
- | OS_TYPE_WINDOWS -> false in
+ let is_bsd =
+ match os_type with
+ | OS_TYPE_FREEBSD | OS_TYPE_NETBSD | OS_TYPE_OPENBSD -> true
+ | OS_TYPE_DOS | OS_TYPE_HURD | OS_TYPE_LINUX | OS_TYPE_MINIX
+ | OS_TYPE_WINDOWS -> false in
- let spec = aug_get_noerrors aug (entry ^ "/spec") in
- let mp = aug_get_noerrors aug (entry ^ "/file") in
- let vfstype = aug_get_noerrors aug (entry ^ "/vfstype") in
+ let spec = aug_get_noerrors aug (entry ^ "/spec") in
+ let spec =
+ match spec with
+ | None -> return None
+ | Some spec -> spec in
- match spec, mp, vfstype with
- | None, _, _ | Some _, None, _ | Some _, Some _, None -> None
- | Some spec, Some mp, Some vfstype ->
- if verbose () then
- eprintf "check_fstab_entry: spec=%s mp=%s vfstype=%s\n%!"
- spec mp vfstype;
+ if verbose () then eprintf "check_fstab_entry: spec=%s\n%!" spec;
- (* Ignore /dev/fd (floppy disks) (RHBZ#642929) and CD-ROM drives.
- *
- * /dev/iso9660/FREEBSD_INSTALL can be found in FreeBSD's
- * installation discs.
- *)
- if (String.is_prefix spec "/dev/fd" &&
- String.length spec >= 8 && Char.isdigit spec.[7]) ||
- (String.is_prefix spec "/dev/cd" &&
- String.length spec >= 8 && Char.isdigit spec.[7]) ||
- spec = "/dev/floppy" ||
- spec = "/dev/cdrom" ||
- String.is_prefix spec "/dev/iso9660/" then
- None
- else (
- (* Canonicalize the path, so "///usr//local//" ->
"/usr/local" *)
- let mp = unix_canonical_path mp in
+ (* Ignore /dev/fd (floppy disks) (RHBZ#642929) and CD-ROM drives.
+ *
+ * /dev/iso9660/FREEBSD_INSTALL can be found in FreeBSD's
+ * installation discs.
+ *)
+ if (String.is_prefix spec "/dev/fd" &&
+ String.length spec >= 8 && Char.isdigit spec.[7]) ||
+ (String.is_prefix spec "/dev/cd" &&
+ String.length spec >= 8 && Char.isdigit spec.[7]) ||
+ spec = "/dev/floppy" ||
+ spec = "/dev/cdrom" ||
+ String.is_prefix spec "/dev/iso9660/" then
+ return None;
- (* Ignore certain mountpoints. *)
- if String.is_prefix mp "/dev/" ||
- mp = "/dev" ||
- String.is_prefix mp "/media/" ||
- String.is_prefix mp "/proc/" ||
- mp = "/proc" ||
- String.is_prefix mp "/selinux/" ||
- mp = "/selinux" ||
- String.is_prefix mp "/sys/" ||
- mp = "/sys" then
- None
- else (
- let mountable =
- (* Resolve UUID= and LABEL= to the actual device. *)
- if String.is_prefix spec "UUID=" then (
- let uuid = String.sub spec 5 (String.length spec - 5) in
- let uuid = shell_unquote uuid in
- Some (Mountable.of_device (Findfs.findfs_uuid uuid))
- )
- else if String.is_prefix spec "LABEL=" then (
- let label = String.sub spec 6 (String.length spec - 6) in
- let label = shell_unquote label in
- Some (Mountable.of_device (Findfs.findfs_label label))
- )
- (* Resolve /dev/root to the current device.
- * Do the same for the / partition of the *BSD
- * systems, since the BSD -> Linux device
- * translation is not straight forward.
- *)
- else if spec = "/dev/root" || (is_bsd && mp = "/")
then
- Some root_mountable
- (* Resolve guest block device names. *)
- else if String.is_prefix spec "/dev/" then
- Some (resolve_fstab_device spec md_map os_type)
- (* In OpenBSD's fstab you can specify partitions
- * on a disk by appending a period and a partition
- * letter to a Disklable Unique Identifier. The
- * DUID is a 16 hex digit field found in the
- * OpenBSD's altered BSD disklabel. For more info
- * see here:
- * http://www.openbsd.org/faq/faq14.html#intro
- *)
- else if PCRE.matches re_openbsd_duid spec then (
- let part = spec.[17] in
- (* We cannot peep into disklabels, we can only
- * assume that this is the first disk.
- *)
- let device = sprintf "/dev/sd0%c" part in
- Some (resolve_fstab_device device md_map os_type)
- )
- (* Ignore "/.swap" (Pardus) and pseudo-devices
- * like "tmpfs". If we haven't resolved the device
- * successfully by this point, just ignore it.
- *)
- else
- None in
+ let mp = aug_get_noerrors aug (entry ^ "/file") in
+ let mp =
+ match mp with
+ | None -> return None
+ | Some mp -> mp in
- match mountable with
- | None -> None
- | Some mountable ->
- let mountable =
- if vfstype = "btrfs" then
- get_btrfs_mountable aug entry mountable
- else mountable in
+ (* Canonicalize the path, so "///usr//local//" -> "/usr/local"
*)
+ let mp = unix_canonical_path mp in
- Some (mountable, mp)
- )
- )
+ if verbose () then eprintf "check_fstab_entry: mp=%s\n%!" mp;
+
+ (* Ignore certain mountpoints. *)
+ if String.is_prefix mp "/dev/" ||
+ mp = "/dev" ||
+ String.is_prefix mp "/media/" ||
+ String.is_prefix mp "/proc/" ||
+ mp = "/proc" ||
+ String.is_prefix mp "/selinux/" ||
+ mp = "/selinux" ||
+ String.is_prefix mp "/sys/" ||
+ mp = "/sys" then
+ return None;
+
+ let mountable =
+ (* Resolve UUID= and LABEL= to the actual device. *)
+ if String.is_prefix spec "UUID=" then (
+ let uuid = String.sub spec 5 (String.length spec - 5) in
+ let uuid = shell_unquote uuid in
+ Mountable.of_device (Findfs.findfs_uuid uuid)
+ )
+ else if String.is_prefix spec "LABEL=" then (
+ let label = String.sub spec 6 (String.length spec - 6) in
+ let label = shell_unquote label in
+ Mountable.of_device (Findfs.findfs_label label)
+ )
+ (* Resolve /dev/root to the current device.
+ * Do the same for the / partition of the *BSD
+ * systems, since the BSD -> Linux device
+ * translation is not straight forward.
+ *)
+ else if spec = "/dev/root" || (is_bsd && mp = "/")
then
+ root_mountable
+ (* Resolve guest block device names. *)
+ else if String.is_prefix spec "/dev/" then
+ resolve_fstab_device spec md_map os_type
+ (* In OpenBSD's fstab you can specify partitions
+ * on a disk by appending a period and a partition
+ * letter to a Disklable Unique Identifier. The
+ * DUID is a 16 hex digit field found in the
+ * OpenBSD's altered BSD disklabel. For more info
+ * see here:
+ * http://www.openbsd.org/faq/faq14.html#intro
+ *)
+ else if PCRE.matches re_openbsd_duid spec then (
+ let part = spec.[17] in
+ (* We cannot peep into disklabels, we can only
+ * assume that this is the first disk.
+ *)
+ let device = sprintf "/dev/sd0%c" part in
+ resolve_fstab_device device md_map os_type
+ )
+ (* Ignore "/.swap" (Pardus) and pseudo-devices
+ * like "tmpfs". If we haven't resolved the device
+ * successfully by this point, just ignore it.
+ *)
+ else
+ return None in
+
+ let vfstype = aug_get_noerrors aug (entry ^ "/vfstype") in
+ let vfstype =
+ match vfstype with
+ | None -> return None
+ | Some vfstype -> vfstype in
+ if verbose () then eprintf "check_fstab_entry: vfstype=%s\n%!" vfstype;
+
+ let mountable =
+ if vfstype = "btrfs" then
+ get_btrfs_mountable aug entry mountable
+ else mountable in
+
+ Some (mountable, mp)
+ )
(* If an fstab entry corresponds to a btrfs filesystem, look for
* the 'subvol' option and if it is present then return a btrfs
--
2.13.2
2455
days inactive
2455
days old
2 comments
1 participants
participants (1)
-
Richard W.M. Jones