[Libguestfs] [PATCH 18/27] daemon: Reimplement ‘btrfs_subvolume_list’ and ‘btrfs_subvolume_get_default’ in OCaml.

[Pino Toscano]

On Friday, 14 July 2017 15:39:26 CEST Richard W.M. Jones wrote:
> +(* In order to examine subvolumes, quota and other things, the btrfs
> + * filesystem has to be mounted.  However we're passed a mountable
> + * in these cases, so we must mount the filesystem.  But we cannot
> + * mount it under the sysroot, as something else might be mounted
> + * there so this function mounts the filesystem on a temporary
> + * directory and ensures it is always unmounted afterwards.
> + *)
> +let with_mounted mountable f =
> +  let tmpdir = sprintf "/tmp/%s" (String.random8 ()) in

  let tmpdir = Mkdtemp.temp_dir ~base_dir:"/tmp" "btrfs." "" in

(or even without ~base_dir, I guess the default should be fine.)
This will also avoid the mkdir calls later on.

> +  (* This is the cleanup function which is called to unmount and
> +   * remove the temporary directory.  This is called on error and
> +   * ordinary exit paths.
> +   *)
> +  let finally () =
> +    ignore (Sys.command (sprintf "umount %s" (quote tmpdir)));
> +    rmdir tmpdir
> +  in
> +
> +  match mountable.m_type with
> +  | MountablePath ->
> +     (* This corner-case happens for Mountable_or_Path parameters, where
> +      * a path was supplied by the caller.  The path (the m_device
> +      * field) is relative to the sysroot.
> +      *)
> +     f (Sysroot.sysroot () // mountable.m_device)

After using Mkdtemp.temp_dir above, "rmdir tmpdir" will be needed here.

> +
> +  | MountableDevice ->
> +     protect ~finally ~f:(
> +       fun () ->
> +         mkdir tmpdir 0o700;
> +         ignore (command "mount" [mountable.m_device; tmpdir]);
> +         f tmpdir
> +     )
> +
> +  | MountableBtrfsVol subvol ->
> +     protect ~finally ~f:(
> +       fun () ->
> +         mkdir tmpdir 0o700;
> +         ignore (command "mount" ["-o"; "subvol=" ^ subvol (* XXX quoting? *);
> +                                  mountable.m_device; tmpdir]);
> +         f tmpdir
> +     )
> +
> +let re_btrfs_subvolume_list =
> +  Str.regexp ("ID[ \t]+\\([0-9]+\\).*[ \t]" ^
> +              "top level[ \t]+\\([0-9]+\\).*[ \t]" ^
> +              "path[ \t]+\\(.*\\)")

Sigh, Str does not support simple character classes like \s :( No wonder
there are at least two or three "re" OCaml modules providing sane regular
expression engines (with a less awkward syntax for captures, etc).

> +let btrfs_subvolume_list mountable =
> +  (* Execute 'btrfs subvolume list <fs>', and split the output into lines *)
> +  let lines =
> +    with_mounted mountable (
> +      fun mp -> command "btrfs" ["subvolume"; "list"; mp]
> +    ) in
> +  let lines = String.nsplit "\n" lines in

If here we do:

  let lines = List.filter ((<>) "") lines in

then later on we can use List.map instead of filter_map.

> diff --git a/daemon/btrfs.mli b/daemon/btrfs.mli
> new file mode 100644
> index 000000000..55a38e42d
> --- /dev/null
> +++ b/daemon/btrfs.mli
> @@ -0,0 +1,26 @@
> +(* guestfs-inspection
> + * Copyright (C) 2009-2017 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.
> + *)
> +
> +type btrfssubvolume = {
> +  btrfssubvolume_id : int64;
> +  btrfssubvolume_top_level_id : int64;
> +  btrfssubvolume_path : string;
> +}

Is this needed? Could Structs.btrfssubvolume be used below?

-- 
Pino Toscano
-------------- next part --------------
A non-text attachment was scrubbed...
Name: signature.asc
Type: application/pgp-signature
Size: 819 bytes
Desc: This is a digitally signed message part.
URL: <http://listman.redhat.com/archives/libguestfs/attachments/20170720/7b2dec1a/attachment.sig>