No need to redeclare them again in few modules, just use them from the Structs module. --- daemon/btrfs.mli | 8 +------- daemon/inspect_fs_windows.ml | 4 ++-- daemon/listfs.ml | 4 ++-- daemon/parted.mli | 9 +-------- daemon/statvfs.mli | 16 +--------------- 5 files changed, 7 insertions(+), 34 deletions(-) diff --git a/daemon/btrfs.mli b/daemon/btrfs.mli index 8ca91fb47..ce1c2b66f 100644 --- a/daemon/btrfs.mli +++ b/daemon/btrfs.mli @@ -16,11 +16,5 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -type btrfssubvolume = { - btrfssubvolume_id : int64; - btrfssubvolume_top_level_id : int64; - btrfssubvolume_path : string; -} - -val btrfs_subvolume_list : Mountable.t -> btrfssubvolume list +val btrfs_subvolume_list : Mountable.t -> Structs.btrfssubvolume list val btrfs_subvolume_get_default : Mountable.t -> int64 diff --git a/daemon/inspect_fs_windows.ml b/daemon/inspect_fs_windows.ml index e9d056cd9..8b2aad8d3 100644 --- a/daemon/inspect_fs_windows.ml +++ b/daemon/inspect_fs_windows.ml @@ -372,10 +372,10 @@ and map_registry_disk_blob devices blob = let offset = int_of_le64 offset in let partitions = Parted.part_list device in let partition = - List.find (fun { Parted.part_start = s } -> s = offset) partitions in + List.find (fun { Structs.part_start = s } -> s = offset) partitions in (* Construct the full device name. *) - Some (sprintf "%s%ld" device partition.Parted.part_num) + Some (sprintf "%s%ld" device partition.Structs.part_num) with | Not_found -> None diff --git a/daemon/listfs.ml b/daemon/listfs.ml index f6e3dcd6e..56ebadeda 100644 --- a/daemon/listfs.ml +++ b/daemon/listfs.ml @@ -125,13 +125,13 @@ and check_with_vfs_type device = let default_volume = Btrfs.btrfs_subvolume_get_default mountable in let vols = List.filter ( - fun { Btrfs.btrfssubvolume_id = id } -> id <> default_volume + fun { Structs.btrfssubvolume_id = id } -> id <> default_volume ) vols in Some ( (mountable, vfs_type) (* whole device = default volume *) :: List.map ( - fun { Btrfs.btrfssubvolume_path = path } -> + fun { Structs.btrfssubvolume_path = path } -> let mountable = Mountable.of_btrfsvol device path in (mountable, "btrfs") ) vols diff --git a/daemon/parted.mli b/daemon/parted.mli index d547f2f2a..0b7eb87f4 100644 --- a/daemon/parted.mli +++ b/daemon/parted.mli @@ -16,15 +16,8 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -type partition = { - part_num : int32; - part_start : int64; - part_end : int64; - part_size : int64; -} - val part_get_mbr_id : string -> int -> int -val part_list : string -> partition list +val part_list : string -> Structs.partition list val part_get_parttype : string -> string diff --git a/daemon/statvfs.mli b/daemon/statvfs.mli index d241f995b..13b22f88d 100644 --- a/daemon/statvfs.mli +++ b/daemon/statvfs.mli @@ -16,18 +16,4 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -type statvfs = { - bsize : int64; - frsize : int64; - blocks : int64; - bfree : int64; - bavail : int64; - files : int64; - ffree : int64; - favail : int64; - fsid : int64; - flag : int64; - namemax : int64; -} - -val statvfs : string -> statvfs +val statvfs : string -> Structs.statvfs -- 2.14.3

This way the Lvm module contains only the OCaml implementations of LVM daemon APIs. This is simple refactoring, with no functional changes. --- daemon/Makefile.am | 2 ++ daemon/findfs.ml | 2 +- daemon/inspect_fs_unix_fstab.ml | 2 +- daemon/lvm.ml | 27 ----------------------- daemon/lvm.mli | 10 --------- daemon/lvm_utils.ml | 48 +++++++++++++++++++++++++++++++++++++++++ daemon/lvm_utils.mli | 27 +++++++++++++++++++++++ 7 files changed, 79 insertions(+), 39 deletions(-) create mode 100644 daemon/lvm_utils.ml create mode 100644 daemon/lvm_utils.mli diff --git a/daemon/Makefile.am b/daemon/Makefile.am index 9dbd375f5..9cd34ff75 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -268,6 +268,7 @@ SOURCES_MLI = \ link.mli \ listfs.mli \ lvm.mli \ + lvm_utils.mli \ md.mli \ mount.mli \ mountable.mli \ @@ -296,6 +297,7 @@ SOURCES_ML = \ ldm.ml \ link.ml \ lvm.ml \ + lvm_utils.ml \ findfs.ml \ md.ml \ mount.ml \ diff --git a/daemon/findfs.ml b/daemon/findfs.ml index f613015f0..c24a194e3 100644 --- a/daemon/findfs.ml +++ b/daemon/findfs.ml @@ -44,7 +44,7 @@ and findfs tag str = if String.is_prefix out "/dev/mapper/" || String.is_prefix out "/dev/dm-" then ( - match Lvm.lv_canonical out with + match Lvm_utils.lv_canonical out with | None -> (* Ignore the case where 'out' doesn't appear to be an LV. * The best we can do is return the original as-is. diff --git a/daemon/inspect_fs_unix_fstab.ml b/daemon/inspect_fs_unix_fstab.ml index 43cec2323..edb797e3f 100644 --- a/daemon/inspect_fs_unix_fstab.ml +++ b/daemon/inspect_fs_unix_fstab.ml @@ -327,7 +327,7 @@ and resolve_fstab_device spec md_map os_type = * we have implemented lvm_canonical_lv_name in the daemon. *) try - match Lvm.lv_canonical spec with + match Lvm_utils.lv_canonical spec with | None -> Mountable.of_device spec | Some device -> Mountable.of_device device with diff --git a/daemon/lvm.ml b/daemon/lvm.ml index ed4ed7462..ef45ed4bc 100644 --- a/daemon/lvm.ml +++ b/daemon/lvm.ml @@ -97,30 +97,3 @@ and filter_convert_old_lvs_output out = ) lines in List.sort compare lines - -(* Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0 - * to a canonical one. - * - * This is harder than it should be. A LV device like /dev/VG/LV is - * really a symlink to a device-mapper device like /dev/dm-0. However - * at the device-mapper (kernel) level, nothing is really known about - * LVM (a userspace concept). Therefore we use a convoluted method to - * determine this, by listing out known LVs and checking whether the - * rdev (major/minor) of the device we are passed matches any of them. - * - * Note use of 'stat' instead of 'lstat' so that symlinks are fully - * resolved. - *) -let lv_canonical device = - let stat1 = stat device in - let lvs = lvs () in - try - Some ( - List.find ( - fun lv -> - let stat2 = stat lv in - stat1.st_rdev = stat2.st_rdev - ) lvs - ) - with - | Not_found -> None diff --git a/daemon/lvm.mli b/daemon/lvm.mli index e9a6faeca..592168433 100644 --- a/daemon/lvm.mli +++ b/daemon/lvm.mli @@ -17,13 +17,3 @@ *) val lvs : unit -> string list - -val lv_canonical : string -> string option -(** Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0 - to a canonical one. - - On error this raises an exception. There are two possible non-error - return cases: - - Some lv = conversion was successful, returning the canonical LV - None = input path was not an LV, it could not be made canonical *) diff --git a/daemon/lvm_utils.ml b/daemon/lvm_utils.ml new file mode 100644 index 000000000..a891193df --- /dev/null +++ b/daemon/lvm_utils.ml @@ -0,0 +1,48 @@ +(* guestfs-inspection + * Copyright (C) 2009-2018 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 Utils + +(* Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0 + * to a canonical one. + * + * This is harder than it should be. A LV device like /dev/VG/LV is + * really a symlink to a device-mapper device like /dev/dm-0. However + * at the device-mapper (kernel) level, nothing is really known about + * LVM (a userspace concept). Therefore we use a convoluted method to + * determine this, by listing out known LVs and checking whether the + * rdev (major/minor) of the device we are passed matches any of them. + * + * Note use of 'stat' instead of 'lstat' so that symlinks are fully + * resolved. + *) +let lv_canonical device = + let stat1 = stat device in + let lvs = Lvm.lvs () in + try + Some ( + List.find ( + fun lv -> + let stat2 = stat lv in + stat1.st_rdev = stat2.st_rdev + ) lvs + ) + with + | Not_found -> None diff --git a/daemon/lvm_utils.mli b/daemon/lvm_utils.mli new file mode 100644 index 000000000..b25a9a706 --- /dev/null +++ b/daemon/lvm_utils.mli @@ -0,0 +1,27 @@ +(* guestfs-inspection + * Copyright (C) 2009-2018 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. + *) + +val lv_canonical : string -> string option +(** Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0 + to a canonical one. + + On error this raises an exception. There are two possible non-error + return cases: + + Some lv = conversion was successful, returning the canonical LV + None = input path was not an LV, it could not be made canonical *) -- 2.14.3

This way the Mount module contains only the OCaml implementations of mount-related daemon APIs. This is simple refactoring, with no functional changes. --- daemon/Makefile.am | 2 ++ daemon/inspect.ml | 2 +- daemon/inspect_fs.ml | 2 +- daemon/mount.ml | 61 ------------------------------------- daemon/mount.mli | 2 -- daemon/mount_utils.ml | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++ daemon/mount_utils.mli | 19 ++++++++++++ 7 files changed, 106 insertions(+), 65 deletions(-) create mode 100644 daemon/mount_utils.ml create mode 100644 daemon/mount_utils.mli diff --git a/daemon/Makefile.am b/daemon/Makefile.am index 9cd34ff75..31eec4d33 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -271,6 +271,7 @@ SOURCES_MLI = \ lvm_utils.mli \ md.mli \ mount.mli \ + mount_utils.mli \ mountable.mli \ optgroups.mli \ parted.mli \ @@ -301,6 +302,7 @@ SOURCES_ML = \ findfs.ml \ md.ml \ mount.ml \ + mount_utils.ml \ parted.ml \ listfs.ml \ realpath.ml \ diff --git a/daemon/inspect.ml b/daemon/inspect.ml index 6d4b17815..ce62c17f2 100644 --- a/daemon/inspect.ml +++ b/daemon/inspect.ml @@ -27,7 +27,7 @@ open Inspect_types let re_primary_partition = PCRE.compile "^/dev/(?:h|s|v)d.[1234]$" let rec inspect_os () = - Mount.umount_all (); + Mount_utils.umount_all (); (* Iterate over all detected filesystems. Inspect each one in turn. *) let fses = Listfs.list_filesystems () in diff --git a/daemon/inspect_fs.ml b/daemon/inspect_fs.ml index 02e2060b9..da98946af 100644 --- a/daemon/inspect_fs.ml +++ b/daemon/inspect_fs.ml @@ -55,7 +55,7 @@ let rec check_for_filesystem_on mountable vfs_type = if not mounted then None else ( let role = check_filesystem mountable in - Mount.umount_all (); + Mount_utils.umount_all (); role ) ) in diff --git a/daemon/mount.ml b/daemon/mount.ml index e42ea1580..4fe85d3b6 100644 --- a/daemon/mount.ml +++ b/daemon/mount.ml @@ -60,64 +60,3 @@ let mount_vfs options vfs mountable mountpoint = let mount = mount_vfs "" "" let mount_ro = mount_vfs "ro" "" let mount_options options = mount_vfs options "" - -(* Unmount everything mounted under /sysroot. - * - * We have to unmount in the correct order, so we sort the paths by - * longest first to ensure that child paths are unmounted by parent - * paths. - * - * This call is more important than it appears at first, because it - * is widely used by both test and production code in order to - * get back to a known state (nothing mounted, everything synchronized). - *) -let rec umount_all () = - (* This is called from internal_autosync and generally as a cleanup - * function, and since the umount will definitely fail if any - * handles are open, we may as well close them. - *) - (* XXX - aug_finalize (); - hivex_finalize (); - journal_finalize (); - *) - - let sysroot = Sysroot.sysroot () in - let sysroot_len = String.length sysroot in - - let info = read_whole_file "/proc/self/mountinfo" in - let info = String.nsplit "\n" info in - - let mps = ref [] in - List.iter ( - fun line -> - let line = String.nsplit " " line in - (* The field of interest is the 5th field. Whitespace is escaped - * with octal sequences like \040 (for space). - * See fs/seq_file.c:mangle_path. - *) - if List.length line >= 5 then ( - let mp = List.nth line 4 in - let mp = proc_unmangle_path mp in - - (* Allow a mount directory like "/sysroot" or "/sysroot/..." *) - if (sysroot_len > 0 && String.is_prefix mp sysroot) || - (String.is_prefix mp sysroot && - String.length mp > sysroot_len && - mp.[sysroot_len] = '/') then - List.push_front mp mps - ) - ) info; - - let mps = !mps in - let mps = List.sort compare_longest_first mps in - - (* Unmount them. *) - List.iter ( - fun mp -> ignore (command "umount" [mp]) - ) mps - -and compare_longest_first s1 s2 = - let n1 = String.length s1 in - let n2 = String.length s2 in - n2 - n1 diff --git a/daemon/mount.mli b/daemon/mount.mli index 96c400190..9fa5b76e7 100644 --- a/daemon/mount.mli +++ b/daemon/mount.mli @@ -20,5 +20,3 @@ val mount : Mountable.t -> string -> unit val mount_ro : Mountable.t -> string -> unit val mount_options : string -> Mountable.t -> string -> unit val mount_vfs : string -> string -> Mountable.t -> string -> unit - -val umount_all : unit -> unit diff --git a/daemon/mount_utils.ml b/daemon/mount_utils.ml new file mode 100644 index 000000000..a53959de3 --- /dev/null +++ b/daemon/mount_utils.ml @@ -0,0 +1,83 @@ +(* guestfs-inspection + * Copyright (C) 2009-2018 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 Std_utils + +open Mountable +open Utils + +(* Unmount everything mounted under /sysroot. + * + * We have to unmount in the correct order, so we sort the paths by + * longest first to ensure that child paths are unmounted by parent + * paths. + * + * This call is more important than it appears at first, because it + * is widely used by both test and production code in order to + * get back to a known state (nothing mounted, everything synchronized). + *) +let rec umount_all () = + (* This is called from internal_autosync and generally as a cleanup + * function, and since the umount will definitely fail if any + * handles are open, we may as well close them. + *) + (* XXX + aug_finalize (); + hivex_finalize (); + journal_finalize (); + *) + + let sysroot = Sysroot.sysroot () in + let sysroot_len = String.length sysroot in + + let info = read_whole_file "/proc/self/mountinfo" in + let info = String.nsplit "\n" info in + + let mps = ref [] in + List.iter ( + fun line -> + let line = String.nsplit " " line in + (* The field of interest is the 5th field. Whitespace is escaped + * with octal sequences like \040 (for space). + * See fs/seq_file.c:mangle_path. + *) + if List.length line >= 5 then ( + let mp = List.nth line 4 in + let mp = proc_unmangle_path mp in + + (* Allow a mount directory like "/sysroot" or "/sysroot/..." *) + if (sysroot_len > 0 && String.is_prefix mp sysroot) || + (String.is_prefix mp sysroot && + String.length mp > sysroot_len && + mp.[sysroot_len] = '/') then + List.push_front mp mps + ) + ) info; + + let mps = !mps in + let mps = List.sort compare_longest_first mps in + + (* Unmount them. *) + List.iter ( + fun mp -> ignore (command "umount" [mp]) + ) mps + +and compare_longest_first s1 s2 = + let n1 = String.length s1 in + let n2 = String.length s2 in + n2 - n1 diff --git a/daemon/mount_utils.mli b/daemon/mount_utils.mli new file mode 100644 index 000000000..72421adfa --- /dev/null +++ b/daemon/mount_utils.mli @@ -0,0 +1,19 @@ +(* guestfs-inspection + * Copyright (C) 2009-2018 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. + *) + +val umount_all : unit -> unit -- 2.14.3

Add a way to generate OCaml interfaces for all the modules in the daemon that implement APIs: this makes sure that for them the interface of each function matches the actual API specified in the generator. --- .gitignore | 17 +++++++++++ daemon/blkid.mli | 19 ------------ daemon/btrfs.mli | 20 ------------- daemon/devsparts.mli | 25 ---------------- daemon/file.mli | 19 ------------ daemon/filearch.mli | 19 ------------ daemon/findfs.mli | 20 ------------- daemon/inspect.mli | 41 -------------------------- daemon/is.mli | 21 ------------- daemon/ldm.mli | 20 ------------- daemon/link.mli | 19 ------------ daemon/listfs.mli | 19 ------------ daemon/lvm.mli | 19 ------------ daemon/md.mli | 20 ------------- daemon/mount.mli | 22 -------------- daemon/parted.mli | 27 ----------------- daemon/realpath.mli | 20 ------------- daemon/statvfs.mli | 19 ------------ generator/daemon.ml | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++++ generator/daemon.mli | 1 + generator/main.ml | 17 +++++++++++ 21 files changed, 118 insertions(+), 369 deletions(-) delete mode 100644 daemon/blkid.mli delete mode 100644 daemon/btrfs.mli delete mode 100644 daemon/devsparts.mli delete mode 100644 daemon/file.mli delete mode 100644 daemon/filearch.mli delete mode 100644 daemon/findfs.mli delete mode 100644 daemon/inspect.mli delete mode 100644 daemon/is.mli delete mode 100644 daemon/ldm.mli delete mode 100644 daemon/link.mli delete mode 100644 daemon/listfs.mli delete mode 100644 daemon/lvm.mli delete mode 100644 daemon/md.mli delete mode 100644 daemon/mount.mli delete mode 100644 daemon/parted.mli delete mode 100644 daemon/realpath.mli delete mode 100644 daemon/statvfs.mli diff --git a/.gitignore b/.gitignore index bb7026537..e67013478 100644 --- a/.gitignore +++ b/.gitignore @@ -185,21 +185,38 @@ Makefile.in /customize/virt-customize.1 /daemon/.depend /daemon/actions.h +/daemon/blkid.mli +/daemon/btrfs.mli /daemon/callbacks.ml /daemon/caml-stubs.c /daemon/daemon_config.ml /daemon/daemon_utils_tests +/daemon/devsparts.mli /daemon/dispatch.c +/daemon/file.mli +/daemon/filearch.mli +/daemon/findfs.mli /daemon/guestfsd /daemon/guestfsd.8 /daemon/guestfsd.exe +/daemon/inspect.mli +/daemon/is.mli +/daemon/ldm.mli +/daemon/link.mli +/daemon/listfs.mli +/daemon/lvm.mli /daemon/lvm-tokenization.c +/daemon/md.mli +/daemon/mount.mli /daemon/names.c /daemon/optgroups.c /daemon/optgroups.h /daemon/optgroups.ml /daemon/optgroups.mli +/daemon/parted.mli +/daemon/realpath.mli /daemon/stamp-guestfsd.pod +/daemon/statvfs.mli /daemon/structs-cleanups.c /daemon/structs-cleanups.h /daemon/structs.ml diff --git a/daemon/blkid.mli b/daemon/blkid.mli deleted file mode 100644 index 65a61def4..000000000 --- a/daemon/blkid.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val vfs_type : Mountable.t -> string diff --git a/daemon/btrfs.mli b/daemon/btrfs.mli deleted file mode 100644 index ce1c2b66f..000000000 --- a/daemon/btrfs.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val btrfs_subvolume_list : Mountable.t -> Structs.btrfssubvolume list -val btrfs_subvolume_get_default : Mountable.t -> int64 diff --git a/daemon/devsparts.mli b/daemon/devsparts.mli deleted file mode 100644 index 7b669c269..000000000 --- a/daemon/devsparts.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val list_devices : unit -> string list -val list_partitions : unit -> string list -val part_to_dev : string -> string -val part_to_partnum : string -> int -val is_whole_device : string -> bool -val nr_devices : unit -> int -val device_index : string -> int diff --git a/daemon/file.mli b/daemon/file.mli deleted file mode 100644 index 1e1631840..000000000 --- a/daemon/file.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val file : string -> string diff --git a/daemon/filearch.mli b/daemon/filearch.mli deleted file mode 100644 index 3f472af51..000000000 --- a/daemon/filearch.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val file_architecture : string -> string diff --git a/daemon/findfs.mli b/daemon/findfs.mli deleted file mode 100644 index c671782c3..000000000 --- a/daemon/findfs.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val findfs_uuid : string -> string -val findfs_label : string -> string diff --git a/daemon/inspect.mli b/daemon/inspect.mli deleted file mode 100644 index 336bbcfae..000000000 --- a/daemon/inspect.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val inspect_os : unit -> Mountable.t list -val inspect_get_roots : unit -> Mountable.t list -val inspect_get_mountpoints : Mountable.t -> (string * Mountable.t) list -val inspect_get_filesystems : Mountable.t -> Mountable.t list -val inspect_get_format : Mountable.t -> string -val inspect_get_type : Mountable.t -> string -val inspect_get_distro : Mountable.t -> string -val inspect_get_package_format : Mountable.t -> string -val inspect_get_package_management : Mountable.t -> string -val inspect_get_product_name : Mountable.t -> string -val inspect_get_product_variant : Mountable.t -> string -val inspect_get_major_version : Mountable.t -> int -val inspect_get_minor_version : Mountable.t -> int -val inspect_get_arch : Mountable.t -> string -val inspect_get_hostname : Mountable.t -> string -val inspect_get_windows_systemroot : Mountable.t -> string -val inspect_get_windows_software_hive : Mountable.t -> string -val inspect_get_windows_system_hive : Mountable.t -> string -val inspect_get_windows_current_control_set : Mountable.t -> string -val inspect_get_drive_mappings : Mountable.t -> (string * string) list -val inspect_is_live : Mountable.t -> bool -val inspect_is_netinst : Mountable.t -> bool -val inspect_is_multipart : Mountable.t -> bool diff --git a/daemon/is.mli b/daemon/is.mli deleted file mode 100644 index f64d33dae..000000000 --- a/daemon/is.mli +++ /dev/null @@ -1,21 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val is_file : ?followsymlinks:bool -> string -> bool -val is_dir : ?followsymlinks:bool -> string -> bool -val is_symlink : string -> bool diff --git a/daemon/ldm.mli b/daemon/ldm.mli deleted file mode 100644 index 74afdf5d8..000000000 --- a/daemon/ldm.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val list_ldm_volumes : unit -> string list -val list_ldm_partitions : unit -> string list diff --git a/daemon/link.mli b/daemon/link.mli deleted file mode 100644 index f3c6d1564..000000000 --- a/daemon/link.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val readlink : string -> string diff --git a/daemon/listfs.mli b/daemon/listfs.mli deleted file mode 100644 index 0e8f24080..000000000 --- a/daemon/listfs.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val list_filesystems : unit -> (Mountable.t * string) list diff --git a/daemon/lvm.mli b/daemon/lvm.mli deleted file mode 100644 index 592168433..000000000 --- a/daemon/lvm.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val lvs : unit -> string list diff --git a/daemon/md.mli b/daemon/md.mli deleted file mode 100644 index e0c3e08ad..000000000 --- a/daemon/md.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val list_md_devices : unit -> string list -val md_detail : string -> (string * string) list diff --git a/daemon/mount.mli b/daemon/mount.mli deleted file mode 100644 index 9fa5b76e7..000000000 --- a/daemon/mount.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val mount : Mountable.t -> string -> unit -val mount_ro : Mountable.t -> string -> unit -val mount_options : string -> Mountable.t -> string -> unit -val mount_vfs : string -> string -> Mountable.t -> string -> unit diff --git a/daemon/parted.mli b/daemon/parted.mli deleted file mode 100644 index 0b7eb87f4..000000000 --- a/daemon/parted.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val part_get_mbr_id : string -> int -> int -val part_list : string -> Structs.partition list - -val part_get_parttype : string -> string - -val part_get_gpt_type : string -> int -> string -val part_get_gpt_guid : string -> int -> string -val part_get_gpt_attributes : string -> int -> int64 -val part_set_gpt_attributes : string -> int -> int64 -> unit diff --git a/daemon/realpath.mli b/daemon/realpath.mli deleted file mode 100644 index 10b9ae565..000000000 --- a/daemon/realpath.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val realpath : string -> string -val case_sensitive_path : string -> string diff --git a/daemon/statvfs.mli b/daemon/statvfs.mli deleted file mode 100644 index 13b22f88d..000000000 --- a/daemon/statvfs.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* guestfs-inspection - * Copyright (C) 2009-2018 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. - *) - -val statvfs : string -> Structs.statvfs diff --git a/generator/daemon.ml b/generator/daemon.ml index 7fb7052a0..559ed6898 100644 --- a/generator/daemon.ml +++ b/generator/daemon.ml @@ -490,6 +490,89 @@ let generate_daemon_caml_callbacks_ml () = else pr "let init_callbacks () = ()\n" +let rec generate_daemon_caml_interface modname () = + generate_header OCamlStyle GPLv2plus; + + let is_ocaml_module_function = function + | { impl = OCaml m } when String.is_prefix m (modname ^ ".") -> true + | { impl = OCaml _ } -> false + | { impl = C } -> false + in + + let ocaml_actions = actions |> (List.filter is_ocaml_module_function) in + if ocaml_actions == [] then + failwithf "no OCaml implementations for module %s" modname; + + let prefix_length = String.length modname + 1 in + List.iter ( + fun { name; style; impl } -> + let ocaml_function = + match impl with + | OCaml f -> + String.sub f prefix_length (String.length f - prefix_length) + | C -> assert false in + + generate_ocaml_daemon_prototype ocaml_function style + ) ocaml_actions + +and generate_ocaml_daemon_prototype name (ret, args, optargs) = + let type_for_stringt = function + | Mountable + | Mountable_or_Path -> "Mountable.t" + | PlainString + | Device + | Pathname + | FileIn + | FileOut + | Key + | GUID + | Filename + | Dev_or_Path -> "string" + in + let type_for_rstringt = function + | RMountable -> "Mountable.t" + | RPlainString + | RDevice -> "string" + in + pr "val %s : " name; + List.iter ( + function + | OBool n -> pr "?%s:bool -> " n + | OInt n -> pr "?%s:int -> " n + | OInt64 n -> pr "?%s:int64 -> " n + | OString n -> pr "?%s:string -> " n + | OStringList n -> pr "?%s:string array -> " n + ) optargs; + if args <> [] then + List.iter ( + function + | String (typ, _) -> pr "%s -> " (type_for_stringt typ) + | BufferIn _ -> pr "string -> " + | OptString _ -> pr "string option -> " + | StringList (typ, _) -> pr "%s array -> " (type_for_stringt typ) + | Bool _ -> pr "bool -> " + | Int _ -> pr "int -> " + | Int64 _ | Pointer _ -> pr "int64 -> " + ) args + else + pr "unit -> "; + (match ret with + | RErr -> pr "unit" (* all errors are turned into exceptions *) + | RInt _ -> pr "int" + | RInt64 _ -> pr "int64" + | RBool _ -> pr "bool" + | RConstString _ -> pr "string" + | RConstOptString _ -> pr "string option" + | RString (typ, _) -> pr "%s" (type_for_rstringt typ) + | RBufferOut _ -> pr "string" + | RStringList (typ, _) -> pr "%s list" (type_for_rstringt typ) + | RStruct (_, typ) -> pr "Structs.%s" typ + | RStructList (_, typ) -> pr "Structs.%s list" typ + | RHashtable (typea, typeb, _) -> + pr "(%s * %s) list" (type_for_rstringt typea) (type_for_rstringt typeb) + ); + pr "\n" + (* Generate stubs for the functions implemented in OCaml. * Basically we implement the do_<name> function here, and * have it call out to OCaml code. diff --git a/generator/daemon.mli b/generator/daemon.mli index 40bf31302..f0268ba99 100644 --- a/generator/daemon.mli +++ b/generator/daemon.mli @@ -21,6 +21,7 @@ val generate_daemon_stubs_h : unit -> unit val generate_daemon_stubs : Types.action list -> unit -> unit val generate_daemon_caml_stubs : unit -> unit val generate_daemon_caml_callbacks_ml : unit -> unit +val generate_daemon_caml_interface : string -> unit -> unit val generate_daemon_dispatch : unit -> unit val generate_daemon_lvm_tokenization : unit -> unit val generate_daemon_names : unit -> unit diff --git a/generator/main.ml b/generator/main.ml index 34bca68d9..e51313779 100644 --- a/generator/main.ml +++ b/generator/main.ml @@ -155,6 +155,23 @@ Run it from the top source directory using the command Daemon.generate_daemon_structs_cleanups_c; output_to "daemon/structs-cleanups.h" Daemon.generate_daemon_structs_cleanups_h; + let daemon_ocaml_interfaces = + List.fold_left ( + fun set { impl } -> + let ocaml_function = + match impl with + | OCaml f -> fst (String.split "." f) + | C -> assert false in + + StringSet.add ocaml_function set + ) StringSet.empty (actions |> impl_ocaml_functions) in + StringSet.iter ( + fun modname -> + let fn = Char.escaped (Char.lowercase_ascii (String.unsafe_get modname 0)) ^ + String.sub modname 1 (String.length modname - 1) in + output_to (sprintf "daemon/%s.mli" fn) + (Daemon.generate_daemon_caml_interface modname) + ) daemon_ocaml_interfaces; output_to "fish/cmds-gperf.gperf" Fish.generate_fish_cmds_gperf; -- 2.14.3