From d43dac69483e8ec62e8356d93f761684ce2f5cc8 Mon Sep 17 00:00:00 2001 From: Richard Jones Date: Sat, 9 May 2009 17:19:24 +0100 Subject: [PATCH] Partial Haskell bindings. --- .gitignore | 4 + HACKING | 3 + Makefile.am | 3 + README | 6 +- configure.ac | 9 + guestfs.pod | 4 +- haskell/Guestfs.hs | 777 ++++++++++++++++++++++++++++++++++++++++++ haskell/Guestfs005Load.hs | 23 ++ haskell/Guestfs010Launch.hs | 32 ++ haskell/Guestfs050LVCreate.hs | 42 +++ haskell/Makefile.am | 42 +++ src/generator.ml | 211 +++++++++++- 12 files changed, 1150 insertions(+), 6 deletions(-) create mode 100644 haskell/Guestfs.hs create mode 100644 haskell/Guestfs005Load.hs create mode 100644 haskell/Guestfs010Launch.hs create mode 100644 haskell/Guestfs050LVCreate.hs create mode 100644 haskell/Makefile.am diff --git a/.gitignore b/.gitignore index 14cada4..c9b27a3 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 7d235bc..8ad6e9a 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 8f81a07..80ea875 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 9efcb9b..abf058e 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 4c20e12..67d626e 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 9cef777..06cc2b3 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 0000000..aedf3b5 --- /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 #-} +{-# 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 0000000..c7cb167 --- /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 0000000..27e49f7 --- /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 0000000..b82bf0d --- /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 0000000..06efdfd --- /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 5b6e1eb..f7057d0 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 #-} +{-# 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 (); -- 1.8.3.1