summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore4
-rw-r--r--HACKING3
-rw-r--r--Makefile.am3
-rw-r--r--README6
-rw-r--r--configure.ac9
-rw-r--r--guestfs.pod4
-rw-r--r--haskell/Guestfs.hs777
-rw-r--r--haskell/Guestfs005Load.hs23
-rw-r--r--haskell/Guestfs010Launch.hs32
-rw-r--r--haskell/Guestfs050LVCreate.hs42
-rw-r--r--haskell/Makefile.am42
-rwxr-xr-xsrc/generator.ml211
12 files changed, 1150 insertions, 6 deletions
diff --git a/.gitignore b/.gitignore
index 14cada46..c9b27a37 100644
--- a/.gitignore
+++ b/.gitignore
@@ -14,6 +14,7 @@
*.so
*.class
*.jar
+*.hi
ChangeLog
Makefile.in
Makefile
@@ -37,6 +38,9 @@ examples/to-xml
fish/guestfish
guestfish.1
guestfs.3
+haskell/Guestfs005Load
+haskell/Guestfs010Launch
+haskell/Guestfs050LVCreate
html/guestfish.1.html
html/guestfs.3.html
html/recipes.html
diff --git a/HACKING b/HACKING
index 7d235bc6..8ad6e9a7 100644
--- a/HACKING
+++ b/HACKING
@@ -43,6 +43,9 @@ examples/
fish/
Guestfish (the command-line program / shell)
+haskell/
+ Haskell bindings.
+
images/
Some guest images to test against. These are gzipped to save
space. You have to unzip them before use.
diff --git a/Makefile.am b/Makefile.am
index 8f81a076..80ea8756 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -34,6 +34,9 @@ endif
if HAVE_JAVA
SUBDIRS += java
endif
+if HAVE_HASKELL
+SUBDIRS += haskell
+endif
if HAVE_INSPECTOR
SUBDIRS += inspector
endif
diff --git a/README b/README
index 9efcb9ba..abf058e7 100644
--- a/README
+++ b/README
@@ -16,8 +16,8 @@ LVs, what filesystem is in each LV, etc.). It can also run commands
in the context of the guest. Also you can access filesystems over FTP.
Libguestfs is a library that can be linked with C and C++ management
-programs (or management programs written in OCaml, Perl, Python, Ruby or Java).
-You can also use it from shell scripts or the command line.
+programs (or management programs written in OCaml, Perl, Python, Ruby, Java
+or Haskell). You can also use it from shell scripts or the command line.
Libguestfs was written by Richard W.M. Jones (rjones@redhat.com).
For discussion please use the fedora-virt mailing list:
@@ -56,6 +56,8 @@ also to build the OCaml bindings
- (Optional) Java, JNI, jpackage-utils if you want to build the java
bindings
+- (Optional) GHC if you want to build the Haskell bindings
+
Running ./configure will check you have all the requirements installed
on your machine.
diff --git a/configure.ac b/configure.ac
index 4c20e123..67d626ef 100644
--- a/configure.ac
+++ b/configure.ac
@@ -394,6 +394,12 @@ AC_SUBST(JNI_VERSION_INFO)
AM_CONDITIONAL([HAVE_JAVA],[test -n "$JAVAC"])
+dnl Check for Haskell (GHC).
+AC_CHECK_PROG([GHC],[ghc],[ghc],[no])
+
+AM_CONDITIONAL([HAVE_HASKELL],
+ [test "x$GHC" != "xno"])
+
dnl Check for Perl modules needed by the inspector.
missing_perl_modules=no
for pm in Pod::Usage Getopt::Long Sys::Virt Data::Dumper; do
@@ -424,6 +430,7 @@ AC_CONFIG_FILES([Makefile src/Makefile fish/Makefile examples/Makefile
python/Makefile
ruby/Makefile ruby/Rakefile
java/Makefile
+ haskell/Makefile
inspector/Makefile
make-initramfs.sh update-initramfs.sh
libguestfs.spec libguestfs.pc
@@ -452,6 +459,8 @@ echo -n "Ruby bindings ....................... "
if test "x$HAVE_RUBY_TRUE" = "x"; then echo "yes"; else echo "no"; fi
echo -n "Java bindings ....................... "
if test "x$HAVE_JAVA_TRUE" = "x"; then echo "yes"; else echo "no"; fi
+echo -n "Haskell bindings .................... "
+if test "x$HAVE_HASKELL" = "x"; then echo "yes"; else echo "no"; fi
echo -n "virt-inspector ...................... "
if test "x$HAVE_INSPECTOR" = "x"; then echo "yes"; else echo "no"; fi
echo
diff --git a/guestfs.pod b/guestfs.pod
index 9cef777c..06cc2b3a 100644
--- a/guestfs.pod
+++ b/guestfs.pod
@@ -37,8 +37,8 @@ LVs, what filesystem is in each LV, etc.). It can also run commands
in the context of the guest. Also you can access filesystems over FTP.
Libguestfs is a library that can be linked with C and C++ management
-programs (or management programs written in OCaml, Perl, Python, Ruby or Java).
-You can also use it from shell scripts or the command line.
+programs (or management programs written in OCaml, Perl, Python, Ruby, Java
+or Haskell). You can also use it from shell scripts or the command line.
You don't need to be root to use libguestfs, although obviously you do
need enough permissions to access the disk images.
diff --git a/haskell/Guestfs.hs b/haskell/Guestfs.hs
new file mode 100644
index 00000000..aedf3b53
--- /dev/null
+++ b/haskell/Guestfs.hs
@@ -0,0 +1,777 @@
+{- libguestfs generated file
+ WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.
+ ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.
+
+ Copyright (C) 2009 Red Hat Inc.
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2 of the License, or (at your option) any later version.
+
+ This library 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
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+-}
+
+{-# INCLUDE <guestfs.h> #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Guestfs (
+ create,
+ launch,
+ wait_ready,
+ kill_subprocess,
+ add_drive,
+ add_cdrom,
+ config,
+ set_qemu,
+ set_path,
+ set_busy,
+ set_ready,
+ end_busy,
+ mount,
+ sync,
+ touch,
+ aug_close,
+ aug_set,
+ aug_mv,
+ aug_save,
+ aug_load,
+ rm,
+ rmdir,
+ rm_rf,
+ mkdir,
+ mkdir_p,
+ pvcreate,
+ vgcreate,
+ mkfs,
+ umount,
+ umount_all,
+ lvm_remove_all,
+ blockdev_setro,
+ blockdev_setrw,
+ blockdev_flushbufs,
+ blockdev_rereadpt,
+ upload,
+ download,
+ tar_in,
+ tar_out,
+ tgz_in,
+ tgz_out,
+ mount_ro,
+ mount_options,
+ mount_vfs,
+ lvremove,
+ vgremove,
+ pvremove,
+ set_e2label,
+ set_e2uuid,
+ zero,
+ grub_install,
+ cp,
+ cp_a,
+ mv,
+ ping_daemon
+ ) 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
+
+foreign import ccall unsafe "guestfs_launch" c_launch
+ :: GuestfsP -> IO (CInt)
+
+launch :: GuestfsH -> IO ()
+launch h = do
+ r <- withForeignPtr h (\p -> c_launch p)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_wait_ready" c_wait_ready
+ :: GuestfsP -> IO (CInt)
+
+wait_ready :: GuestfsH -> IO ()
+wait_ready h = do
+ r <- withForeignPtr h (\p -> c_wait_ready p)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_kill_subprocess" c_kill_subprocess
+ :: GuestfsP -> IO (CInt)
+
+kill_subprocess :: GuestfsH -> IO ()
+kill_subprocess h = do
+ r <- withForeignPtr h (\p -> c_kill_subprocess p)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_add_drive" c_add_drive
+ :: GuestfsP -> CString -> IO (CInt)
+
+add_drive :: GuestfsH -> String -> IO ()
+add_drive h filename = do
+ r <- withCString filename $ \filename -> withForeignPtr h (\p -> c_add_drive p filename)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_add_cdrom" c_add_cdrom
+ :: GuestfsP -> CString -> IO (CInt)
+
+add_cdrom :: GuestfsH -> String -> IO ()
+add_cdrom h filename = do
+ r <- withCString filename $ \filename -> withForeignPtr h (\p -> c_add_cdrom p filename)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_config" c_config
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+config :: GuestfsH -> String -> Maybe String -> IO ()
+config h qemuparam qemuvalue = do
+ r <- withCString qemuparam $ \qemuparam -> maybeWith withCString qemuvalue $ \qemuvalue -> withForeignPtr h (\p -> c_config p qemuparam qemuvalue)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_set_qemu" c_set_qemu
+ :: GuestfsP -> CString -> IO (CInt)
+
+set_qemu :: GuestfsH -> String -> IO ()
+set_qemu h qemu = do
+ r <- withCString qemu $ \qemu -> withForeignPtr h (\p -> c_set_qemu p qemu)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_set_path" c_set_path
+ :: GuestfsP -> CString -> IO (CInt)
+
+set_path :: GuestfsH -> String -> IO ()
+set_path h path = do
+ r <- withCString path $ \path -> withForeignPtr h (\p -> c_set_path p path)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_set_busy" c_set_busy
+ :: GuestfsP -> IO (CInt)
+
+set_busy :: GuestfsH -> IO ()
+set_busy h = do
+ r <- withForeignPtr h (\p -> c_set_busy p)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_set_ready" c_set_ready
+ :: GuestfsP -> IO (CInt)
+
+set_ready :: GuestfsH -> IO ()
+set_ready h = do
+ r <- withForeignPtr h (\p -> c_set_ready p)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_end_busy" c_end_busy
+ :: GuestfsP -> IO (CInt)
+
+end_busy :: GuestfsH -> IO ()
+end_busy h = do
+ r <- withForeignPtr h (\p -> c_end_busy p)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_mount" c_mount
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+mount :: GuestfsH -> String -> String -> IO ()
+mount h device mountpoint = do
+ r <- withCString device $ \device -> withCString mountpoint $ \mountpoint -> withForeignPtr h (\p -> c_mount p device mountpoint)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_sync" c_sync
+ :: GuestfsP -> IO (CInt)
+
+sync :: GuestfsH -> IO ()
+sync h = do
+ r <- withForeignPtr h (\p -> c_sync p)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_touch" c_touch
+ :: GuestfsP -> CString -> IO (CInt)
+
+touch :: GuestfsH -> String -> IO ()
+touch h path = do
+ r <- withCString path $ \path -> withForeignPtr h (\p -> c_touch p path)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_aug_close" c_aug_close
+ :: GuestfsP -> IO (CInt)
+
+aug_close :: GuestfsH -> IO ()
+aug_close h = do
+ r <- withForeignPtr h (\p -> c_aug_close p)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_aug_set" c_aug_set
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+aug_set :: GuestfsH -> String -> String -> IO ()
+aug_set h path val = do
+ r <- withCString path $ \path -> withCString val $ \val -> withForeignPtr h (\p -> c_aug_set p path val)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_aug_mv" c_aug_mv
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+aug_mv :: GuestfsH -> String -> String -> IO ()
+aug_mv h src dest = do
+ r <- withCString src $ \src -> withCString dest $ \dest -> withForeignPtr h (\p -> c_aug_mv p src dest)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_aug_save" c_aug_save
+ :: GuestfsP -> IO (CInt)
+
+aug_save :: GuestfsH -> IO ()
+aug_save h = do
+ r <- withForeignPtr h (\p -> c_aug_save p)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_aug_load" c_aug_load
+ :: GuestfsP -> IO (CInt)
+
+aug_load :: GuestfsH -> IO ()
+aug_load h = do
+ r <- withForeignPtr h (\p -> c_aug_load p)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_rm" c_rm
+ :: GuestfsP -> CString -> IO (CInt)
+
+rm :: GuestfsH -> String -> IO ()
+rm h path = do
+ r <- withCString path $ \path -> withForeignPtr h (\p -> c_rm p path)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_rmdir" c_rmdir
+ :: GuestfsP -> CString -> IO (CInt)
+
+rmdir :: GuestfsH -> String -> IO ()
+rmdir h path = do
+ r <- withCString path $ \path -> withForeignPtr h (\p -> c_rmdir p path)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_rm_rf" c_rm_rf
+ :: GuestfsP -> CString -> IO (CInt)
+
+rm_rf :: GuestfsH -> String -> IO ()
+rm_rf h path = do
+ r <- withCString path $ \path -> withForeignPtr h (\p -> c_rm_rf p path)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_mkdir" c_mkdir
+ :: GuestfsP -> CString -> IO (CInt)
+
+mkdir :: GuestfsH -> String -> IO ()
+mkdir h path = do
+ r <- withCString path $ \path -> withForeignPtr h (\p -> c_mkdir p path)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_mkdir_p" c_mkdir_p
+ :: GuestfsP -> CString -> IO (CInt)
+
+mkdir_p :: GuestfsH -> String -> IO ()
+mkdir_p h path = do
+ r <- withCString path $ \path -> withForeignPtr h (\p -> c_mkdir_p p path)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_pvcreate" c_pvcreate
+ :: GuestfsP -> CString -> IO (CInt)
+
+pvcreate :: GuestfsH -> String -> IO ()
+pvcreate h device = do
+ r <- withCString device $ \device -> withForeignPtr h (\p -> c_pvcreate p device)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_vgcreate" c_vgcreate
+ :: GuestfsP -> CString -> Ptr CString -> IO (CInt)
+
+vgcreate :: GuestfsH -> String -> [String] -> IO ()
+vgcreate h volgroup physvols = do
+ r <- withCString volgroup $ \volgroup -> withMany withCString physvols $ \physvols -> withArray0 nullPtr physvols $ \physvols -> withForeignPtr h (\p -> c_vgcreate p volgroup physvols)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_mkfs" c_mkfs
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+mkfs :: GuestfsH -> String -> String -> IO ()
+mkfs h fstype device = do
+ r <- withCString fstype $ \fstype -> withCString device $ \device -> withForeignPtr h (\p -> c_mkfs p fstype device)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_umount" c_umount
+ :: GuestfsP -> CString -> IO (CInt)
+
+umount :: GuestfsH -> String -> IO ()
+umount h pathordevice = do
+ r <- withCString pathordevice $ \pathordevice -> withForeignPtr h (\p -> c_umount p pathordevice)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_umount_all" c_umount_all
+ :: GuestfsP -> IO (CInt)
+
+umount_all :: GuestfsH -> IO ()
+umount_all h = do
+ r <- withForeignPtr h (\p -> c_umount_all p)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_lvm_remove_all" c_lvm_remove_all
+ :: GuestfsP -> IO (CInt)
+
+lvm_remove_all :: GuestfsH -> IO ()
+lvm_remove_all h = do
+ r <- withForeignPtr h (\p -> c_lvm_remove_all p)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_blockdev_setro" c_blockdev_setro
+ :: GuestfsP -> CString -> IO (CInt)
+
+blockdev_setro :: GuestfsH -> String -> IO ()
+blockdev_setro h device = do
+ r <- withCString device $ \device -> withForeignPtr h (\p -> c_blockdev_setro p device)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_blockdev_setrw" c_blockdev_setrw
+ :: GuestfsP -> CString -> IO (CInt)
+
+blockdev_setrw :: GuestfsH -> String -> IO ()
+blockdev_setrw h device = do
+ r <- withCString device $ \device -> withForeignPtr h (\p -> c_blockdev_setrw p device)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_blockdev_flushbufs" c_blockdev_flushbufs
+ :: GuestfsP -> CString -> IO (CInt)
+
+blockdev_flushbufs :: GuestfsH -> String -> IO ()
+blockdev_flushbufs h device = do
+ r <- withCString device $ \device -> withForeignPtr h (\p -> c_blockdev_flushbufs p device)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_blockdev_rereadpt" c_blockdev_rereadpt
+ :: GuestfsP -> CString -> IO (CInt)
+
+blockdev_rereadpt :: GuestfsH -> String -> IO ()
+blockdev_rereadpt h device = do
+ r <- withCString device $ \device -> withForeignPtr h (\p -> c_blockdev_rereadpt p device)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_upload" c_upload
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+upload :: GuestfsH -> String -> String -> IO ()
+upload h filename remotefilename = do
+ r <- withCString filename $ \filename -> withCString remotefilename $ \remotefilename -> withForeignPtr h (\p -> c_upload p filename remotefilename)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_download" c_download
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+download :: GuestfsH -> String -> String -> IO ()
+download h remotefilename filename = do
+ r <- withCString remotefilename $ \remotefilename -> withCString filename $ \filename -> withForeignPtr h (\p -> c_download p remotefilename filename)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_tar_in" c_tar_in
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+tar_in :: GuestfsH -> String -> String -> IO ()
+tar_in h tarfile directory = do
+ r <- withCString tarfile $ \tarfile -> withCString directory $ \directory -> withForeignPtr h (\p -> c_tar_in p tarfile directory)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_tar_out" c_tar_out
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+tar_out :: GuestfsH -> String -> String -> IO ()
+tar_out h directory tarfile = do
+ r <- withCString directory $ \directory -> withCString tarfile $ \tarfile -> withForeignPtr h (\p -> c_tar_out p directory tarfile)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_tgz_in" c_tgz_in
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+tgz_in :: GuestfsH -> String -> String -> IO ()
+tgz_in h tarball directory = do
+ r <- withCString tarball $ \tarball -> withCString directory $ \directory -> withForeignPtr h (\p -> c_tgz_in p tarball directory)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_tgz_out" c_tgz_out
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+tgz_out :: GuestfsH -> String -> String -> IO ()
+tgz_out h directory tarball = do
+ r <- withCString directory $ \directory -> withCString tarball $ \tarball -> withForeignPtr h (\p -> c_tgz_out p directory tarball)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_mount_ro" c_mount_ro
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+mount_ro :: GuestfsH -> String -> String -> IO ()
+mount_ro h device mountpoint = do
+ r <- withCString device $ \device -> withCString mountpoint $ \mountpoint -> withForeignPtr h (\p -> c_mount_ro p device mountpoint)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_mount_options" c_mount_options
+ :: GuestfsP -> CString -> CString -> CString -> IO (CInt)
+
+mount_options :: GuestfsH -> String -> String -> String -> IO ()
+mount_options h options device mountpoint = do
+ r <- withCString options $ \options -> withCString device $ \device -> withCString mountpoint $ \mountpoint -> withForeignPtr h (\p -> c_mount_options p options device mountpoint)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_mount_vfs" c_mount_vfs
+ :: GuestfsP -> CString -> CString -> CString -> CString -> IO (CInt)
+
+mount_vfs :: GuestfsH -> String -> String -> String -> String -> IO ()
+mount_vfs h options vfstype device mountpoint = do
+ r <- withCString options $ \options -> withCString vfstype $ \vfstype -> withCString device $ \device -> withCString mountpoint $ \mountpoint -> withForeignPtr h (\p -> c_mount_vfs p options vfstype device mountpoint)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_lvremove" c_lvremove
+ :: GuestfsP -> CString -> IO (CInt)
+
+lvremove :: GuestfsH -> String -> IO ()
+lvremove h device = do
+ r <- withCString device $ \device -> withForeignPtr h (\p -> c_lvremove p device)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_vgremove" c_vgremove
+ :: GuestfsP -> CString -> IO (CInt)
+
+vgremove :: GuestfsH -> String -> IO ()
+vgremove h vgname = do
+ r <- withCString vgname $ \vgname -> withForeignPtr h (\p -> c_vgremove p vgname)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_pvremove" c_pvremove
+ :: GuestfsP -> CString -> IO (CInt)
+
+pvremove :: GuestfsH -> String -> IO ()
+pvremove h device = do
+ r <- withCString device $ \device -> withForeignPtr h (\p -> c_pvremove p device)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_set_e2label" c_set_e2label
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+set_e2label :: GuestfsH -> String -> String -> IO ()
+set_e2label h device label = do
+ r <- withCString device $ \device -> withCString label $ \label -> withForeignPtr h (\p -> c_set_e2label p device label)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_set_e2uuid" c_set_e2uuid
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+set_e2uuid :: GuestfsH -> String -> String -> IO ()
+set_e2uuid h device uuid = do
+ r <- withCString device $ \device -> withCString uuid $ \uuid -> withForeignPtr h (\p -> c_set_e2uuid p device uuid)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_zero" c_zero
+ :: GuestfsP -> CString -> IO (CInt)
+
+zero :: GuestfsH -> String -> IO ()
+zero h device = do
+ r <- withCString device $ \device -> withForeignPtr h (\p -> c_zero p device)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_grub_install" c_grub_install
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+grub_install :: GuestfsH -> String -> String -> IO ()
+grub_install h root device = do
+ r <- withCString root $ \root -> withCString device $ \device -> withForeignPtr h (\p -> c_grub_install p root device)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_cp" c_cp
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+cp :: GuestfsH -> String -> String -> IO ()
+cp h src dest = do
+ r <- withCString src $ \src -> withCString dest $ \dest -> withForeignPtr h (\p -> c_cp p src dest)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_cp_a" c_cp_a
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+cp_a :: GuestfsH -> String -> String -> IO ()
+cp_a h src dest = do
+ r <- withCString src $ \src -> withCString dest $ \dest -> withForeignPtr h (\p -> c_cp_a p src dest)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_mv" c_mv
+ :: GuestfsP -> CString -> CString -> IO (CInt)
+
+mv :: GuestfsH -> String -> String -> IO ()
+mv h src dest = do
+ r <- withCString src $ \src -> withCString dest $ \dest -> withForeignPtr h (\p -> c_mv p src dest)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
+foreign import ccall unsafe "guestfs_ping_daemon" c_ping_daemon
+ :: GuestfsP -> IO (CInt)
+
+ping_daemon :: GuestfsH -> IO ()
+ping_daemon h = do
+ r <- withForeignPtr h (\p -> c_ping_daemon p)
+ if (r == -1)
+ then do
+ err <- last_error h
+ fail err
+ else return ()
+
diff --git a/haskell/Guestfs005Load.hs b/haskell/Guestfs005Load.hs
new file mode 100644
index 00000000..c7cb1671
--- /dev/null
+++ b/haskell/Guestfs005Load.hs
@@ -0,0 +1,23 @@
+{- libguestfs Haskell bindings
+ Copyright (C) 2009 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+-}
+
+module Guestfs005Load where
+import qualified Guestfs
+
+main = do
+ Guestfs.create
diff --git a/haskell/Guestfs010Launch.hs b/haskell/Guestfs010Launch.hs
new file mode 100644
index 00000000..27e49f77
--- /dev/null
+++ b/haskell/Guestfs010Launch.hs
@@ -0,0 +1,32 @@
+{- libguestfs Haskell bindings
+ Copyright (C) 2009 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+-}
+
+module Guestfs010Launch where
+import qualified Guestfs
+import System.IO (openFile, hClose, hSetFileSize, IOMode(WriteMode))
+import System.Posix.Files (removeLink)
+
+main = do
+ g <- Guestfs.create
+ fd <- openFile "test.img" WriteMode
+ hSetFileSize fd (500 * 1024 * 1024)
+ hClose fd
+ Guestfs.add_drive g "test.img"
+ Guestfs.launch g
+ Guestfs.wait_ready g
+ removeLink "test.img"
diff --git a/haskell/Guestfs050LVCreate.hs b/haskell/Guestfs050LVCreate.hs
new file mode 100644
index 00000000..b82bf0da
--- /dev/null
+++ b/haskell/Guestfs050LVCreate.hs
@@ -0,0 +1,42 @@
+{- libguestfs Haskell bindings
+ Copyright (C) 2009 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+-}
+
+module Guestfs050LVCreate where
+import qualified Guestfs
+import System.IO (openFile, hClose, hSetFileSize, IOMode(WriteMode))
+import System.Posix.Files (removeLink)
+
+main = do
+ g <- Guestfs.create
+ fd <- openFile "test.img" WriteMode
+ hSetFileSize fd (500 * 1024 * 1024)
+ hClose fd
+ Guestfs.add_drive g "test.img"
+ Guestfs.launch g
+ Guestfs.wait_ready g
+
+ Guestfs.pvcreate g "/dev/sda"
+ Guestfs.vgcreate g "VG" ["/dev/sda"]
+ -- Guestfs.lvcreate g "LV1" "VG" 200
+ -- Guestfs.lvcreate g "LV2" "VG" 200
+
+ -- Guestfs.lvs g and check returned list
+
+ Guestfs.sync g
+
+ removeLink "test.img"
diff --git a/haskell/Makefile.am b/haskell/Makefile.am
new file mode 100644
index 00000000..06efdfdc
--- /dev/null
+++ b/haskell/Makefile.am
@@ -0,0 +1,42 @@
+# libguestfs Haskell bindings
+# Copyright (C) 2009 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+EXTRA_DIST = *.hs
+
+CLEANFILES = *~
+
+if HAVE_HASKELL
+
+TESTS_ENVIRONMENT = \
+ LD_LIBRARY_PATH=$(abs_top_builddir)/src/.libs \
+ LIBGUESTFS_PATH=$(abs_top_builddir) \
+ $(VG)
+
+TESTS = Guestfs005Load Guestfs010Launch Guestfs050LVCreate
+
+GHCFLAGS = -I$(abs_top_builddir)/src -L$(abs_top_builddir)/src/.libs
+
+Guestfs005Load: Guestfs005Load.hs Guestfs.hs
+ $(GHC) $(GHCFLAGS) -main-is $(shell basename $@) --make -o $@ $< -lguestfs
+
+Guestfs010Launch: Guestfs010Launch.hs Guestfs.hs
+ $(GHC) $(GHCFLAGS) -main-is $(shell basename $@) --make -o $@ $< -lguestfs
+
+Guestfs050LVCreate: Guestfs050LVCreate.hs Guestfs.hs
+ $(GHC) $(GHCFLAGS) -main-is $(shell basename $@) --make -o $@ $< -lguestfs
+
+endif \ No newline at end of file
diff --git a/src/generator.ml b/src/generator.ml
index 5b6e1eb3..f7057d0e 100755
--- a/src/generator.ml
+++ b/src/generator.ml
@@ -2214,14 +2214,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;
@@ -2263,6 +2264,7 @@ let generate_header comment license =
| CStyle -> pr " */\n"
| HashStyle -> ()
| OCamlStyle -> pr " *)\n"
+ | HaskellStyle -> pr "-}\n"
);
pr "\n"
@@ -6528,6 +6530,207 @@ 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;
@@ -6668,3 +6871,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 ();
generated by cgit (git 2.34.1) at 2024-11-20 15:21:30 +0000