Libguestfs - Apr 2018 - [PATCH] daemon: Fix type signature of mount_vfs (RHBZ#1564983).

https://bugzilla.redhat.com/show_bug.cgi?id=1564983

Because Mount.mount_vfs was declared with the wrong type signature it
could never be called correctly from outside the daemon.

The root cause of this problem is that the generator doesn't generate
the type signatures automatically (which it could do, and fairly
easily).  Therefore there are probably other similar bugs waiting to
be found.

Rich.

Reported-by: Yongkui Guo.

Fixes commit 82bbd9c8a503661528289589976697d08cb41090.
---
 daemon/inspect_fs.ml |  6 ++----
 daemon/mount.ml      | 18 +++++++++---------
 daemon/mount.mli     |  2 +-
 3 files changed, 12 insertions(+), 14 deletions(-)

diff --git a/daemon/inspect_fs.ml b/daemon/inspect_fs.ml
index 383e3e0a7..02e2060b9 100644
--- a/daemon/inspect_fs.ml
+++ b/daemon/inspect_fs.ml
@@ -39,14 +39,12 @@ let rec check_for_filesystem_on mountable vfs_type         
if vfs_type = "ufs" then ( (* Hack for the *BSDs. *)
           (* FreeBSD fs is a variant of ufs called ufs2 ... *)
           try
-            Mount.mount_vfs (Some "ro,ufstype=ufs2") (Some
"ufs")
-                            mountable "/";
+            Mount.mount_vfs "ro,ufstype=ufs2" "ufs"
mountable "/";
             true
           with _ ->
             (* while NetBSD and OpenBSD use another variant labeled 44bsd *)
             try
-              Mount.mount_vfs (Some "ro,ufstype=44bsd") (Some
"ufs")
-                              mountable "/";
+              Mount.mount_vfs "ro,ufstype=44bsd" "ufs"
mountable "/";
               true
             with _ -> false
         ) else (
diff --git a/daemon/mount.ml b/daemon/mount.ml
index a4e744f7b..e42ea1580 100644
--- a/daemon/mount.ml
+++ b/daemon/mount.ml
@@ -32,22 +32,22 @@ let mount_vfs options vfs mountable mountpoint  
   (* -o options *)
   (match options, mountable.m_type with
-   | (None | Some ""), (MountableDevice | MountablePath) -> ()
-   | Some options, (MountableDevice | MountablePath) ->
+   | "", (MountableDevice | MountablePath) -> ()
+   | options, (MountableDevice | MountablePath) ->
       List.push_back args "-o";
       List.push_back args options
-   | (None | Some ""), MountableBtrfsVol subvol ->
+   | "", MountableBtrfsVol subvol ->
       List.push_back args "-o";
       List.push_back args ("subvol=" ^ subvol)
-   | Some options, MountableBtrfsVol subvol ->
+   | options, MountableBtrfsVol subvol ->
       List.push_back args "-o";
       List.push_back args ("subvol=" ^ subvol ^ "," ^
options)
   );
 
   (* -t vfs *)
   (match vfs with
-   | None | Some "" -> ()
-   | Some t ->
+   | "" -> ()
+   | t ->
       List.push_back args "-t";
       List.push_back args t
   );
@@ -57,9 +57,9 @@ let mount_vfs options vfs mountable mountpoint  
   ignore (command "mount" !args)
 
-let mount = mount_vfs None None
-let mount_ro = mount_vfs (Some "ro") None
-let mount_options options = mount_vfs (Some options) None
+let mount = mount_vfs "" ""
+let mount_ro = mount_vfs "ro" ""
+let mount_options options = mount_vfs options ""
 
 (* Unmount everything mounted under /sysroot.
  *
diff --git a/daemon/mount.mli b/daemon/mount.mli
index 553630667..96c400190 100644
--- a/daemon/mount.mli
+++ b/daemon/mount.mli
@@ -19,6 +19,6 @@
 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 option -> string option -> Mountable.t ->
string -> unit
+val mount_vfs : string -> string -> Mountable.t -> string -> unit
 
 val umount_all : unit -> unit
-- 
2.16.2

On Monday, 9 April 2018 09:54:51 CEST Richard W.M. Jones
wrote:
> https://bugzilla.redhat.com/show_bug.cgi?id=1564983
> 
> Because Mount.mount_vfs was declared with the wrong type signature it
> could never be called correctly from outside the daemon.
LGTM.
> The root cause of this problem is that the generator doesn't generate
> the type signatures automatically (which it could do, and fairly
> easily).  Therefore there are probably other similar bugs waiting to
> be found.
Let's see how this turns out.

-- 
Pino Toscano