X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=src%2Fgenerator.ml;h=b3388f6e8d683f3b147ab550062ffded08d64572;hb=45d78361d791f4a752fca9472b81bdc75f9f92a4;hp=29b0ecd7b74bc61d9900612379031243d63c7b66;hpb=6eaa49faddeef5ec086ad7c58e0cd591fb4400dc;p=libguestfs.git

diff --git a/src/generator.ml b/src/generator.ml
index 29b0ecd..b3388f6 100755
--- a/src/generator.ml
+++ b/src/generator.ml
@@ -136,7 +136,15 @@ can easily destroy all your data>."
  * the virtual machine and block devices are reused between tests.
  * So don't try testing kill_subprocess :-x
  *
- * Between each test we umount-all and lvm-remove-all (except InitNone).
+ * Between each test we blockdev-setrw, umount-all, lvm-remove-all
+ * (except InitNone).
+ *
+ * If the appliance is running an older Linux kernel (eg. RHEL 5) then
+ * devices are named /dev/hda etc.  To cope with this, the test suite
+ * adds some hairly logic to detect this case, and then automagically
+ * replaces all strings which match "/dev/sd.*" with "/dev/hd.*".
+ * When writing test cases you shouldn't have to worry about this
+ * difference.
  *
  * Don't assume anything about the previous contents of the block
  * devices.  Use 'Init*' to create some initial scenarios.
@@ -339,8 +347,12 @@ return the default path.");
    "set autosync mode",
    "\
 If C<autosync> is true, this enables autosync.  Libguestfs will make a
-best effort attempt to run C<guestfs_sync> when the handle is closed
-(also if the program exits without closing handles).");
+best effort attempt to run C<guestfs_umount_all> followed by
+C<guestfs_sync> when the handle is closed
+(also if the program exits without closing handles).
+
+This is disabled by default (except in guestfish where it is
+enabled by default).");
 
   ("get_autosync", (RBool "autosync", []), -1, [],
    [],
@@ -426,6 +438,16 @@ actions using the low-level API.
 
 For more information on states, see L<guestfs(3)>.");
 
+  ("end_busy", (RErr, []), -1, [NotInFish],
+   [],
+   "leave the busy state",
+   "\
+This sets the state to C<READY>, or if in C<CONFIG> then it leaves the
+state as is.  This is only used when implementing
+actions using the low-level API.
+
+For more information on states, see L<guestfs(3)>.");
+
 ]
 
 let daemon_functions = [
@@ -985,7 +1007,7 @@ on the volume group C<volgroup>, with C<size> megabytes.");
    "make a filesystem",
    "\
 This creates a filesystem on C<device> (usually a partition
-of LVM logical volume).  The filesystem type is C<fstype>, for
+or LVM logical volume).  The filesystem type is C<fstype>, for
 example C<ext3>.");
 
   ("sfdisk", (RErr, [String "device";
@@ -1041,7 +1063,12 @@ with length C<size>.
 
 As a special case, if C<size> is C<0>
 then the length is calculated using C<strlen> (so in this case
-the content cannot contain embedded ASCII NULs).");
+the content cannot contain embedded ASCII NULs).
+
+I<NB.> Owing to a bug, writing content containing ASCII NUL
+characters does I<not> work, even if the length is specified.
+We hope to resolve this bug in a future version.  In the meantime
+use C<guestfs_upload>.");
 
   ("umount", (RErr, [String "pathordevice"]), 45, [FishAlias "unmount"],
    [InitEmpty, TestOutputList (
@@ -1074,6 +1101,20 @@ Some internal mounts are not shown.");
   ("umount_all", (RErr, []), 47, [FishAlias "unmount-all"],
    [InitBasicFS, TestOutputList (
       [["umount_all"];
+       ["mounts"]], []);
+    (* check that umount_all can unmount nested mounts correctly: *)
+    InitEmpty, TestOutputList (
+      [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
+       ["mkfs"; "ext2"; "/dev/sda1"];
+       ["mkfs"; "ext2"; "/dev/sda2"];
+       ["mkfs"; "ext2"; "/dev/sda3"];
+       ["mount"; "/dev/sda1"; "/"];
+       ["mkdir"; "/mp1"];
+       ["mount"; "/dev/sda2"; "/mp1"];
+       ["mkdir"; "/mp1/mp2"];
+       ["mount"; "/dev/sda3"; "/mp1/mp2"];
+       ["mkdir"; "/mp1/mp2/mp3"];
+       ["umount_all"];
        ["mounts"]], [])],
    "unmount all filesystems",
    "\
@@ -1107,8 +1148,55 @@ The exact command which runs is C<file -bsL path>.  Note in
 particular that the filename is not prepended to the output
 (the C<-b> option).");
 
-  ("command", (RString "output", [StringList "arguments"]), 50, [],
-   [], (* XXX how to test? *)
+  ("command", (RString "output", [StringList "arguments"]), 50, [ProtocolLimitWarning],
+   [InitBasicFS, TestOutput (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command"; "/test-command 1"]], "Result1");
+    InitBasicFS, TestOutput (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command"; "/test-command 2"]], "Result2\n");
+    InitBasicFS, TestOutput (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command"; "/test-command 3"]], "\nResult3");
+    InitBasicFS, TestOutput (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command"; "/test-command 4"]], "\nResult4\n");
+    InitBasicFS, TestOutput (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command"; "/test-command 5"]], "\nResult5\n\n");
+    InitBasicFS, TestOutput (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command"; "/test-command 6"]], "\n\nResult6\n\n");
+    InitBasicFS, TestOutput (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command"; "/test-command 7"]], "");
+    InitBasicFS, TestOutput (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command"; "/test-command 8"]], "\n");
+    InitBasicFS, TestOutput (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command"; "/test-command 9"]], "\n\n");
+    InitBasicFS, TestOutput (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command"; "/test-command 10"]], "Result10-1\nResult10-2\n");
+    InitBasicFS, TestOutput (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command"; "/test-command 11"]], "Result11-1\nResult11-2");
+    InitBasicFS, TestLastFail (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command"; "/test-command"]])],
    "run a command from the guest filesystem",
    "\
 This call runs a command from the guest filesystem.  The
@@ -1121,6 +1209,13 @@ The first element is the name of the program to run.
 Subsequent elements are parameters.  The list must be
 non-empty (ie. must contain a program name).
 
+The return value is anything printed to I<stdout> by
+the command.
+
+If the command returns a non-zero exit status, then
+this function returns an error message.  The error message
+string is the content of I<stderr> from the command.
+
 The C<$PATH> environment variable will contain at least
 C</usr/bin> and C</bin>.  If you require a program from
 another location, you should provide the full path in the
@@ -1132,8 +1227,51 @@ correct places.  It is the caller's responsibility to ensure
 all filesystems that are needed are mounted at the right
 locations.");
 
-  ("command_lines", (RStringList "lines", [StringList "arguments"]), 51, [],
-   [], (* XXX how to test? *)
+  ("command_lines", (RStringList "lines", [StringList "arguments"]), 51, [ProtocolLimitWarning],
+   [InitBasicFS, TestOutputList (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command_lines"; "/test-command 1"]], ["Result1"]);
+    InitBasicFS, TestOutputList (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command_lines"; "/test-command 2"]], ["Result2"]);
+    InitBasicFS, TestOutputList (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command_lines"; "/test-command 3"]], ["";"Result3"]);
+    InitBasicFS, TestOutputList (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command_lines"; "/test-command 4"]], ["";"Result4"]);
+    InitBasicFS, TestOutputList (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command_lines"; "/test-command 5"]], ["";"Result5";""]);
+    InitBasicFS, TestOutputList (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command_lines"; "/test-command 6"]], ["";"";"Result6";""]);
+    InitBasicFS, TestOutputList (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command_lines"; "/test-command 7"]], []);
+    InitBasicFS, TestOutputList (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command_lines"; "/test-command 8"]], [""]);
+    InitBasicFS, TestOutputList (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command_lines"; "/test-command 9"]], ["";""]);
+    InitBasicFS, TestOutputList (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command_lines"; "/test-command 10"]], ["Result10-1";"Result10-2"]);
+    InitBasicFS, TestOutputList (
+      [["upload"; "test-command"; "/test-command"];
+       ["chmod"; "493"; "/test-command"];
+       ["command_lines"; "/test-command 11"]], ["Result11-1";"Result11-2"])],
    "run a command, returning lines",
    "\
 This is the same as C<guestfs_command>, but splits the
@@ -1178,10 +1316,10 @@ This is the same as the C<statvfs(2)> system call.");
 
   ("tune2fs_l", (RHashtable "superblock", [String "device"]), 55, [],
    [], (* XXX test *)
-   "get ext2/ext3 superblock details",
+   "get ext2/ext3/ext4 superblock details",
    "\
-This returns the contents of the ext2 or ext3 filesystem superblock
-on C<device>.
+This returns the contents of the ext2, ext3 or ext4 filesystem
+superblock on C<device>.
 
 It is the same as running C<tune2fs -l device>.  See L<tune2fs(8)>
 manpage for more details.  The list of fields returned isn't
@@ -1479,6 +1617,343 @@ There is no comprehensive help for this command.  You have
 to look at the file C<daemon/debug.c> in the libguestfs source
 to find out what you can do.");
 
+  ("lvremove", (RErr, [String "device"]), 77, [],
+   [InitEmpty, TestOutputList (
+      [["pvcreate"; "/dev/sda"];
+       ["vgcreate"; "VG"; "/dev/sda"];
+       ["lvcreate"; "LV1"; "VG"; "50"];
+       ["lvcreate"; "LV2"; "VG"; "50"];
+       ["lvremove"; "/dev/VG/LV1"];
+       ["lvs"]], ["/dev/VG/LV2"]);
+    InitEmpty, TestOutputList (
+      [["pvcreate"; "/dev/sda"];
+       ["vgcreate"; "VG"; "/dev/sda"];
+       ["lvcreate"; "LV1"; "VG"; "50"];
+       ["lvcreate"; "LV2"; "VG"; "50"];
+       ["lvremove"; "/dev/VG"];
+       ["lvs"]], []);
+    InitEmpty, TestOutputList (
+      [["pvcreate"; "/dev/sda"];
+       ["vgcreate"; "VG"; "/dev/sda"];
+       ["lvcreate"; "LV1"; "VG"; "50"];
+       ["lvcreate"; "LV2"; "VG"; "50"];
+       ["lvremove"; "/dev/VG"];
+       ["vgs"]], ["VG"])],
+   "remove an LVM logical volume",
+   "\
+Remove an LVM logical volume C<device>, where C<device> is
+the path to the LV, such as C</dev/VG/LV>.
+
+You can also remove all LVs in a volume group by specifying
+the VG name, C</dev/VG>.");
+
+  ("vgremove", (RErr, [String "vgname"]), 78, [],
+   [InitEmpty, TestOutputList (
+      [["pvcreate"; "/dev/sda"];
+       ["vgcreate"; "VG"; "/dev/sda"];
+       ["lvcreate"; "LV1"; "VG"; "50"];
+       ["lvcreate"; "LV2"; "VG"; "50"];
+       ["vgremove"; "VG"];
+       ["lvs"]], []);
+    InitEmpty, TestOutputList (
+      [["pvcreate"; "/dev/sda"];
+       ["vgcreate"; "VG"; "/dev/sda"];
+       ["lvcreate"; "LV1"; "VG"; "50"];
+       ["lvcreate"; "LV2"; "VG"; "50"];
+       ["vgremove"; "VG"];
+       ["vgs"]], [])],
+   "remove an LVM volume group",
+   "\
+Remove an LVM volume group C<vgname>, (for example C<VG>).
+
+This also forcibly removes all logical volumes in the volume
+group (if any).");
+
+  ("pvremove", (RErr, [String "device"]), 79, [],
+   [InitEmpty, TestOutputList (
+      [["pvcreate"; "/dev/sda"];
+       ["vgcreate"; "VG"; "/dev/sda"];
+       ["lvcreate"; "LV1"; "VG"; "50"];
+       ["lvcreate"; "LV2"; "VG"; "50"];
+       ["vgremove"; "VG"];
+       ["pvremove"; "/dev/sda"];
+       ["lvs"]], []);
+    InitEmpty, TestOutputList (
+      [["pvcreate"; "/dev/sda"];
+       ["vgcreate"; "VG"; "/dev/sda"];
+       ["lvcreate"; "LV1"; "VG"; "50"];
+       ["lvcreate"; "LV2"; "VG"; "50"];
+       ["vgremove"; "VG"];
+       ["pvremove"; "/dev/sda"];
+       ["vgs"]], []);
+    InitEmpty, TestOutputList (
+      [["pvcreate"; "/dev/sda"];
+       ["vgcreate"; "VG"; "/dev/sda"];
+       ["lvcreate"; "LV1"; "VG"; "50"];
+       ["lvcreate"; "LV2"; "VG"; "50"];
+       ["vgremove"; "VG"];
+       ["pvremove"; "/dev/sda"];
+       ["pvs"]], [])],
+   "remove an LVM physical volume",
+   "\
+This wipes a physical volume C<device> so that LVM will no longer
+recognise it.
+
+The implementation uses the C<pvremove> command which refuses to
+wipe physical volumes that contain any volume groups, so you have
+to remove those first.");
+
+  ("set_e2label", (RErr, [String "device"; String "label"]), 80, [],
+   [InitBasicFS, TestOutput (
+      [["set_e2label"; "/dev/sda1"; "testlabel"];
+       ["get_e2label"; "/dev/sda1"]], "testlabel")],
+   "set the ext2/3/4 filesystem label",
+   "\
+This sets the ext2/3/4 filesystem label of the filesystem on
+C<device> to C<label>.  Filesystem labels are limited to
+16 characters.
+
+You can use either C<guestfs_tune2fs_l> or C<guestfs_get_e2label>
+to return the existing label on a filesystem.");
+
+  ("get_e2label", (RString "label", [String "device"]), 81, [],
+   [],
+   "get the ext2/3/4 filesystem label",
+   "\
+This returns the ext2/3/4 filesystem label of the filesystem on
+C<device>.");
+
+  ("set_e2uuid", (RErr, [String "device"; String "uuid"]), 82, [],
+   [InitBasicFS, TestOutput (
+      [["set_e2uuid"; "/dev/sda1"; "a3a61220-882b-4f61-89f4-cf24dcc7297d"];
+       ["get_e2uuid"; "/dev/sda1"]], "a3a61220-882b-4f61-89f4-cf24dcc7297d");
+    InitBasicFS, TestOutput (
+      [["set_e2uuid"; "/dev/sda1"; "clear"];
+       ["get_e2uuid"; "/dev/sda1"]], "");
+    (* We can't predict what UUIDs will be, so just check the commands run. *)
+    InitBasicFS, TestRun (
+      [["set_e2uuid"; "/dev/sda1"; "random"]]);
+    InitBasicFS, TestRun (
+      [["set_e2uuid"; "/dev/sda1"; "time"]])],
+   "set the ext2/3/4 filesystem UUID",
+   "\
+This sets the ext2/3/4 filesystem UUID of the filesystem on
+C<device> to C<uuid>.  The format of the UUID and alternatives
+such as C<clear>, C<random> and C<time> are described in the
+L<tune2fs(8)> manpage.
+
+You can use either C<guestfs_tune2fs_l> or C<guestfs_get_e2uuid>
+to return the existing UUID of a filesystem.");
+
+  ("get_e2uuid", (RString "uuid", [String "device"]), 83, [],
+   [],
+   "get the ext2/3/4 filesystem UUID",
+   "\
+This returns the ext2/3/4 filesystem UUID of the filesystem on
+C<device>.");
+
+  ("fsck", (RInt "status", [String "fstype"; String "device"]), 84, [],
+   [InitBasicFS, TestOutputInt (
+      [["umount"; "/dev/sda1"];
+       ["fsck"; "ext2"; "/dev/sda1"]], 0);
+    InitBasicFS, TestOutputInt (
+      [["umount"; "/dev/sda1"];
+       ["zero"; "/dev/sda1"];
+       ["fsck"; "ext2"; "/dev/sda1"]], 8)],
+   "run the filesystem checker",
+   "\
+This runs the filesystem checker (fsck) on C<device> which
+should have filesystem type C<fstype>.
+
+The returned integer is the status.  See L<fsck(8)> for the
+list of status codes from C<fsck>.
+
+Notes:
+
+=over 4
+
+=item *
+
+Multiple status codes can be summed together.
+
+=item *
+
+A non-zero return code can mean \"success\", for example if
+errors have been corrected on the filesystem.
+
+=item *
+
+Checking or repairing NTFS volumes is not supported
+(by linux-ntfs).
+
+=back
+
+This command is entirely equivalent to running C<fsck -a -t fstype device>.");
+
+  ("zero", (RErr, [String "device"]), 85, [],
+   [InitBasicFS, TestOutput (
+      [["umount"; "/dev/sda1"];
+       ["zero"; "/dev/sda1"];
+       ["file"; "/dev/sda1"]], "data")],
+   "write zeroes to the device",
+   "\
+This command writes zeroes over the first few blocks of C<device>.
+
+How many blocks are zeroed isn't specified (but it's I<not> enough
+to securely wipe the device).  It should be sufficient to remove
+any partition tables, filesystem superblocks and so on.");
+
+  ("grub_install", (RErr, [String "root"; String "device"]), 86, [],
+   [InitBasicFS, TestOutputTrue (
+      [["grub_install"; "/"; "/dev/sda1"];
+       ["is_dir"; "/boot"]])],
+   "install GRUB",
+   "\
+This command installs GRUB (the Grand Unified Bootloader) on
+C<device>, with the root directory being C<root>.");
+
+  ("cp", (RErr, [String "src"; String "dest"]), 87, [],
+   [InitBasicFS, TestOutput (
+      [["write_file"; "/old"; "file content"; "0"];
+       ["cp"; "/old"; "/new"];
+       ["cat"; "/new"]], "file content");
+    InitBasicFS, TestOutputTrue (
+      [["write_file"; "/old"; "file content"; "0"];
+       ["cp"; "/old"; "/new"];
+       ["is_file"; "/old"]]);
+    InitBasicFS, TestOutput (
+      [["write_file"; "/old"; "file content"; "0"];
+       ["mkdir"; "/dir"];
+       ["cp"; "/old"; "/dir/new"];
+       ["cat"; "/dir/new"]], "file content")],
+   "copy a file",
+   "\
+This copies a file from C<src> to C<dest> where C<dest> is
+either a destination filename or destination directory.");
+
+  ("cp_a", (RErr, [String "src"; String "dest"]), 88, [],
+   [InitBasicFS, TestOutput (
+      [["mkdir"; "/olddir"];
+       ["mkdir"; "/newdir"];
+       ["write_file"; "/olddir/file"; "file content"; "0"];
+       ["cp_a"; "/olddir"; "/newdir"];
+       ["cat"; "/newdir/olddir/file"]], "file content")],
+   "copy a file or directory recursively",
+   "\
+This copies a file or directory from C<src> to C<dest>
+recursively using the C<cp -a> command.");
+
+  ("mv", (RErr, [String "src"; String "dest"]), 89, [],
+   [InitBasicFS, TestOutput (
+      [["write_file"; "/old"; "file content"; "0"];
+       ["mv"; "/old"; "/new"];
+       ["cat"; "/new"]], "file content");
+    InitBasicFS, TestOutputFalse (
+      [["write_file"; "/old"; "file content"; "0"];
+       ["mv"; "/old"; "/new"];
+       ["is_file"; "/old"]])],
+   "move a file",
+   "\
+This moves a file from C<src> to C<dest> where C<dest> is
+either a destination filename or destination directory.");
+
+  ("drop_caches", (RErr, [Int "whattodrop"]), 90, [],
+   [InitEmpty, TestRun (
+      [["drop_caches"; "3"]])],
+   "drop kernel page cache, dentries and inodes",
+   "\
+This instructs the guest kernel to drop its page cache,
+and/or dentries and inode caches.  The parameter C<whattodrop>
+tells the kernel what precisely to drop, see
+L<http://linux-mm.org/Drop_Caches>
+
+Setting C<whattodrop> to 3 should drop everything.
+
+This automatically calls L<sync(2)> before the operation,
+so that the maximum guest memory is freed.");
+
+  ("dmesg", (RString "kmsgs", []), 91, [],
+   [InitEmpty, TestRun (
+      [["dmesg"]])],
+   "return kernel messages",
+   "\
+This returns the kernel messages (C<dmesg> output) from
+the guest kernel.  This is sometimes useful for extended
+debugging of problems.
+
+Another way to get the same information is to enable
+verbose messages with C<guestfs_set_verbose> or by setting
+the environment variable C<LIBGUESTFS_DEBUG=1> before
+running the program.");
+
+  ("ping_daemon", (RErr, []), 92, [],
+   [InitEmpty, TestRun (
+      [["ping_daemon"]])],
+   "ping the guest daemon",
+   "\
+This is a test probe into the guestfs daemon running inside
+the qemu subprocess.  Calling this function checks that the
+daemon responds to the ping message, without affecting the daemon
+or attached block device(s) in any other way.");
+
+  ("equal", (RBool "equality", [String "file1"; String "file2"]), 93, [],
+   [InitBasicFS, TestOutputTrue (
+      [["write_file"; "/file1"; "contents of a file"; "0"];
+       ["cp"; "/file1"; "/file2"];
+       ["equal"; "/file1"; "/file2"]]);
+    InitBasicFS, TestOutputFalse (
+      [["write_file"; "/file1"; "contents of a file"; "0"];
+       ["write_file"; "/file2"; "contents of another file"; "0"];
+       ["equal"; "/file1"; "/file2"]]);
+    InitBasicFS, TestLastFail (
+      [["equal"; "/file1"; "/file2"]])],
+   "test if two files have equal contents",
+   "\
+This compares the two files C<file1> and C<file2> and returns
+true if their content is exactly equal, or false otherwise.
+
+The external L<cmp(1)> program is used for the comparison.");
+
+  ("strings", (RStringList "stringsout", [String "path"]), 94, [ProtocolLimitWarning],
+   [InitBasicFS, TestOutputList (
+      [["write_file"; "/new"; "hello\nworld\n"; "0"];
+       ["strings"; "/new"]], ["hello"; "world"]);
+    InitBasicFS, TestOutputList (
+      [["touch"; "/new"];
+       ["strings"; "/new"]], [])],
+   "print the printable strings in a file",
+   "\
+This runs the L<strings(1)> command on a file and returns
+the list of printable strings found.");
+
+  ("strings_e", (RStringList "stringsout", [String "encoding"; String "path"]), 95, [ProtocolLimitWarning],
+   [InitBasicFS, TestOutputList (
+      [["write_file"; "/new"; "hello\nworld\n"; "0"];
+       ["strings_e"; "b"; "/new"]], []);
+    (*InitBasicFS, TestOutputList (
+      [["write_file"; "/new"; "\000h\000e\000l\000l\000o\000\n\000w\000o\000r\000l\000d\000\n"; "24"];
+       ["strings_e"; "b"; "/new"]], ["hello"; "world"])*)],
+   "print the printable strings in a file",
+   "\
+This is like the C<guestfs_strings> command, but allows you to
+specify the encoding.
+
+See the L<strings(1)> manpage for the full list of encodings.
+
+Commonly useful encodings are C<l> (lower case L) which will
+show strings inside Windows/x86 files.
+
+The returned strings are transcoded to UTF-8.");
+
+  ("hexdump", (RString "dump", [String "path"]), 96, [ProtocolLimitWarning],
+   [InitBasicFS, TestOutput (
+      [["write_file"; "/new"; "hello\nworld\n"; "12"];
+       ["hexdump"; "/new"]], "00000000  68 65 6c 6c 6f 0a 77 6f  72 6c 64 0a              |hello.world.|\n0000000c\n")],
+   "dump a file in hexadecimal",
+   "\
+This runs C<hexdump -C> on the given C<path>.  The result is
+the human-readable, canonical hex dump of the file.");
+
 ]
 
 let all_functions = non_daemon_functions @ daemon_functions
@@ -1669,6 +2144,13 @@ let rec string_split sep str =
     s' :: string_split sep s''
   )
 
+let files_equal n1 n2 =
+  let cmd = sprintf "cmp -s %s %s" (Filename.quote n1) (Filename.quote n2) in
+  match Sys.command cmd with
+  | 0 -> true
+  | 1 -> false
+  | i -> failwithf "%s: failed with error code %d" cmd i
+
 let rec find_map f = function
   | [] -> raise Not_found
   | x :: xs ->
@@ -1832,14 +2314,15 @@ let chan = ref stdout
 let pr fs = ksprintf (output_string !chan) fs
 
 (* Generate a header block in a number of standard styles. *)
-type comment_style = CStyle | HashStyle | OCamlStyle
+type comment_style = CStyle | HashStyle | OCamlStyle | HaskellStyle
 type license = GPLv2 | LGPLv2
 
 let generate_header comment license =
   let c = match comment with
     | CStyle ->     pr "/* "; " *"
     | HashStyle ->  pr "# ";  "#"
-    | OCamlStyle -> pr "(* "; " *" in
+    | OCamlStyle -> pr "(* "; " *"
+    | HaskellStyle -> pr "{- "; "  " in
   pr "libguestfs generated file\n";
   pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
@@ -1881,6 +2364,7 @@ let generate_header comment license =
    | CStyle -> pr " */\n"
    | HashStyle -> ()
    | OCamlStyle -> pr " *)\n"
+   | HaskellStyle -> pr "-}\n"
   );
   pr "\n"
 
@@ -2325,8 +2809,7 @@ check_state (guestfs_h *g, const char *caller)
       pr "struct %s_ctx {\n" shortname;
       pr "  /* This flag is set by the callbacks, so we know we've done\n";
       pr "   * the callbacks as expected, and in the right sequence.\n";
-      pr "   * 0 = not called, 1 = send called,\n";
-      pr "   * 1001 = reply called.\n";
+      pr "   * 0 = not called, 1 = reply_cb called.\n";
       pr "   */\n";
       pr "  int cb_sequence;\n";
       pr "  struct guestfs_message_header hdr;\n";
@@ -2352,6 +2835,13 @@ check_state (guestfs_h *g, const char *caller)
       pr "  guestfs_main_loop *ml = guestfs_get_main_loop (g);\n";
       pr "  struct %s_ctx *ctx = (struct %s_ctx *) data;\n" shortname shortname;
       pr "\n";
+      pr "  /* This should definitely not happen. */\n";
+      pr "  if (ctx->cb_sequence != 0) {\n";
+      pr "    ctx->cb_sequence = 9999;\n";
+      pr "    error (g, \"%%s: internal error: reply callback called twice\", \"%s\");\n" name;
+      pr "    return;\n";
+      pr "  }\n";
+      pr "\n";
       pr "  ml->main_loop_quit (ml, g);\n";
       pr "\n";
       pr "  if (!xdr_guestfs_message_header (xdr, &ctx->hdr)) {\n";
@@ -2384,7 +2874,7 @@ check_state (guestfs_h *g, const char *caller)
       );
 
       pr " done:\n";
-      pr "  ctx->cb_sequence = 1001;\n";
+      pr "  ctx->cb_sequence = 1;\n";
       pr "}\n\n";
 
       (* Generate the action stub. *)
@@ -2446,7 +2936,7 @@ check_state (guestfs_h *g, const char *caller)
 	     name;
       );
       pr "  if (serial == -1) {\n";
-      pr "    guestfs_set_ready (g);\n";
+      pr "    guestfs_end_busy (g);\n";
       pr "    return %s;\n" error_code;
       pr "  }\n";
       pr "\n";
@@ -2461,7 +2951,7 @@ check_state (guestfs_h *g, const char *caller)
 	    pr "\n";
 	    pr "    r = guestfs__send_file_sync (g, %s);\n" n;
 	    pr "    if (r == -1) {\n";
-	    pr "      guestfs_set_ready (g);\n";
+	    pr "      guestfs_end_busy (g);\n";
 	    pr "      return %s;\n" error_code;
 	    pr "    }\n";
 	    pr "    if (r == -2) /* daemon cancelled */\n";
@@ -2479,23 +2969,24 @@ check_state (guestfs_h *g, const char *caller)
       pr "  guestfs_set_reply_callback (g, %s_reply_cb, &ctx);\n" shortname;
       pr "  (void) ml->main_loop_run (ml, g);\n";
       pr "  guestfs_set_reply_callback (g, NULL, NULL);\n";
-      pr "  if (ctx.cb_sequence != 1001) {\n";
+      pr "  if (ctx.cb_sequence != 1) {\n";
       pr "    error (g, \"%%s reply failed, see earlier error messages\", \"%s\");\n" name;
-      pr "    guestfs_set_ready (g);\n";
+      pr "    guestfs_end_busy (g);\n";
       pr "    return %s;\n" error_code;
       pr "  }\n";
       pr "\n";
 
       pr "  if (check_reply_header (g, &ctx.hdr, GUESTFS_PROC_%s, serial) == -1) {\n"
 	(String.uppercase shortname);
-      pr "    guestfs_set_ready (g);\n";
+      pr "    guestfs_end_busy (g);\n";
       pr "    return %s;\n" error_code;
       pr "  }\n";
       pr "\n";
 
       pr "  if (ctx.hdr.status == GUESTFS_STATUS_ERROR) {\n";
       pr "    error (g, \"%%s\", ctx.err.error_message);\n";
-      pr "    guestfs_set_ready (g);\n";
+      pr "    free (ctx.err.error_message);\n";
+      pr "    guestfs_end_busy (g);\n";
       pr "    return %s;\n" error_code;
       pr "  }\n";
       pr "\n";
@@ -2505,14 +2996,14 @@ check_state (guestfs_h *g, const char *caller)
 	function
 	| FileOut n ->
 	    pr "  if (guestfs__receive_file_sync (g, %s) == -1) {\n" n;
-	    pr "    guestfs_set_ready (g);\n";
+	    pr "    guestfs_end_busy (g);\n";
 	    pr "    return %s;\n" error_code;
 	    pr "  }\n";
 	    pr "\n";
 	| _ -> ()
       ) (snd style);
 
-      pr "  guestfs_set_ready (g);\n";
+      pr "  guestfs_end_busy (g);\n";
 
       (match fst style with
        | RErr -> pr "  return 0;\n"
@@ -2626,9 +3117,14 @@ and generate_daemon_actions () =
 	     | String n -> pr "  %s = args.%s;\n" n n
 	     | OptString n -> pr "  %s = args.%s ? *args.%s : NULL;\n" n n n
 	     | StringList n ->
-		 pr "  args.%s.%s_val = realloc (args.%s.%s_val, sizeof (char *) * (args.%s.%s_len+1));\n" n n n n n n;
-		 pr "  args.%s.%s_val[args.%s.%s_len] = NULL;\n" n n n n;
-		 pr "  %s = args.%s.%s_val;\n" n n n
+		 pr "  %s = realloc (args.%s.%s_val,\n" n n n;
+		 pr "                sizeof (char *) * (args.%s.%s_len+1));\n" n n;
+		 pr "  if (%s == NULL) {\n" n;
+		 pr "    reply_with_perror (\"realloc\");\n";
+		 pr "    goto done;\n";
+		 pr "  }\n";
+		 pr "  %s[args.%s.%s_len] = NULL;\n" n n n;
+		 pr "  args.%s.%s_val = %s;\n" n n n;
 	     | Bool n -> pr "  %s = args.%s;\n" n n
 	     | Int n -> pr "  %s = args.%s;\n" n n
 	     | FileIn _ | FileOut _ -> ()
@@ -2909,6 +3405,11 @@ and generate_tests () =
 static guestfs_h *g;
 static int suppress_error = 0;
 
+/* This will be 's' or 'h' depending on whether the guest kernel
+ * names IDE devices /dev/sd* or /dev/hd*.
+ */
+static char devchar = 's';
+
 static void print_error (guestfs_h *g, void *data, const char *msg)
 {
   if (!suppress_error)
@@ -2967,8 +3468,9 @@ int main (int argc, char *argv[])
   int failed = 0;
   const char *srcdir;
   const char *filename;
-  int fd;
+  int fd, i;
   int nr_tests, test_num = 0;
+  char **devs;
 
   no_test_warnings ();
 
@@ -3078,6 +3580,28 @@ int main (int argc, char *argv[])
     exit (1);
   }
 
+  /* Detect if the appliance uses /dev/sd* or /dev/hd* in device
+   * names.  This changed between RHEL 5 and RHEL 6 so we have to
+   * support both.
+   */
+  devs = guestfs_list_devices (g);
+  if (devs == NULL || devs[0] == NULL) {
+    printf (\"guestfs_list_devices FAILED\\n\");
+    exit (1);
+  }
+  if (strncmp (devs[0], \"/dev/sd\", 7) == 0)
+    devchar = 's';
+  else if (strncmp (devs[0], \"/dev/hd\", 7) == 0)
+    devchar = 'h';
+  else {
+    printf (\"guestfs_list_devices returned unexpected string '%%s'\\n\",
+            devs[0]);
+    exit (1);
+  }
+  for (i = 0; devs[i] != NULL; ++i)
+    free (devs[i]);
+  free (devs);
+
   nr_tests = %d;
 
 " (500 * 1024 * 1024) (50 * 1024 * 1024) (10 * 1024 * 1024) nr_tests;
@@ -3119,12 +3643,14 @@ and generate_one_test name i (init, test) =
    | InitEmpty ->
        pr "  /* InitEmpty for %s (%d) */\n" name i;
        List.iter (generate_test_command_call test_name)
-	 [["umount_all"];
+	 [["blockdev_setrw"; "/dev/sda"];
+	  ["umount_all"];
 	  ["lvm_remove_all"]]
    | InitBasicFS ->
        pr "  /* InitBasicFS for %s (%d): create ext2 on /dev/sda1 */\n" name i;
        List.iter (generate_test_command_call test_name)
-	 [["umount_all"];
+	 [["blockdev_setrw"; "/dev/sda"];
+	  ["umount_all"];
 	  ["lvm_remove_all"];
 	  ["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
 	  ["mkfs"; "ext2"; "/dev/sda1"];
@@ -3133,7 +3659,8 @@ and generate_one_test name i (init, test) =
        pr "  /* InitBasicFSonLVM for %s (%d): create ext2 on /dev/VG/LV */\n"
 	 name i;
        List.iter (generate_test_command_call test_name)
-	 [["umount_all"];
+	 [["blockdev_setrw"; "/dev/sda"];
+	  ["umount_all"];
 	  ["lvm_remove_all"];
 	  ["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
 	  ["pvcreate"; "/dev/sda1"];
@@ -3158,10 +3685,14 @@ and generate_one_test name i (init, test) =
        List.iter (generate_test_command_call test_name) seq
    | TestOutput (seq, expected) ->
        pr "  /* TestOutput for %s (%d) */\n" name i;
+       pr "  char expected[] = \"%s\";\n" (c_quote expected);
+       if String.length expected > 7 &&
+          String.sub expected 0 7 = "/dev/sd" then
+	 pr "  expected[5] = devchar;\n";
        let seq, last = get_seq_last seq in
        let test () =
-	 pr "    if (strcmp (r, \"%s\") != 0) {\n" (c_quote expected);
-	 pr "      fprintf (stderr, \"%s: expected \\\"%s\\\" but got \\\"%%s\\\"\\n\", r);\n" test_name (c_quote expected);
+	 pr "    if (strcmp (r, expected) != 0) {\n";
+	 pr "      fprintf (stderr, \"%s: expected \\\"%%s\\\" but got \\\"%%s\\\"\\n\", expected, r);\n" test_name;
 	 pr "      return -1;\n";
 	 pr "    }\n"
        in
@@ -3178,9 +3709,14 @@ and generate_one_test name i (init, test) =
 	     pr "      print_strings (r);\n";
 	     pr "      return -1;\n";
 	     pr "    }\n";
-	     pr "    if (strcmp (r[%d], \"%s\") != 0) {\n" i (c_quote str);
-	     pr "      fprintf (stderr, \"%s: expected \\\"%s\\\" but got \\\"%%s\\\"\\n\", r[%d]);\n" test_name (c_quote str) i;
-	     pr "      return -1;\n";
+             pr "    {\n";
+             pr "      char expected[] = \"%s\";\n" (c_quote str);
+             if String.length str > 7 && String.sub str 0 7 = "/dev/sd" then
+	       pr "      expected[5] = devchar;\n";
+	     pr "      if (strcmp (r[%d], expected) != 0) {\n" i;
+	     pr "        fprintf (stderr, \"%s: expected \\\"%%s\\\" but got \\\"%%s\\\"\\n\", expected, r[%d]);\n" test_name i;
+	     pr "        return -1;\n";
+	     pr "      }\n";
 	     pr "    }\n"
 	 ) expected;
 	 pr "    if (r[%d] != NULL) {\n" (List.length expected);
@@ -3324,16 +3860,26 @@ and generate_test_command_call ?(expect_error = false) ?test test_name cmd =
 
       List.iter (
 	function
-	| String _, _
-	| OptString _, _
+	| OptString n, "NULL" -> ()
+	| String n, arg
+	| OptString n, arg ->
+	    pr "    char %s[] = \"%s\";\n" n (c_quote arg);
+	    if String.length arg > 7 && String.sub arg 0 7 = "/dev/sd" then
+	      pr "    %s[5] = devchar;\n" n
 	| Int _, _
-	| Bool _, _ -> ()
+	| Bool _, _
 	| FileIn _, _ | FileOut _, _ -> ()
 	| StringList n, arg ->
-	    pr "    char *%s[] = {\n" n;
 	    let strs = string_split " " arg in
-	    List.iter (
-	      fun str -> pr "      \"%s\",\n" (c_quote str)
+	    iteri (
+	      fun i str ->
+                pr "    char %s_%d[] = \"%s\";\n" n i (c_quote str);
+	        if String.length str > 7 && String.sub str 0 7 = "/dev/sd" then
+	          pr "    %s_%d[5] = devchar;\n" n i
+	    ) strs;
+	    pr "    char *%s[] = {\n" n;
+	    iteri (
+	      fun i _ -> pr "      %s_%d,\n" n i
 	    ) strs;
 	    pr "      NULL\n";
 	    pr "    };\n";
@@ -3368,11 +3914,12 @@ and generate_test_command_call ?(expect_error = false) ?test test_name cmd =
       (* Generate the parameters. *)
       List.iter (
 	function
-	| String _, arg
+	| OptString _, "NULL" -> pr ", NULL"
+	| String n, _
+	| OptString n, _ ->
+            pr ", %s" n
 	| FileIn _, arg | FileOut _, arg ->
 	    pr ", \"%s\"" (c_quote arg)
-	| OptString _, arg ->
-	    if arg = "NULL" then pr ", NULL" else pr ", \"%s\"" (c_quote arg)
 	| StringList n, _ ->
 	    pr ", %s" n
 	| Int _, arg ->
@@ -3423,6 +3970,7 @@ and c_quote str =
   let str = replace_str str "\r" "\\r" in
   let str = replace_str str "\n" "\\n" in
   let str = replace_str str "\t" "\\t" in
+  let str = replace_str str "\000" "\\0" in
   str
 
 (* Generate a lot of different functions for guestfish. *)
@@ -3758,7 +4306,7 @@ and generate_fish_completion () =
 
 #ifdef HAVE_LIBREADLINE
 
-static const char *commands[] = {
+static const char *const commands[] = {
 ";
 
   (* Get the commands and sort them, including the aliases. *)
@@ -4188,7 +4736,7 @@ copy_table (char * const * argv)
 	    pr "    %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n"
 	      n n
 	| StringList n ->
-	    pr "  char **%s = ocaml_guestfs_strings_val (%sv);\n" n n
+	    pr "  char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
 	| Bool n ->
 	    pr "  int %s = Bool_val (%sv);\n" n n
 	| Int n ->
@@ -4410,12 +4958,13 @@ XS_unpack_charPtrPtr (SV *arg) {
   AV *av;
   I32 i;
 
-  if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV) {
+  if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV)
     croak (\"array reference expected\");
-  }
 
   av = (AV *)SvRV (arg);
-  ret = (char **)malloc (av_len (av) + 1 + 1);
+  ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *));
+  if (!ret)
+    croak (\"malloc failed\");
 
   for (i = 0; i <= av_len (av); i++) {
     SV **elem = av_fetch (av, i, 0);
@@ -4433,6 +4982,8 @@ XS_unpack_charPtrPtr (SV *arg) {
 
 MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
 
+PROTOTYPES: ENABLE
+
 guestfs_h *
 _create ()
    CODE:
@@ -5342,6 +5893,11 @@ and generate_ruby_c () =
 
 #include \"extconf.h\"
 
+/* For Ruby < 1.9 */
+#ifndef RARRAY_LEN
+#define RARRAY_LEN(r) (RARRAY((r))->len)
+#endif
+
 static VALUE m_guestfs;			/* guestfs module */
 static VALUE c_guestfs;			/* guestfs_h handle */
 static VALUE e_Error;			/* used for all errors */
@@ -5409,11 +5965,13 @@ static VALUE ruby_guestfs_close (VALUE gv)
 	    pr "  {\n";
 	    pr "    int i, len;\n";
 	    pr "    len = RARRAY_LEN (%sv);\n" n;
-	    pr "    %s = malloc (sizeof (char *) * (len+1));\n" n;
+	    pr "    %s = guestfs_safe_malloc (g, sizeof (char *) * (len+1));\n"
+	      n;
 	    pr "    for (i = 0; i < len; ++i) {\n";
 	    pr "      VALUE v = rb_ary_entry (%sv, i);\n" n;
 	    pr "      %s[i] = StringValueCStr (v);\n" n;
 	    pr "    }\n";
+	    pr "    %s[len] = NULL;\n" n;
 	    pr "  }\n";
 	| Bool n
 	| Int n ->
@@ -5909,7 +6467,7 @@ Java_com_redhat_et_libguestfs_GuestFS__1close
       let needs_i =
 	(match fst style with
 	 | RStringList _ | RPVList _ | RVGList _ | RLVList _ -> true
-	 | RErr _ | RBool _ | RInt _ | RInt64 _ | RConstString _
+	 | RErr | RBool _ | RInt _ | RInt64 _ | RConstString _
 	 | RString _ | RIntBool _ | RStat _ | RStatVFS _
 	 | RHashtable _ -> false) ||
 	List.exists (function StringList _ -> true | _ -> false) (snd style) in
@@ -5928,7 +6486,7 @@ Java_com_redhat_et_libguestfs_GuestFS__1close
 	    pr "  %s = (*env)->GetStringUTFChars (env, j%s, NULL);\n" n n
 	| StringList n ->
 	    pr "  %s_len = (*env)->GetArrayLength (env, j%s);\n" n n;
-	    pr "  %s = malloc (sizeof (char *) * (%s_len+1));\n" n n;
+	    pr "  %s = guestfs_safe_malloc (g, sizeof (char *) * (%s_len+1));\n" n n;
 	    pr "  for (i = 0; i < %s_len; ++i) {\n" n;
 	    pr "    jobject o = (*env)->GetObjectArrayElement (env, j%s, i);\n"
 	      n;
@@ -6072,14 +6630,224 @@ and generate_java_lvm_return typ jtyp cols =
   pr "  guestfs_free_lvm_%s_list (r);\n" typ;
   pr "  return jr;\n"
 
+and generate_haskell_hs () =
+  generate_header HaskellStyle LGPLv2;
+
+  (* XXX We only know how to generate partial FFI for Haskell
+   * at the moment.  Please help out!
+   *)
+  let can_generate style =
+    let check_no_bad_args =
+      List.for_all (function Bool _ | Int _ -> false | _ -> true)
+    in
+    match style with
+    | RErr, args -> check_no_bad_args args
+    | RBool _, _
+    | RInt _, _
+    | RInt64 _, _
+    | RConstString _, _
+    | RString _, _
+    | RStringList _, _
+    | RIntBool _, _
+    | RPVList _, _
+    | RVGList _, _
+    | RLVList _, _
+    | RStat _, _
+    | RStatVFS _, _
+    | RHashtable _, _ -> false in
+
+  pr "\
+{-# INCLUDE <guestfs.h> #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Guestfs (
+  create";
+
+  (* List out the names of the actions we want to export. *)
+  List.iter (
+    fun (name, style, _, _, _, _, _) ->
+      if can_generate style then pr ",\n  %s" name
+  ) all_functions;
+
+  pr "
+  ) where
+import Foreign
+import Foreign.C
+import IO
+import Control.Exception
+import Data.Typeable
+
+data GuestfsS = GuestfsS            -- represents the opaque C struct
+type GuestfsP = Ptr GuestfsS        -- guestfs_h *
+type GuestfsH = ForeignPtr GuestfsS -- guestfs_h * with attached finalizer
+
+-- XXX define properly later XXX
+data PV = PV
+data VG = VG
+data LV = LV
+data IntBool = IntBool
+data Stat = Stat
+data StatVFS = StatVFS
+data Hashtable = Hashtable
+
+foreign import ccall unsafe \"guestfs_create\" c_create
+  :: IO GuestfsP
+foreign import ccall unsafe \"&guestfs_close\" c_close
+  :: FunPtr (GuestfsP -> IO ())
+foreign import ccall unsafe \"guestfs_set_error_handler\" c_set_error_handler
+  :: GuestfsP -> Ptr CInt -> Ptr CInt -> IO ()
+
+create :: IO GuestfsH
+create = do
+  p <- c_create
+  c_set_error_handler p nullPtr nullPtr
+  h <- newForeignPtr c_close p
+  return h
+
+foreign import ccall unsafe \"guestfs_last_error\" c_last_error
+  :: GuestfsP -> IO CString
+
+-- last_error :: GuestfsH -> IO (Maybe String)
+-- last_error h = do
+--   str <- withForeignPtr h (\\p -> c_last_error p)
+--   maybePeek peekCString str
+
+last_error :: GuestfsH -> IO (String)
+last_error h = do
+  str <- withForeignPtr h (\\p -> c_last_error p)
+  if (str == nullPtr)
+    then return \"no error\"
+    else peekCString str
+
+";
+
+  (* Generate wrappers for each foreign function. *)
+  List.iter (
+    fun (name, style, _, _, _, _, _) ->
+      if can_generate style then (
+	pr "foreign import ccall unsafe \"guestfs_%s\" c_%s\n" name name;
+	pr "  :: ";
+	generate_haskell_prototype ~handle:"GuestfsP" style;
+	pr "\n";
+	pr "\n";
+	pr "%s :: " name;
+	generate_haskell_prototype ~handle:"GuestfsH" ~hs:true style;
+	pr "\n";
+	pr "%s %s = do\n" name
+	  (String.concat " " ("h" :: List.map name_of_argt (snd style)));
+	pr "  r <- ";
+	List.iter (
+	  function
+	  | FileIn n
+	  | FileOut n
+	  | String n -> pr "withCString %s $ \\%s -> " n n
+	  | OptString n -> pr "maybeWith withCString %s $ \\%s -> " n n
+	  | StringList n -> pr "withMany withCString %s $ \\%s -> withArray0 nullPtr %s $ \\%s -> " n n n n
+	  | Bool n ->
+	      (* XXX this doesn't work *)
+	      pr "      let\n";
+	      pr "        %s = case %s of\n" n n;
+	      pr "          False -> 0\n";
+	      pr "          True -> 1\n";
+	      pr "      in fromIntegral %s $ \\%s ->\n" n n
+	  | Int n -> pr "fromIntegral %s $ \\%s -> " n n
+	) (snd style);
+	pr "withForeignPtr h (\\p -> c_%s %s)\n" name
+	  (String.concat " " ("p" :: List.map name_of_argt (snd style)));
+	(match fst style with
+	 | RErr | RInt _ | RInt64 _ | RBool _ ->
+	     pr "  if (r == -1)\n";
+	     pr "    then do\n";
+	     pr "      err <- last_error h\n";
+	     pr "      fail err\n";
+	 | RConstString _ | RString _ | RStringList _ | RIntBool _
+	 | RPVList _ | RVGList _ | RLVList _ | RStat _ | RStatVFS _
+	 | RHashtable _ ->
+	     pr "  if (r == nullPtr)\n";
+	     pr "    then do\n";
+	     pr "      err <- last_error h\n";
+	     pr "      fail err\n";
+	);
+	(match fst style with
+	 | RErr ->
+	     pr "    else return ()\n"
+	 | RInt _ ->
+	     pr "    else return (fromIntegral r)\n"
+	 | RInt64 _ ->
+	     pr "    else return (fromIntegral r)\n"
+	 | RBool _ ->
+	     pr "    else return (toBool r)\n"
+	 | RConstString _
+	 | RString _
+	 | RStringList _
+	 | RIntBool _
+	 | RPVList _
+	 | RVGList _
+	 | RLVList _
+	 | RStat _
+	 | RStatVFS _
+	 | RHashtable _ ->
+	     pr "    else return ()\n" (* XXXXXXXXXXXXXXXXXXXX *)
+	);
+	pr "\n";
+      )
+  ) all_functions
+
+and generate_haskell_prototype ~handle ?(hs = false) style =
+  pr "%s -> " handle;
+  let string = if hs then "String" else "CString" in
+  let int = if hs then "Int" else "CInt" in
+  let bool = if hs then "Bool" else "CInt" in
+  let int64 = if hs then "Integer" else "Int64" in
+  List.iter (
+    fun arg ->
+      (match arg with
+       | String _ -> pr "%s" string
+       | OptString _ -> if hs then pr "Maybe String" else pr "CString"
+       | StringList _ -> if hs then pr "[String]" else pr "Ptr CString"
+       | Bool _ -> pr "%s" bool
+       | Int _ -> pr "%s" int
+       | FileIn _ -> pr "%s" string
+       | FileOut _ -> pr "%s" string
+      );
+      pr " -> ";
+  ) (snd style);
+  pr "IO (";
+  (match fst style with
+   | RErr -> if not hs then pr "CInt"
+   | RInt _ -> pr "%s" int
+   | RInt64 _ -> pr "%s" int64
+   | RBool _ -> pr "%s" bool
+   | RConstString _ -> pr "%s" string
+   | RString _ -> pr "%s" string
+   | RStringList _ -> pr "[%s]" string
+   | RIntBool _ -> pr "IntBool"
+   | RPVList _ -> pr "[PV]"
+   | RVGList _ -> pr "[VG]"
+   | RLVList _ -> pr "[LV]"
+   | RStat _ -> pr "Stat"
+   | RStatVFS _ -> pr "StatVFS"
+   | RHashtable _ -> pr "Hashtable"
+  );
+  pr ")"
+
 let output_to filename =
   let filename_new = filename ^ ".new" in
   chan := open_out filename_new;
   let close () =
     close_out !chan;
     chan := stdout;
-    Unix.rename filename_new filename;
-    printf "written %s\n%!" filename;
+
+    (* Is the new file different from the current file? *)
+    if Sys.file_exists filename && files_equal filename filename_new then
+      Unix.unlink filename_new		(* same, so skip it *)
+    else (
+      (* different, overwrite old one *)
+      (try Unix.chmod filename 0o644 with Unix.Unix_error _ -> ());
+      Unix.rename filename_new filename;
+      Unix.chmod filename 0o444;
+      printf "written %s\n%!" filename;
+    )
   in
   close
 
@@ -6203,3 +6971,7 @@ Run it from the top source directory using the command
   let close = output_to "java/com_redhat_et_libguestfs_GuestFS.c" in
   generate_java_c ();
   close ();
+
+  let close = output_to "haskell/Guestfs.hs" in
+  generate_haskell_hs ();
+  close ();