Libguestfs - Sep 2020 - [PATCH v2 1/7] New APIs: cryptsetup-open and cryptsetup-close.

Original version linked from here:
https://bugzilla.redhat.com/show_bug.cgi?id=1808977#c8

There is no change in the code in this series, but feedback from the
original series was we shouldn't lose the error message in patch 7.

When I tested this just now in fact we don't lose the error if
debugging is enabled, but I have updated the commit message to note
what the error message is in the BitLocker case.

Rich.

This commit deprecates luks-open/luks-open-ro/luks-close for the more
generic sounding names cryptsetup-open/cryptsetup-close, which also
correspond directly to the cryptsetup commands.

The optional cryptsetup-open readonly flag is used to replace the
functionality of luks-open-ro.

The optional cryptsetup-open crypttype parameter can be used to select
the type (corresponding to cryptsetup open --type), which allows us to
open BitLocker-encrypted disks with no extra effort.  As a convenience
the crypttype parameter may be omitted, and libguestfs will use a
heuristic (based on vfs-type output) to try to determine the correct
type to use.

The deprecated functions and the new functions are all (re-)written in
OCaml.

There is no new test here, unfortunately.  It would be nice to test
Windows BitLocker support in this new API, however the Linux tools do
not support creating BitLocker disks, and while it is possible to
create one under Windows, the smallest compressed disk I could create
is 37M because of a mixture of the minimum support size for BitLocker
disks and the fact that encrypted parts of NTFS cannot be compressed.
---
 .gitignore                           |   1 +
 daemon/Makefile.am                   |   3 +
 daemon/cryptsetup.ml                 |  83 +++++++++++++++++++++
 daemon/luks.c                        |  83 ---------------------
 generator/actions_core.ml            | 106 +++++++++++++++------------
 generator/actions_core_deprecated.ml |  52 +++++++++++++
 generator/daemon.ml                  |   5 +-
 generator/proc_nr.ml                 |   2 +
 gobject/Makefile.inc                 |   2 +
 lib/MAX_PROC_NR                      |   2 +-
 lib/guestfs.pod                      |  17 +++--
 11 files changed, 216 insertions(+), 140 deletions(-)

diff --git a/.gitignore b/.gitignore
index ab4cd0667..39354de51 100644
--- a/.gitignore
+++ b/.gitignore
@@ -147,6 +147,7 @@ Makefile.in
 /daemon/btrfs.mli
 /daemon/callbacks.ml
 /daemon/caml-stubs.c
+/daemon/cryptsetup.mli
 /daemon/daemon_config.ml
 /daemon/daemon_utils_tests
 /daemon/devsparts.mli
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index e57e5a506..480192e1c 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -39,6 +39,7 @@ generator_built = \
 	blkid.mli \
 	btrfs.mli \
 	callbacks.ml \
+	cryptsetup.mli \
 	devsparts.mli \
 	file.mli \
 	filearch.mli \
@@ -269,6 +270,7 @@ SOURCES_MLI = \
 	btrfs.mli \
 	callbacks.mli \
 	chroot.mli \
+	cryptsetup.mli \
 	daemon.mli \
 	daemon_config.mli \
 	devsparts.mli \
@@ -310,6 +312,7 @@ SOURCES_ML = \
 	chroot.ml \
 	blkid.ml \
 	btrfs.ml \
+	cryptsetup.ml \
 	devsparts.ml \
 	file.ml \
 	filearch.ml \
diff --git a/daemon/cryptsetup.ml b/daemon/cryptsetup.ml
new file mode 100644
index 000000000..e4e6a114c
--- /dev/null
+++ b/daemon/cryptsetup.ml
@@ -0,0 +1,83 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2020 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Printf
+open Unix
+
+open Std_utils
+
+open Utils
+
+let cryptsetup_open ?(readonly = false) ?crypttype device key mapname +  (*
/dev/mapper/mapname must not exist already. *)
+  let devmapper = sprintf "/dev/mapper/%s" mapname in
+  if is_block_device devmapper then
+    failwithf "%s: device already exists" devmapper;
+
+  (* Heuristically determine the encryption type. *)
+  let crypttype +    match crypttype with
+    | Some s -> s
+    | None ->
+       let t = Blkid.vfs_type (Mountable.of_device device) in
+       match t with
+       | "crypto_LUKS" -> "luks"
+       | "BitLocker" -> "bitlk"
+       | _ ->
+          failwithf "%s: unknown encrypted device type" t in
+
+  (* Write the key to a temporary file. *)
+  let keyfile, chan = Filename.open_temp_file "crypt"
".key" in
+  fchmod (descr_of_out_channel chan) 0o600;
+  output_string chan key;
+  close_out chan;
+
+  (* Make sure we always remove the temporary file. *)
+  protect ~f:(
+    fun () ->
+      let args = ref [] in
+      List.push_back_list args ["-d"; keyfile];
+      if readonly then List.push_back args "--readonly";
+      List.push_back_list args ["open"; device; mapname;
"--type"; crypttype];
+      ignore (command "cryptsetup" !args)
+  ) ~finally:(fun () -> unlink keyfile);
+
+  udev_settle ()
+
+let cryptsetup_close device +  (* Must be /dev/mapper/... *)
+  if not (String.is_prefix device "/dev/mapper/") then
+    failwithf "%s: you must call this on the /dev/mapper device created by
cryptsetup-open" device;
+
+  let mapname = String.sub device 12 (String.length device - 12) in
+  ignore (command "cryptsetup" ["close"; mapname]);
+
+  udev_settle ()
+
+(* Deprecated APIs for backwards compatibility.
+ *
+ * For convenient for existing callers we do not specify the
+ * crypttype parameter.  This means that callers of these APIs
+ * will be able to open BitLocker drives transparently.  (If
+ * we wanted to be strict we would pass ~crypttype:"luks"
+ * here, but that seems to have only downsides).
+ *)
+let luks_open device key mapname = cryptsetup_open device key mapname
+let luks_open_ro device key mapname +  cryptsetup_open ~readonly:true device
key mapname
+let luks_close = cryptsetup_close
diff --git a/daemon/luks.c b/daemon/luks.c
index d631cb100..51ced585d 100644
--- a/daemon/luks.c
+++ b/daemon/luks.c
@@ -81,89 +81,6 @@ remove_temp (char *tempfile)
   free (tempfile);
 }
 
-static int
-luks_open (const char *device, const char *key, const char *mapname,
-           int readonly)
-{
-  /* Sanity check: /dev/mapper/mapname must not exist already.  Note
-   * that the device-mapper control device (/dev/mapper/control) is
-   * always there, so you can't ever have mapname == "control".
-   */
-  CLEANUP_FREE char *devmapper = NULL;
-  if (asprintf (&devmapper, "/dev/mapper/%s", mapname) == -1) {
-    reply_with_perror ("asprintf");
-    return -1;
-  }
-  if (access (devmapper, F_OK) == 0) {
-    reply_with_error ("%s: device already exists", devmapper);
-    return -1;
-  }
-
-  char *tempfile = write_key_to_temp (key);
-  if (!tempfile)
-    return -1;
-
-  const char *argv[MAX_ARGS];
-  size_t i = 0;
-
-  ADD_ARG (argv, i, "cryptsetup");
-  ADD_ARG (argv, i, "-d");
-  ADD_ARG (argv, i, tempfile);
-  if (readonly) ADD_ARG (argv, i, "--readonly");
-  ADD_ARG (argv, i, "luksOpen");
-  ADD_ARG (argv, i, device);
-  ADD_ARG (argv, i, mapname);
-  ADD_ARG (argv, i, NULL);
-
-  CLEANUP_FREE char *err = NULL;
-  int r = commandv (NULL, &err, (const char * const *) argv);
-  remove_temp (tempfile);
-
-  if (r == -1) {
-    reply_with_error ("%s", err);
-    return -1;
-  }
-
-  udev_settle ();
-
-  return 0;
-}
-
-int
-do_luks_open (const char *device, const char *key, const char *mapname)
-{
-  return luks_open (device, key, mapname, 0);
-}
-
-int
-do_luks_open_ro (const char *device, const char *key, const char *mapname)
-{
-  return luks_open (device, key, mapname, 1);
-}
-
-int
-do_luks_close (const char *device)
-{
-  /* Must be /dev/mapper/... */
-  if (! STRPREFIX (device, "/dev/mapper/")) {
-    reply_with_error ("luks_close: you must call this on the /dev/mapper
device created by luks_open");
-    return -1;
-  }
-
-  const char *mapname = &device[12];
-
-  CLEANUP_FREE char *err = NULL;
-  int r = command (NULL, &err, "cryptsetup",
"luksClose", mapname, NULL);
-  if (r == -1) {
-    reply_with_error ("%s", err);
-    return -1;
-  }
-
-  udev_settle ();
-
-  return 0;
-}
-
 static int
 luks_format (const char *device, const char *key, int keyslot,
              const char *cipher)
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 9a24a8d78..54156b2b8 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -5664,52 +5664,6 @@ will be able to see every block device.
 This command also clears the LVM cache and performs a volume
 group scan." };
 
-  { defaults with
-    name = "luks_open"; added = (1, 5, 1);
-    style = RErr, [String (Device, "device"); String (Key,
"key"); String (PlainString, "mapname")], [];
-    optional = Some "luks";
-    shortdesc = "open a LUKS-encrypted block device";
-    longdesc = "\
-This command opens a block device which has been encrypted
-according to the Linux Unified Key Setup (LUKS) standard.
-
-C<device> is the encrypted block device or partition.
-
-The caller must supply one of the keys associated with the
-LUKS block device, in the C<key> parameter.
-
-This creates a new block device called F</dev/mapper/mapname>.
-Reads and writes to this block device are decrypted from and
-encrypted to the underlying C<device> respectively.
-
-If this block device contains LVM volume groups, then
-calling C<guestfs_lvm_scan> with the C<activate>
-parameter C<true> will make them visible.
-
-Use C<guestfs_list_dm_devices> to list all device mapper
-devices." };
-
-  { defaults with
-    name = "luks_open_ro"; added = (1, 5, 1);
-    style = RErr, [String (Device, "device"); String (Key,
"key"); String (PlainString, "mapname")], [];
-    optional = Some "luks";
-    shortdesc = "open a LUKS-encrypted block device read-only";
-    longdesc = "\
-This is the same as C<guestfs_luks_open> except that a read-only
-mapping is created." };
-
-  { defaults with
-    name = "luks_close"; added = (1, 5, 1);
-    style = RErr, [String (Device, "device")], [];
-    optional = Some "luks";
-    shortdesc = "close a LUKS device";
-    longdesc = "\
-This closes a LUKS device that was created earlier by
-C<guestfs_luks_open> or C<guestfs_luks_open_ro>.  The
-C<device> parameter must be the name of the LUKS mapping
-device (ie. F</dev/mapper/mapname>) and I<not> the name
-of the underlying block device." };
-
   { defaults with
     name = "luks_format"; added = (1, 5, 2);
     style = RErr, [String (Device, "device"); String (Key,
"key"); Int "keyslot"], [];
@@ -9753,4 +9707,64 @@ is used)." };
     longdesc = "\
 This returns the UUID of the LUKS device C<device>." };
 
+  { defaults with
+    name = "cryptsetup_open"; added = (1, 43, 1);
+    style = RErr, [String (Device, "device"); String (Key,
"key"); String (PlainString, "mapname")], [OBool
"readonly"; OString "crypttype"];
+    impl = OCaml "Cryptsetup.cryptsetup_open";
+    optional = Some "luks";
+    test_excuse = "no way to format BitLocker, and smallest device is
huge";
+    shortdesc = "open an encrypted block device";
+    longdesc = "\
+This command opens a block device which has been encrypted
+according to the Linux Unified Key Setup (LUKS) standard,
+Windows BitLocker, or some other types.
+
+C<device> is the encrypted block device or partition.
+
+The caller must supply one of the keys associated with the
+encrypted block device, in the C<key> parameter.
+
+This creates a new block device called F</dev/mapper/mapname>.
+Reads and writes to this block device are decrypted from and
+encrypted to the underlying C<device> respectively.
+
+If the optional C<crypttype> parameter is not present then
+libguestfs tries to guess the correct type (for example
+LUKS or BitLocker).  However you can override this by
+specifying one of the following types:
+
+=over 4
+
+=item C<luks>
+
+A Linux LUKS device.
+
+=item C<bitlk>
+
+A Windows BitLocker device.
+
+=back
+
+The optional C<readonly> flag, if set to true, creates a
+read-only mapping.
+
+If this block device contains LVM volume groups, then
+calling C<guestfs_lvm_scan> with the C<activate>
+parameter C<true> will make them visible.
+
+Use C<guestfs_list_dm_devices> to list all device mapper
+devices." };
+
+  { defaults with
+    name = "cryptsetup_close"; added = (1, 43, 1);
+    style = RErr, [String (Device, "device")], [];
+    impl = OCaml "Cryptsetup.cryptsetup_close";
+    optional = Some "luks";
+    shortdesc = "close an encrypted device";
+    longdesc = "\
+This closes an encrypted device that was created earlier by
+C<guestfs_cryptsetup_open>.  The C<device> parameter must be
+the name of the mapping device (ie. F</dev/mapper/mapname>)
+and I<not> the name of the underlying block device." };
+
 ]
diff --git a/generator/actions_core_deprecated.ml
b/generator/actions_core_deprecated.ml
index 8556763b7..299f9854b 100644
--- a/generator/actions_core_deprecated.ml
+++ b/generator/actions_core_deprecated.ml
@@ -847,4 +847,56 @@ allows you to specify the new size (in bytes)
explicitly." };
 This rescans all block devices and rebuilds the list of LVM
 physical volumes, volume groups and logical volumes." };
 
+  { defaults with
+    name = "luks_open"; added = (1, 5, 1);
+    style = RErr, [String (Device, "device"); String (Key,
"key"); String (PlainString, "mapname")], [];
+    impl = OCaml "Cryptsetup.luks_open";
+    optional = Some "luks";
+    deprecated_by = Replaced_by "cryptsetup_open";
+    shortdesc = "open a LUKS-encrypted block device";
+    longdesc = "\
+This command opens a block device which has been encrypted
+according to the Linux Unified Key Setup (LUKS) standard.
+
+C<device> is the encrypted block device or partition.
+
+The caller must supply one of the keys associated with the
+LUKS block device, in the C<key> parameter.
+
+This creates a new block device called F</dev/mapper/mapname>.
+Reads and writes to this block device are decrypted from and
+encrypted to the underlying C<device> respectively.
+
+If this block device contains LVM volume groups, then
+calling C<guestfs_lvm_scan> with the C<activate>
+parameter C<true> will make them visible.
+
+Use C<guestfs_list_dm_devices> to list all device mapper
+devices." };
+
+  { defaults with
+    name = "luks_open_ro"; added = (1, 5, 1);
+    style = RErr, [String (Device, "device"); String (Key,
"key"); String (PlainString, "mapname")], [];
+    impl = OCaml "Cryptsetup.luks_open_ro";
+    optional = Some "luks";
+    deprecated_by = Replaced_by "cryptsetup_open";
+    shortdesc = "open a LUKS-encrypted block device read-only";
+    longdesc = "\
+This is the same as C<guestfs_luks_open> except that a read-only
+mapping is created." };
+
+  { defaults with
+    name = "luks_close"; added = (1, 5, 1);
+    style = RErr, [String (Device, "device")], [];
+    impl = OCaml "Cryptsetup.luks_close";
+    optional = Some "luks";
+    deprecated_by = Replaced_by "cryptsetup_close";
+    shortdesc = "close a LUKS device";
+    longdesc = "\
+This closes a LUKS device that was created earlier by
+C<guestfs_luks_open> or C<guestfs_luks_open_ro>.  The
+C<device> parameter must be the name of the LUKS mapping
+device (ie. F</dev/mapper/mapname>) and I<not> the name
+of the underlying block device." };
+
 ]
diff --git a/generator/daemon.ml b/generator/daemon.ml
index 9edef462c..b1047427b 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -776,7 +776,8 @@ let generate_daemon_caml_stubs ()                pr
"Val_bool (%s)" n;
            | OInt _ -> assert false
            | OInt64 _ -> assert false
-           | OString _ -> assert false
+           | OString _ ->
+              pr "caml_copy_string (%s)" n
            | OStringList _ -> assert false
           );
           pr ";\n";
@@ -792,7 +793,7 @@ let generate_daemon_caml_stubs ()             | Bool n ->
pr "Val_bool (%s)" n
            | Int n -> pr "Val_int (%s)" n
            | Int64 n -> pr "caml_copy_int64 (%s)" n
-           | String ((PlainString|Device|Pathname|Dev_or_Path), n) ->
+           | String ((PlainString|Device|Pathname|Dev_or_Path|Key), n) ->
               pr "caml_copy_string (%s)" n
            | String ((Mountable|Mountable_or_Path), n) ->
               pr "guestfs_int_daemon_copy_mountable (%s)" n
diff --git a/generator/proc_nr.ml b/generator/proc_nr.ml
index d8e7e1282..30e42864f 100644
--- a/generator/proc_nr.ml
+++ b/generator/proc_nr.ml
@@ -514,6 +514,8 @@ let proc_nr = [
 505, "f2fs_expand";
 506, "lvm_scan";
 507, "luks_uuid";
+508, "cryptsetup_open";
+509, "cryptsetup_close";
 ]
 
 (* End of list.  If adding a new entry, add it at the end of the list
diff --git a/gobject/Makefile.inc b/gobject/Makefile.inc
index 84ad960ef..650f8ddac 100644
--- a/gobject/Makefile.inc
+++ b/gobject/Makefile.inc
@@ -69,6 +69,7 @@ guestfs_gobject_headers= \
   include/guestfs-gobject/optargs-copy_file_to_device.h \
   include/guestfs-gobject/optargs-copy_file_to_file.h \
   include/guestfs-gobject/optargs-cpio_out.h \
+  include/guestfs-gobject/optargs-cryptsetup_open.h \
   include/guestfs-gobject/optargs-disk_create.h \
   include/guestfs-gobject/optargs-download_blocks.h \
   include/guestfs-gobject/optargs-e2fsck.h \
@@ -162,6 +163,7 @@ guestfs_gobject_sources= \
   src/optargs-copy_file_to_device.c \
   src/optargs-copy_file_to_file.c \
   src/optargs-cpio_out.c \
+  src/optargs-cryptsetup_open.c \
   src/optargs-disk_create.c \
   src/optargs-download_blocks.c \
   src/optargs-e2fsck.c \
diff --git a/lib/MAX_PROC_NR b/lib/MAX_PROC_NR
index 055b6671a..77afe238f 100644
--- a/lib/MAX_PROC_NR
+++ b/lib/MAX_PROC_NR
@@ -1 +1 @@
-507
+509
diff --git a/lib/guestfs.pod b/lib/guestfs.pod
index d746a41b1..bce9eb79f 100644
--- a/lib/guestfs.pod
+++ b/lib/guestfs.pod
@@ -585,17 +585,18 @@ Libguestfs allows you to access Linux guests which have
been
 encrypted using whole disk encryption that conforms to the
 Linux Unified Key Setup (LUKS) standard.  This includes
 nearly all whole disk encryption systems used by modern
-Linux guests.
+Linux guests.  Windows BitLocker is also supported.
 
-Use L</guestfs_vfs_type> to identify LUKS-encrypted block
-devices (it returns the string C<crypto_LUKS>).
+Use L</guestfs_vfs_type> to identify encrypted block
+devices.  For LUKS it returns the string C<crypto_LUKS>.
+For Windows BitLocker it returns C<BitLocker>.
 
-Then open these devices by calling L</guestfs_luks_open>.
+Then open these devices by calling L</guestfs_cryptsetup_open>.
 Obviously you will require the passphrase!
 
-Opening a LUKS device creates a new device mapper device
+Opening an encrypted device creates a new device mapper device
 called F</dev/mapper/mapname> (where C<mapname> is the
-string you supply to L</guestfs_luks_open>).
+string you supply to L</guestfs_cryptsetup_open>).
 Reads and writes to this mapper device are decrypted from and
 encrypted to the underlying block device respectively.
 
@@ -603,11 +604,11 @@ LVM volume groups on the device can be made visible by
calling
 L</guestfs_vgscan> followed by L</guestfs_vg_activate_all>.
 The logical volume(s) can now be mounted in the usual way.
 
-Use the reverse process to close a LUKS device.  Unmount
+Use the reverse process to close an encrypted device.  Unmount
 any logical volumes on it, deactivate the volume groups
 by calling C<guestfs_vg_activate (g, 0, ["/dev/VG"])>.
 Then close the mapper device by calling
-L</guestfs_luks_close> on the F</dev/mapper/mapname>
+L</guestfs_cryptsetup_close> on the F</dev/mapper/mapname>
 device (I<not> the underlying encrypted block device).
 
 =head2 MOUNT LOCAL
-- 
2.27.0

---
 fish/guestfish.pod | 30 ++++++++++++++++++------------
 1 file changed, 18 insertions(+), 12 deletions(-)

diff --git a/fish/guestfish.pod b/fish/guestfish.pod
index c4fdd17b7..9f086f110 100644
--- a/fish/guestfish.pod
+++ b/fish/guestfish.pod
@@ -857,34 +857,40 @@ it, eg:
 
 Libguestfs has some support for Linux guests encrypted according to
 the Linux Unified Key Setup (LUKS) standard, which includes nearly all
-whole disk encryption systems used by modern Linux guests.  Currently
-only LVM-on-LUKS is supported.
+whole disk encryption systems used by modern Linux guests, and Windows
+BitLocker.
 
 Identify encrypted block devices and partitions using L</vfs-type>:
 
  ><fs> vfs-type /dev/sda2
  crypto_LUKS
 
-Then open those devices using L</luks-open>.  This creates a
-device-mapper device called F</dev/mapper/luksdev>.
+or:
 
- ><fs> luks-open /dev/sda2 luksdev
+ ><fs> vfs-type /dev/sda2
+ BitLocker
+
+Then open those devices using L</cryptsetup-open>.
+This creates a device-mapper device called F</dev/mapper/name>.
+
+ ><fs> cryptsetup-open /dev/sda2 name
  Enter key or passphrase ("key"): <enter the passphrase>
 
-Finally you have to tell LVM to scan for volume groups on
-the newly created mapper device:
+For Linux guests you have to tell LVM to scan for volume groups on the
+newly created mapper device:
 
  vgscan
  vg-activate-all true
 
-The logical volume(s) can now be mounted in the usual way.
+The filesystems or logical volumes can now be mounted in the usual way.
 
-Before closing a LUKS device you must unmount any logical volumes on
-it and deactivate the volume groups by calling C<vg-activate false VG>
-on each one.  Then you can close the mapper device:
+Before closing an encrypted device you must unmount any logical
+volumes on it and deactivate the volume groups by calling
+C<vg-activate false VG> on each one.  Then you can close the mapper
+device:
 
  vg-activate false /dev/VG
- luks-close /dev/mapper/luksdev
+ cryptsetup-close /dev/mapper/name
 
 =head1 WINDOWS PATHS
 
-- 
2.27.0

Simple refactoring to make the code clearer, should have no other
effect.
---
 daemon/listfs.ml | 64 ++++++++++++++++++++++++------------------------
 1 file changed, 32 insertions(+), 32 deletions(-)

diff --git a/daemon/listfs.ml b/daemon/listfs.ml
index 903f363d0..3b71471ae 100644
--- a/daemon/listfs.ml
+++ b/daemon/listfs.ml
@@ -28,38 +28,36 @@ let rec list_filesystems ()    let has_lvm2 =
Optgroups.lvm2_available () in
   let has_ldm = Optgroups.ldm_available () in
 
+  let ret = ref [] in
+
   (* Devices. *)
   let devices = Devsparts.list_devices () in
   let devices = List.filter is_not_partitioned_device devices in
-  let ret = List.filter_map check_with_vfs_type devices in
+  List.iter (check_with_vfs_type ret) devices;
 
   (* Partitions. *)
   let partitions = Devsparts.list_partitions () in
   let partitions = List.filter is_partition_can_hold_filesystem partitions in
-  let ret = ret @ List.filter_map check_with_vfs_type partitions in
+  List.iter (check_with_vfs_type ret) partitions;
 
   (* MD. *)
   let mds = Md.list_md_devices () in
   let mds = List.filter is_not_partitioned_device mds in
-  let ret = ret @ List.filter_map check_with_vfs_type mds in
+  List.iter (check_with_vfs_type ret) mds;
 
   (* LVM. *)
-  let ret -    if has_lvm2 then (
-      let lvs = Lvm.lvs () in
-      ret @ List.filter_map check_with_vfs_type lvs
-    )
-    else ret in
+  if has_lvm2 then (
+    let lvs = Lvm.lvs () in
+    List.iter (check_with_vfs_type ret) lvs
+  );
 
   (* LDM. *)
-  let ret -    if has_ldm then (
-      let ldmvols = Ldm.list_ldm_volumes () in
-      ret @ List.filter_map check_with_vfs_type ldmvols
-    )
-    else ret in
+  if has_ldm then (
+    let ldmvols = Ldm.list_ldm_volumes () in
+    List.iter (check_with_vfs_type ret) ldmvols
+  );
 
-  List.flatten ret
+  !ret
 
 (* Look to see if device can directly contain filesystem (RHBZ#590167).
  * Partitioned devices cannot contain filesystem, so we will exclude
@@ -120,11 +118,10 @@ and is_mbr_extended parttype device partnum     
Parted.part_get_mbr_part_type device partnum = "extended"
 
 (* Use vfs-type to check for a filesystem of some sort of [device].
- * Returns [Some [device, vfs_type; ...]] if found (there may be
- * multiple devices found in the case of btrfs), else [None] if nothing
- * is found.
+ * Appends (device, vfs_type) to the ret parameter (there may be
+ * multiple devices found in the case of btrfs).
  *)
-and check_with_vfs_type device +and check_with_vfs_type ret device    let
mountable = Mountable.of_device device in
   let vfs_type      try Blkid.vfs_type mountable
@@ -135,18 +132,18 @@ and check_with_vfs_type device         "" in
 
   if vfs_type = "" then
-    Some [mountable, "unknown"]
+    List.push_back ret (mountable, "unknown")
 
   (* Ignore all "*_member" strings.  In libblkid these are returned
    * for things which are members of some RAID or LVM set, most
    * importantly "LVM2_member" which is a PV.
    *)
   else if String.is_suffix vfs_type "_member" then
-    None
+    ()
 
   (* Ignore LUKS-encrypted partitions.  These are also containers, as above. *)
   else if vfs_type = "crypto_LUKS" then
-    None
+    ()
 
   (* A single btrfs device can turn into many volumes. *)
   else if vfs_type = "btrfs" then (
@@ -162,15 +159,18 @@ and check_with_vfs_type device          fun {
Structs.btrfssubvolume_id = id } -> id <> default_volume
       ) vols in
 
-    Some (
-      (mountable, vfs_type) (* whole device = default volume *)
-      :: List.map (
-           fun { Structs.btrfssubvolume_path = path } ->
-             let mountable = Mountable.of_btrfsvol device path in
-             (mountable, "btrfs")
-         ) vols
-      )
+    (* whole device = default volume *)
+    List.push_back ret (mountable, vfs_type);
+
+    (* subvolumes *)
+    List.push_back_list ret (
+      List.map (
+        fun { Structs.btrfssubvolume_path = path } ->
+          let mountable = Mountable.of_btrfsvol device path in
+          (mountable, "btrfs")
+      ) vols
+    )
   )
 
   else
-    Some [mountable, vfs_type]
+    List.push_back ret (mountable, vfs_type)
-- 
2.27.0

---
 daemon/listfs.ml | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/daemon/listfs.ml b/daemon/listfs.ml
index 3b71471ae..a4c917d12 100644
--- a/daemon/listfs.ml
+++ b/daemon/listfs.ml
@@ -141,8 +141,8 @@ and check_with_vfs_type ret device    else if
String.is_suffix vfs_type "_member" then
     ()
 
-  (* Ignore LUKS-encrypted partitions.  These are also containers, as above. *)
-  else if vfs_type = "crypto_LUKS" then
+  (* Ignore encrypted partitions.  These are also containers, as above. *)
+  else if vfs_type = "crypto_LUKS" || vfs_type =
"BitLocker" then
     ()
 
   (* A single btrfs device can turn into many volumes. *)
-- 
2.27.0

Simple refactoring.  The only annoying point is requiring an extra
module because of OCaml module dependency restrictions.
---
 .gitignore                |  1 +
 daemon/Makefile.am        |  3 ++
 daemon/lvm.c              | 76 ---------------------------------------
 daemon/lvm_dm.ml          | 39 ++++++++++++++++++++
 generator/actions_core.ml |  1 +
 5 files changed, 44 insertions(+), 76 deletions(-)

diff --git a/.gitignore b/.gitignore
index 39354de51..71a84fd9d 100644
--- a/.gitignore
+++ b/.gitignore
@@ -164,6 +164,7 @@ Makefile.in
 /daemon/link.mli
 /daemon/listfs.mli
 /daemon/lvm.mli
+/daemon/lvm_dm.mli
 /daemon/lvm-tokenization.c
 /daemon/md.mli
 /daemon/mount.mli
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 480192e1c..038be592c 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -50,6 +50,7 @@ generator_built = \
 	link.mli \
 	listfs.mli \
 	lvm.mli \
+	lvm_dm.mli \
 	md.mli \
 	mount.mli \
 	optgroups.ml \
@@ -289,6 +290,7 @@ SOURCES_MLI = \
 	link.mli \
 	listfs.mli \
 	lvm.mli \
+	lvm_dm.mli \
 	lvm_utils.mli \
 	md.mli \
 	mount.mli \
@@ -321,6 +323,7 @@ SOURCES_ML = \
 	link.ml \
 	lvm.ml \
 	lvm_utils.ml \
+	lvm_dm.ml \
 	findfs.ml \
 	md.ml \
 	mount.ml \
diff --git a/daemon/lvm.c b/daemon/lvm.c
index a78b344db..039240866 100644
--- a/daemon/lvm.c
+++ b/daemon/lvm.c
@@ -764,82 +764,6 @@ do_lvm_canonical_lv_name (const char *device)
   return canonical;             /* caller frees */
 }
 
-/* List everything in /dev/mapper which *isn't* an LV (RHBZ#688062). */
-char **
-do_list_dm_devices (void)
-{
-  CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret);
-  struct dirent *d;
-  DIR *dir;
-  int r;
-
-  dir = opendir ("/dev/mapper");
-  if (!dir) {
-    reply_with_perror ("opendir: /dev/mapper");
-    return NULL;
-  }
-
-  while (1) {
-    CLEANUP_FREE char *devname = NULL;
-
-    errno = 0;
-    d = readdir (dir);
-    if (d == NULL) break;
-
-    /* Ignore . and .. */
-    if (STREQ (d->d_name, ".") || STREQ (d->d_name,
".."))
-      continue;
-
-    /* Ignore /dev/mapper/control which is used internally by dm. */
-    if (STREQ (d->d_name, "control"))
-      continue;
-
-    if (asprintf (&devname, "/dev/mapper/%s", d->d_name) ==
-1) {
-      reply_with_perror ("asprintf");
-      closedir (dir);
-      return NULL;
-    }
-
-    /* Ignore dm devices which are LVs. */
-    r = lv_canonical (devname, NULL);
-    if (r == -1) {
-      closedir (dir);
-      return NULL;
-    }
-    if (r)
-      continue;
-
-    /* Not an LV, so add it. */
-    if (add_string (&ret, devname) == -1) {
-      closedir (dir);
-      return NULL;
-    }
-  }
-
-  /* Did readdir fail? */
-  if (errno != 0) {
-    reply_with_perror ("readdir: /dev/mapper");
-    closedir (dir);
-    return NULL;
-  }
-
-  /* Close the directory handle. */
-  if (closedir (dir) == -1) {
-    reply_with_perror ("closedir: /dev/mapper");
-    return NULL;
-  }
-
-  /* Sort the output (may be empty). */
-  if (ret.size > 0)
-    sort_strings (ret.argv, ret.size);
-
-  /* NULL-terminate the list. */
-  if (end_stringsbuf (&ret) == -1)
-    return NULL;
-
-  return take_stringsbuf (&ret);
-}
-
 char *
 do_vgmeta (const char *vg, size_t *size_r)
 {
diff --git a/daemon/lvm_dm.ml b/daemon/lvm_dm.ml
new file mode 100644
index 000000000..474ba8377
--- /dev/null
+++ b/daemon/lvm_dm.ml
@@ -0,0 +1,39 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2020 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Unix
+open Printf
+
+open Std_utils
+
+open Utils
+
+(* List everything in /dev/mapper which *isn't* an LV (RHBZ#688062). *)
+let list_dm_devices () +  let ds = Sys.readdir "/dev/mapper" in
+  let ds = Array.to_list ds in
+  let ds = List.sort compare ds in
+
+  (* Ignore /dev/mapper/control which is used internally by d-m. *)
+  let ds = List.filter ((<>) "control") ds in
+
+  let ds = List.map ((^) "/dev/mapper/") ds in
+
+  (* Only keep devices which are _not_ LVs. *)
+  let ds = List.filter (fun d -> Lvm_utils.lv_canonical d = None) ds in
+  ds
diff --git a/generator/actions_core.ml b/generator/actions_core.ml
index 54156b2b8..0dec3b86d 100644
--- a/generator/actions_core.ml
+++ b/generator/actions_core.ml
@@ -6180,6 +6180,7 @@ parameter." };
   { defaults with
     name = "list_dm_devices"; added = (1, 11, 15);
     style = RStringList (RDevice, "devices"), [], [];
+    impl = OCaml "Lvm_dm.list_dm_devices";
     shortdesc = "list device mapper devices";
     longdesc = "\
 List all device mapper devices.
-- 
2.27.0

In case any bare filesystems were decrypted using cryptsetup-open,
they would appear as /dev/mapper/name devices.  Since list-filesystems
did not consider those when searching for filesystems, the unencrypted
filesystems would not be returned.

Note that previously this worked for LUKS because the common case
(eg. for Fedora) was that whole devices were encrypted and thoes
devices contained LVs, so luks-open + vgactivate would activate the
LVs which would then be found by list-filesystems.  For Windows
BitLocker, the common case seems to be that each separate NTFS
filesystem is contained in a separate BitLocker wrapper.
---
 daemon/listfs.ml | 13 +++++++++++++
 1 file changed, 13 insertions(+)

diff --git a/daemon/listfs.ml b/daemon/listfs.ml
index a4c917d12..d8add5005 100644
--- a/daemon/listfs.ml
+++ b/daemon/listfs.ml
@@ -35,6 +35,14 @@ let rec list_filesystems ()    let devices = List.filter
is_not_partitioned_device devices in
   List.iter (check_with_vfs_type ret) devices;
 
+  (* Device-mapper devices.
+   * We include these in case any encrypted devices contain
+   * direct filesystems.
+   *)
+  let devices = Lvm_dm.list_dm_devices () in
+  let devices = List.filter is_not_partitioned_device devices in
+  List.iter (check_with_vfs_type ret) devices;
+
   (* Partitions. *)
   let partitions = Devsparts.list_partitions () in
   let partitions = List.filter is_partition_can_hold_filesystem partitions in
@@ -64,6 +72,11 @@ let rec list_filesystems ()   * such devices.
  *)
 and is_not_partitioned_device device +  let device +    if String.is_prefix
device "/dev/mapper/" then
+      Unix_utils.Realpath.realpath device
+    else
+      device in
   assert (String.is_prefix device "/dev/");
   let dev_name = String.sub device 5 (String.length device - 5) in
   let dev_dir = "/sys/block/" ^ dev_name in
-- 
2.27.0

Fixes “XXX” comment.  This turns out to be necessary in order to
suppress a warning when inspecting Windows BitLocker-encrypted guests.

The warning (which still appears in debugging output even with this
patch) is:

  libguestfs: error: lvm_canonical_lv_name: /dev/mapper/cryptsda2: not a logical
volume
---
 lib/canonical-name.c | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/lib/canonical-name.c b/lib/canonical-name.c
index 052bbf12c..11cf6fed6 100644
--- a/lib/canonical-name.c
+++ b/lib/canonical-name.c
@@ -46,8 +46,9 @@ guestfs_impl_canonical_device_name (guestfs_h *g, const char
*device)
   }
   else if (STRPREFIX (device, "/dev/mapper/") ||
            STRPREFIX (device, "/dev/dm-")) {
-    /* XXX hide errors */
+    guestfs_push_error_handler (g, NULL, NULL);
     ret = guestfs_lvm_canonical_lv_name (g, device);
+    guestfs_pop_error_handler (g);
     if (ret == NULL)
       ret = safe_strdup (g, device);
   }
-- 
2.27.0

On Monday, 7 September 2020 11:43:54 CEST Richard W.M. Jones
wrote:
> This commit deprecates luks-open/luks-open-ro/luks-close for the more
> generic sounding names cryptsetup-open/cryptsetup-close, which also
> correspond directly to the cryptsetup commands.
> 
> The optional cryptsetup-open readonly flag is used to replace the
> functionality of luks-open-ro.
> 
> The optional cryptsetup-open crypttype parameter can be used to select
> the type (corresponding to cryptsetup open --type), which allows us to
> open BitLocker-encrypted disks with no extra effort.  As a convenience
> the crypttype parameter may be omitted, and libguestfs will use a
> heuristic (based on vfs-type output) to try to determine the correct
> type to use.
At least in my (non extensive) tests with cryptsetup, it seems it can
detect the right format even without --type=format or the luksOpen/etc
aliases.

What I'd do is:
- drop the autodetection: it is a mild duplication of what cryptsetup
  already does, and adding it in the API now means that it will be
  stuck there...
- maybe (need to think about it) make the crypttype parameter mandatory,
  so the user has to select the right format
> The deprecated functions and the new functions are all (re-)written in
> OCaml.
Regarding the deprecated functions: wouldn't it be better to have them
in the library, rather than in the daemon? The machinery needed in the
library is more or less than same anyway, and this way we can remove
two RPCs in the daemon.

Also, please bump the versions of the new APIs.
> +let cryptsetup_open ?(readonly = false) ?crypttype device key mapname >
+  (* /dev/mapper/mapname must not exist already. *)
  /* Sanity check: /dev/mapper/mapname must not exist already.  Note
   * that the device-mapper control device (/dev/mapper/control) is
   * always there, so you can't ever have mapname == "control".
   */

This whole comment seems useful, it would be a pity to lose it in the
conversion. Also, unrelated to this patch: IMHO it would be a good idea
to explicitly note this limitation in the API docs.
> +  (* Write the key to a temporary file. *)
> +  let keyfile, chan = Filename.open_temp_file "crypt"
".key" in
> +  fchmod (descr_of_out_channel chan) 0o600;
This fchmod is not needed, as temporary files are already 600 by
default.
> +  (* Make sure we always remove the temporary file. *)
> +  protect ~f:(
> +    fun () ->
> +      let args = ref [] in
> +      List.push_back_list args ["-d"; keyfile];
> +      if readonly then List.push_back args "--readonly";
> +      List.push_back_list args ["open"; device; mapname;
"--type"; crypttype];
Minor nit: even if this way makes sense more from a scope POV, I'd
instead build the args list out of the protect. Mostly for ease of
reading.
> +(* Deprecated APIs for backwards compatibility.
> + *
> + * For convenient for existing callers we do not specify the
> + * crypttype parameter.  This means that callers of these APIs
> + * will be able to open BitLocker drives transparently.  (If
> + * we wanted to be strict we would pass ~crypttype:"luks"
> + * here, but that seems to have only downsides).
I disagree here: if an user uses the luks_open API, IMHO they expect it
to be LUKS; if they want to use other types, then they want to switch
to the new cryptsetup_open. So I'd pass ~crypttype:"luks" in
luks_open.
> +  { defaults with
> +    name = "cryptsetup_open"; added = (1, 43, 1);
> +    style = RErr, [String (Device, "device"); String (Key,
"key"); String (PlainString, "mapname")], [OBool
"readonly"; OString "crypttype"];
> +    impl = OCaml "Cryptsetup.cryptsetup_open";
> +    optional = Some "luks";
> +    test_excuse = "no way to format BitLocker, and smallest device is
huge";
> +    shortdesc = "open an encrypted block device";
> +    longdesc = "\
> +This command opens a block device which has been encrypted
> +according to the Linux Unified Key Setup (LUKS) standard,
> +Windows BitLocker, or some other types.
> +
> +C<device> is the encrypted block device or partition.
> +
> +The caller must supply one of the keys associated with the
> +encrypted block device, in the C<key> parameter.
> +
> +This creates a new block device called F</dev/mapper/mapname>.
> +Reads and writes to this block device are decrypted from and
> +encrypted to the underlying C<device> respectively.
> +
> +If the optional C<crypttype> parameter is not present then
> +libguestfs tries to guess the correct type (for example
> +LUKS or BitLocker).  However you can override this by
> +specifying one of the following types:
> +
> +=over 4
> +
> +=item C<luks>
> +
> +A Linux LUKS device.
> +
> +=item C<bitlk>
> +
> +A Windows BitLocker device.
> +
> +=back
Maybe add:

  Please refer to the L<cryptsetup(8)> documentation for all the
  supported types.

-- 
Pino Toscano

On Monday, 7 September 2020 11:44:00 CEST Richard W.M. Jones
wrote:
> Fixes “XXX” comment.  This turns out to be necessary in order to
> suppress a warning when inspecting Windows BitLocker-encrypted guests.
> 
> The warning (which still appears in debugging output even with this
> patch) is:
> 
>   libguestfs: error: lvm_canonical_lv_name: /dev/mapper/cryptsda2: not a
logical volume
> ---
>  lib/canonical-name.c | 3 ++-
>  1 file changed, 2 insertions(+), 1 deletion(-)
> 
> diff --git a/lib/canonical-name.c b/lib/canonical-name.c
> index 052bbf12c..11cf6fed6 100644
> --- a/lib/canonical-name.c
> +++ b/lib/canonical-name.c
> @@ -46,8 +46,9 @@ guestfs_impl_canonical_device_name (guestfs_h *g, const
char *device)
>    }
>    else if (STRPREFIX (device, "/dev/mapper/") ||
>             STRPREFIX (device, "/dev/dm-")) {
> -    /* XXX hide errors */
> +    guestfs_push_error_handler (g, NULL, NULL);
>      ret = guestfs_lvm_canonical_lv_name (g, device);
> +    guestfs_pop_error_handler (g);
Instead of ignoring all the errors from lvm_canonical_lv_name, isn't
there a way to avoid getting into this situation in the first place?
Right now it is not ignored, so if anything fails we can immediately
notice it, which won't happen anymore with the proposed change.

-- 
Pino Toscano