Bindings to libvhd.

This allows ocaml programs to manipulate VHD files suitable for use
with XCP/XenServer.

Sample usage:
	Vhd.create filename virtual_size (Vhd.Ty_dynamic) (Vhdutil.max_size) [];
	let uid = Vhd.with_vhd filename false Vhd.get_uid

Signed-off-by: Jon Ludlam <jonathan.ludlam@eu.citrix.com>
Acked-by: Dave Scott <dave.scott@eu.citrix.com>

diff --git a/Makefile.in b/Makefile.in
index 57f1259d5a147ba930505b9d8398c88848179cc7..8ff2534d22c02f214e824ea47a6d9c428c964265 100644 (file)
--- a/Makefile.in
+++ b/Makefile.in
@@ -44,6 +44,7 @@ ifeq ($(HAVE_XEN),1)
        $(MAKE) -C xsrpc
        $(MAKE) -C eventchn
        $(MAKE) -C cpuid
+       $(MAKE) -C vhd
 endif
 
 install:
@@ -82,6 +83,7 @@ ifeq ($(HAVE_XEN),1)
        $(MAKE) -C xsrpc install
        $(MAKE) -C eventchn install
        $(MAKE) -C cpuid install
+       $(MAKE) -C vhd install
 endif
 
 uninstall:
@@ -120,6 +122,7 @@ ifeq ($(HAVE_XEN),1)
        $(MAKE) -C xc uninstall
        $(MAKE) -C mmap uninstall
        $(MAKE) -C cpuid uninstall
+       $(MAKE) -C vhd uninstall
 endif
 
 bins:
@@ -169,6 +172,7 @@ doc:
        $(MAKE) -C forking_executioner doc
        $(MAKE) -C mlvm doc
        $(MAKE) -C cpuid doc
+       $(MAKE) -C vhd doc
        $(MAKE) -C xen-utils doc
 
 .PHONY: clean
@@ -190,6 +194,7 @@ clean:
        $(MAKE) -C forking_executioner clean
        $(MAKE) -C mlvm clean
        $(MAKE) -C cpuid clean
+       $(MAKE) -C vhd clean
        $(MAKE) -C xen-utils clean
 
 cleanxen:

diff --git a/vhd/META.in b/vhd/META.in
new file mode 100644 (file)
index 0000000..c8a3ec0
--- /dev/null
+++ b/vhd/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "libvhd bindings"
+archive(byte) = "vhd.cma"
+archive(native) = "vhd.cmxa"

diff --git a/vhd/Makefile b/vhd/Makefile
new file mode 100644 (file)
index 0000000..b63e0b6
--- /dev/null
+++ b/vhd/Makefile
@@ -0,0 +1,71 @@
+
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/usr/lib/ocaml -D_LARGEFILE_SOURCE -D_LARGEFILE64_SOURCE -D_GNU_SOURCE -fno-strict-aliasing -D_FILE_OFFSET_BITS=64
+OCAMLC = ocamlc -g
+OCAMLOPT = ocamlopt
+OCAMLFIND = ocamlfind
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := 1
+OCAMLFLAGS = -g -dtypes 
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OBJS = vhd
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = vhd.cma vhd.cmxa
+
+DOCDIR = /myrepos/xen-api-libs.hg/doc
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+vhd.cmxa: libvhd_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
+       $(OCAMLFIND) $(OCAMLOPT) $(OCAMLFLAGS) -a -o $@ -cclib -lvhd_stubs -cclib -lvhd $(foreach obj,$(OBJS),$(obj).cmx)
+
+vhd.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+       $(OCAMLFIND) $(OCAMLC) $(OCAMLFLAGS) -a -dllib dllvhd_stubs.so -cclib -lvhd_stubs -cclib -lvhd -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+vhd_stubs.a: vhd_stubs.o
+       ocamlmklib -o vhd_stubs -lvhd $+
+
+libvhd_stubs.a: vhd_stubs.o
+       ar rcs $@ $+
+       ocamlmklib -o vhd_stubs -lvhd $+
+
+%.cmo: %.ml
+       $(OCAMLFIND) $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
+
+%.cmi: %.mli
+       $(OCAMLFIND) $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
+
+%.cmx: %.ml
+       $(OCAMLFIND) $(OCAMLOPT) $(OCAMLFLAGS) -c -o $@ $<
+
+%.o: %.c
+       $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+       sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+       ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore vhd META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+       ocamlfind remove vhd
+
+.PHONY: doc
+doc: $(INTF)
+       python ../doc/doc.py $(DOCDIR) "vhd" "package" "$(OBJS)" "." "" ""
+
+clean:
+       rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)

diff --git a/vhd/vhd.ml b/vhd/vhd.ml
new file mode 100644 (file)
index 0000000..16b1f98
--- /dev/null
+++ b/vhd/vhd.ml
@@ -0,0 +1,111 @@
+type vhd
+
+let dd_blk_unused = 0xFFFFFFFFL
+
+type open_flags = 
+       | Open_rdonly
+       | Open_rdwr
+       | Open_fast
+       | Open_strict
+       | Open_ignore_disabled
+       | Open_cached
+       | Open_io_write_sparse
+
+type create_flags =
+       | Flag_creat_file_size_fixed
+       | Flag_creat_parent_raw
+
+type vhd_type =
+       | Ty_none
+       | Ty_fixed
+       | Ty_dynamic 
+       | Ty_diff
+
+external __open : string -> int -> vhd = "stub_vhd_open"
+
+let _open file flags =
+       let flag_value = function 
+               | Open_rdonly -> 1
+               | Open_rdwr -> 2
+               | Open_fast -> 4
+               | Open_strict -> 8
+               | Open_ignore_disabled -> 16
+               | Open_cached -> 32
+               | Open_io_write_sparse -> 64
+       in
+       let flags_value = List.fold_left (+) 0 (List.map flag_value flags)  in
+       __open file flags_value
+
+let create_flags_value flags =
+       let flag_value = function
+               | Flag_creat_file_size_fixed -> 1
+               | Flag_creat_parent_raw -> 2
+       in
+       List.fold_left (+) 0 (List.map flag_value flags) 
+
+let create_ty_value ty =
+       match ty with
+               | Ty_none -> 0
+               | Ty_fixed -> 2
+               | Ty_dynamic -> 3
+               | Ty_diff -> 4
+
+external close : vhd -> unit = "stub_vhd_close"
+
+external _create : string -> int64 -> int -> int64 -> int -> unit = "stub_vhd_create"
+
+let create name bytes ty mbytes flags =
+       let flags_value = create_flags_value flags in
+       let ty_value = create_ty_value ty in
+       _create name bytes ty_value mbytes flags_value
+
+external _snapshot : string -> int64 -> string -> int64 -> int -> unit = "stub_vhd_snapshot"
+
+let snapshot name bytes parent mbytes flags =
+       let flags_value = create_flags_value flags in
+       _snapshot name bytes parent mbytes flags_value
+
+external get_phys_size : vhd -> int64 = "stub_vhd_get_phys_size"
+external get_uid : vhd -> string = "stub_vhd_get_uid"
+external get_max_bat_size : vhd -> int64 = "stub_vhd_get_max_bat_size"
+external get_parent_uid : vhd -> string = "stub_vhd_get_parent_uid"
+external get_parent : vhd -> string = "stub_vhd_get_parent"
+external get_virtual_size : vhd -> int64 = "stub_vhd_get_virtual_size"
+external _get_type : vhd -> int = "stub_vhd_get_type"
+
+let get_type vhd =
+       let ty = _get_type vhd in
+       match ty with
+               | 0 -> Ty_none
+               | 2 -> Ty_fixed
+               | 3 -> Ty_dynamic
+               | 4 -> Ty_diff
+               | _ -> failwith "Unknown VHD type"
+
+external get_creator : vhd -> string = "stub_vhd_get_creator"
+external get_hidden : vhd -> int = "stub_vhd_get_hidden"
+external set_hidden : vhd -> int -> unit = "stub_vhd_set_hidden"
+external set_phys_size : vhd -> int64 -> unit = "stub_vhd_set_phys_size"
+external set_virt_size : vhd -> int64 -> unit = "stub_vhd_set_virt_size"
+external coalesce : vhd -> unit = "stub_vhd_coalesce"
+external write_sector : vhd -> int64 -> string -> int = "stub_vhd_write_sector"
+external read_sector : vhd -> int64 -> string = "stub_vhd_read_sector"
+external set_log_level : int -> unit = "stub_vhd_set_log_level"
+external set_parent : vhd -> string -> bool -> unit = "stub_vhd_set_parent"
+external get_bat : vhd -> (int*int) list = "stub_vhd_get_bat"
+external _get_first_allocated_block : vhd -> int64 = "stub_vhd_get_first_allocated_block"
+
+let get_first_allocated_block vhd =
+       let blk = _get_first_allocated_block vhd in
+       if blk = dd_blk_unused then None else Some blk
+
+let with_vhd filename rw f =
+       let vhd = _open filename (if rw then [Open_rdwr] else [Open_rdonly]) in
+       try
+               let result = f vhd in
+               close vhd;
+               result
+       with e ->
+               close vhd;
+               raise e
+

diff --git a/vhd/vhd.mli b/vhd/vhd.mli
new file mode 100644 (file)
index 0000000..73afdf2
--- /dev/null
+++ b/vhd/vhd.mli
@@ -0,0 +1,46 @@
+type vhd
+
+val dd_blk_unused : int64
+
+type open_flags = 
+       | Open_rdonly
+       | Open_rdwr
+       | Open_fast
+       | Open_strict
+       | Open_ignore_disabled
+       | Open_cached
+       | Open_io_write_sparse
+
+type create_flags =
+       | Flag_creat_file_size_fixed
+       | Flag_creat_parent_raw
+
+type vhd_type =
+       | Ty_none
+       | Ty_fixed
+       | Ty_dynamic 
+       | Ty_diff
+
+val _open : string -> open_flags list -> vhd 
+val close : vhd -> unit
+val create : string -> int64 -> vhd_type -> int64 -> create_flags list -> unit 
+val snapshot : string -> int64 -> string -> int64 -> create_flags list -> unit
+val get_phys_size : vhd -> int64
+val get_uid : vhd -> string
+val get_max_bat_size : vhd -> int64 
+val get_parent_uid : vhd -> string 
+val get_parent : vhd -> string
+val get_virtual_size : vhd -> int64
+val get_type : vhd -> vhd_type
+val get_creator : vhd -> string
+val get_hidden : vhd -> int 
+val set_hidden : vhd -> int -> unit 
+val set_phys_size : vhd -> int64 -> unit
+val set_virt_size : vhd -> int64 -> unit
+val coalesce : vhd -> unit
+val write_sector : vhd -> int64 -> string -> int
+val read_sector : vhd -> int64 -> string
+val set_log_level : int -> unit
+val set_parent : vhd -> string -> bool -> unit
+val get_bat : vhd -> (int*int) list
+val get_first_allocated_block : vhd -> int64 option

diff --git a/vhd/vhd_stubs.c b/vhd/vhd_stubs.c
new file mode 100644 (file)
index 0000000..c83bd1a
--- /dev/null
+++ b/vhd/vhd_stubs.c
@@ -0,0 +1,543 @@
+#include <errno.h>
+#include <fcntl.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+
+#include <vhd/libvhd.h>
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/signals.h>
+
+#include "syslog.h"
+
+
+static struct custom_operations vhd_ops = {
+  "com.citrix.dci.vhd",
+  custom_finalize_default,
+  custom_compare_default,
+  custom_hash_default,
+  custom_serialize_default,
+  custom_deserialize_default
+};
+
+#define Vhd_val(v) (*((vhd_context_t **) Data_custom_val(v)))
+
+static value alloc_vhd(vhd_context_t *t)
+{
+  value v = alloc_custom(&vhd_ops, sizeof(vhd_context_t *), 0, 1);
+  Vhd_val(v)=t;
+  return v;
+}
+
+value stub_vhd_open(value name, value flags) 
+{
+  CAMLparam2(name,flags);
+  CAMLlocal1(vhd);
+  vhd_context_t *context = (vhd_context_t *)malloc(sizeof(vhd_context_t));
+  int ret = vhd_open(context,String_val(name),Int_val(flags));
+  if(ret!=0) {
+    caml_failwith("Failed to open VHD");
+  }
+  vhd=alloc_vhd(context);
+  CAMLreturn (vhd);
+}
+
+value stub_vhd_close(value vhd)
+{
+  CAMLparam1(vhd);
+  vhd_context_t *context=Vhd_val(vhd);
+  vhd_close(context);
+  free(context);
+  CAMLreturn (Val_unit);
+}
+  
+value stub_vhd_get_phys_size(value vhd)
+{
+  CAMLparam1(vhd);
+  vhd_context_t *context=Vhd_val(vhd);
+  off64_t phys_size;
+  vhd_get_phys_size(context, &phys_size);
+  CAMLreturn(caml_copy_int64(phys_size));
+}
+
+value stub_vhd_create(value name, value size, value type, value mbytes, value flags)
+{
+  CAMLparam5(name,size,type,mbytes,flags);
+  int ret = vhd_create(String_val(name),Int64_val(size),Int_val(type),Int64_val(mbytes),Int_val(flags));
+  if(ret != 0) {
+    caml_failwith("Failed to create VHD");
+  }
+  CAMLreturn (Val_unit);
+}
+
+value stub_vhd_snapshot(value snapshot, value size, value parent, value mbytes, value flags)
+{
+  CAMLparam5(snapshot,size,parent,mbytes,flags);
+  int ret = vhd_snapshot(String_val(snapshot),Int64_val(size),String_val(parent),Int64_val(mbytes),Int_val(flags));
+  if(ret != 0) {
+    caml_failwith("Failed to snapshot VHD");
+  }
+  CAMLreturn (Val_unit);
+}
+
+value stub_vhd_get_parent(value vhd)
+{
+  CAMLparam1(vhd);
+  char *parent=NULL;
+  int n,i,err;
+  vhd_parent_locator_t *loc;
+
+  vhd_context_t *context = Vhd_val(vhd);
+
+  if(context->footer.type != HD_TYPE_DIFF) {
+    caml_failwith("Disk is not a differencing disk");
+  }
+
+  n = vhd_parent_locator_count(context);
+  for (i = 0; i < n; i++) {
+       loc = context->header.loc + i;
+       if(loc->code == PLAT_CODE_MACX) {
+         err = vhd_parent_locator_read(context, loc, &parent);
+         if (err)
+               caml_failwith("vhd_parent_locator_read failed");
+       }
+  }
+
+  if(parent==NULL) {
+       caml_failwith("Failed to find a parent!");
+  }
+
+  CAMLreturn(caml_copy_string(parent));
+}
+
+value stub_vhd_get_uid(value vhd)
+{
+  CAMLparam1(vhd);
+  vhd_context_t *context = Vhd_val(vhd);
+  char uuid[256];
+  uuid_unparse_lower(context->footer.uuid,uuid);
+  CAMLreturn(caml_copy_string(uuid));
+}
+
+value stub_vhd_get_max_bat_size(value vhd)
+{
+  CAMLparam1(vhd);
+  vhd_context_t *context = Vhd_val(vhd);
+  CAMLreturn(caml_copy_int64(context->header.max_bat_size));
+}
+
+value stub_vhd_get_parent_uid(value vhd)
+{
+  CAMLparam1(vhd);
+  vhd_context_t *context = Vhd_val(vhd);
+  char uuid[256];
+  if(context->footer.type != HD_TYPE_DIFF) {
+    caml_failwith("Not a differencing disk");
+  }
+  uuid_unparse_lower(context->header.prt_uuid,uuid);
+  CAMLreturn(caml_copy_string(uuid));
+}
+
+value stub_vhd_get_type(value vhd)
+{
+  CAMLparam1(vhd);
+  vhd_context_t *context = Vhd_val(vhd);
+  CAMLreturn(Val_int(context->footer.type));
+}
+
+value stub_vhd_get_creator(value vhd)
+{
+  CAMLparam1(vhd);
+  vhd_context_t *context = Vhd_val(vhd);
+  char creator[5];
+  strncpy(creator,context->footer.crtr_app,4);
+  creator[4]='\0';
+  CAMLreturn(caml_copy_string(creator));
+}
+
+value stub_vhd_get_virtual_size(value vhd)
+{
+  CAMLparam1(vhd);
+  vhd_context_t *context = Vhd_val(vhd);
+  CAMLreturn(caml_copy_int64(context->footer.curr_size));
+}
+
+value stub_vhd_get_hidden(value vhd)
+{
+  CAMLparam1(vhd);
+  int hidden;
+  vhd_context_t *context = Vhd_val(vhd);
+  vhd_hidden(context,&hidden);
+  CAMLreturn(Val_int(hidden));
+}
+
+value stub_vhd_set_hidden(value vhd, value hidden)
+{
+  CAMLparam2(vhd,hidden);
+  vhd_context_t *context = Vhd_val(vhd);
+  context->footer.hidden = (char)Int_val(hidden);
+  int err = vhd_write_footer(context, &context->footer);
+  if(err) {
+    syslog(LOG_DAEMON | LOG_ERR, "set hidden failed: %d", err);
+    caml_failwith("Set hidden failed!");
+  }
+  CAMLreturn(Val_unit);
+}
+
+value stub_vhd_set_phys_size(value vhd, value ml_newsize)
+{
+  CAMLparam2(vhd,ml_newsize);
+  int err;
+  vhd_context_t *context = Vhd_val(vhd);
+  uint64_t newsize=Int64_val(ml_newsize);
+  err=vhd_set_phys_size(context, newsize);
+  if(err) {
+    syslog(LOG_DAEMON | LOG_ERR, "vhd_set_phys_size failed: %d", err);
+    caml_failwith("Set phys_size failed");
+  }
+  CAMLreturn(Val_unit);
+}
+
+value stub_vhd_set_virt_size(value vhd, value ml_newsize)
+{
+  CAMLparam2(vhd,ml_newsize);
+  int err;
+  vhd_context_t *context = Vhd_val(vhd);
+  uint64_t newsize=Int64_val(ml_newsize);
+  err=vhd_set_virt_size(context, newsize);
+  if(err) {
+    syslog(LOG_DAEMON | LOG_ERR, "vhd_set_virt_size failed: %d", err);
+    caml_failwith("Set virt_size failed");
+  }
+  CAMLreturn(Val_unit);
+}
+
+static int
+__raw_io_write(int fd, char* buf, uint64_t sec, uint32_t secs)
+{
+        off64_t off;
+        size_t ret;
+
+        errno = 0;
+        off = lseek64(fd, vhd_sectors_to_bytes(sec), SEEK_SET);
+        if (off == (off64_t)-1) {
+                printf("raw parent: seek(0x%08"PRIx64") failed: %d\n",
+                       vhd_sectors_to_bytes(sec), -errno);
+                return -errno;
+        }
+
+        ret = write(fd, buf, vhd_sectors_to_bytes(secs));
+        if (ret == vhd_sectors_to_bytes(secs))
+                return 0;
+
+        printf("raw parent: write of 0x%"PRIx64" returned %zd, errno: %d\n",
+               vhd_sectors_to_bytes(secs), ret, -errno);
+        return (errno ? -errno : -EIO);
+}
+
+/*
+ * Use 'parent' if the parent is VHD, and 'parent_fd' if the parent is raw
+ */
+static int
+vhd_util_coalesce_block(vhd_context_t *vhd, vhd_context_t *parent,
+                int parent_fd, uint64_t block)
+{
+        int i, err;
+        char *buf, *map;
+        uint64_t sec, secs;
+
+        buf = NULL;
+        map = NULL;
+        sec = block * vhd->spb;
+
+        if (vhd->bat.bat[block] == DD_BLK_UNUSED)
+                return 0;
+
+        err = posix_memalign((void **)&buf, 4096, vhd->header.block_size);
+        if (err)
+                return -err;
+
+        err = vhd_io_read(vhd, buf, sec, vhd->spb);
+        if (err)
+                goto done;
+
+        if (vhd_has_batmap(vhd) && vhd_batmap_test(vhd, &vhd->batmap, block)) {
+                if (parent->file)
+                        err = vhd_io_write(parent, buf, sec, vhd->spb);
+                else
+                        err = __raw_io_write(parent_fd, buf, sec, vhd->spb);
+                goto done;
+        }
+
+        err = vhd_read_bitmap(vhd, block, &map);
+        if (err)
+                goto done;
+
+        for (i = 0; i < vhd->spb; i++) {
+                if (!vhd_bitmap_test(vhd, map, i))
+                        continue;
+
+                for (secs = 0; i + secs < vhd->spb; secs++)
+                        if (!vhd_bitmap_test(vhd, map, i + secs))
+                                break;
+
+                if (parent->file)
+                        err = vhd_io_write(parent,
+                                           buf + vhd_sectors_to_bytes(i),
+                                           sec + i, secs);
+                else
+                        err = __raw_io_write(parent_fd,
+                                             buf + vhd_sectors_to_bytes(i),
+                                             sec + i, secs);
+                if (err)
+                        goto done;
+
+                i += secs;
+        }
+
+        err = 0;
+
+done:
+        free(buf);
+        free(map);
+        return err;
+}
+
+value stub_vhd_coalesce(value vhd) 
+{
+  CAMLparam1(vhd);
+  vhd_context_t *context = Vhd_val(vhd);
+  vhd_context_t parent;
+  char uuid[37];
+  char *pname;
+  int err,i;
+  int parent_fd=-1;
+
+  parent.file = NULL;
+
+  uuid_unparse(context->footer.uuid,uuid);
+
+  caml_enter_blocking_section();
+
+  err=vhd_parent_locator_get(context, &pname);
+  if(err) {
+    syslog(LOG_DAEMON | LOG_ERR, "Error finding %s parent: %d", uuid, err);
+    caml_failwith("Couldn't find parent");
+  }
+
+  if( vhd_parent_raw(context)) {
+    parent_fd = open(pname, O_RDWR | O_DIRECT | O_LARGEFILE, 0644);
+    if(parent_fd == -1) {
+      err = - errno;
+      syslog(LOG_DAEMON | LOG_ERR, "Failed to open raw parent %s: %d",pname,err);
+      free(pname);
+      caml_failwith("Couldn't open parent");
+    }
+  } else {
+    err = vhd_open(&parent,pname,VHD_OPEN_RDWR);
+    if(err) {
+      syslog(LOG_DAEMON | LOG_ERR, "Failed to open vhd parent %s: %d",pname,err);
+      free(pname);
+      caml_failwith("Couldn't open parent");
+    }
+  }
+
+  err=vhd_get_bat(context);
+  if(err)
+    goto done;
+
+  if(vhd_has_batmap(context)) {
+    err = vhd_get_batmap(context);
+    if (err)
+      goto done;
+  }
+
+  for(i=0; i<context->bat.entries; i++) {
+    err=vhd_util_coalesce_block(context,&parent,parent_fd,i);
+    if(err)
+      goto done;
+  }
+
+  err=0;
+
+ done:
+  free(pname);
+  if(parent.file)
+    vhd_close(&parent);
+  else
+    close(parent_fd);
+
+  caml_leave_blocking_section();
+  
+  CAMLreturn (Val_unit);
+}
+
+value stub_vhd_write_sector(value vhd, value ml_sectorno, value ml_string)
+{
+  CAMLparam3(vhd, ml_sectorno, ml_string);
+  uint64_t sectorno=Int64_val(ml_sectorno);
+  if(caml_string_length(ml_string)!=512) 
+    caml_failwith("Require string to be of length 512");
+  vhd_context_t *context = Vhd_val(vhd);
+  char *buf;
+  int err;
+
+  err = posix_memalign((void **)&buf, 4096, context->header.block_size);
+
+  if(err) {
+    syslog(LOG_INFO, "error with the posix_memalign: %d", err);
+    caml_failwith("Error with the posix memalign");
+  }
+
+  memcpy(buf,String_val(ml_string),512);
+
+  caml_enter_blocking_section();
+
+  err = vhd_get_bat(context);
+
+  if(err) {
+    syslog(LOG_INFO, "error getting bat: %d", err);
+    caml_leave_blocking_section();
+    caml_failwith("Error getting BAT");
+  }
+
+  err = vhd_io_write(context, buf, sectorno, 1);
+
+  if(err) {
+    syslog(LOG_INFO, "error performing write: %d", err);
+    caml_leave_blocking_section();
+    caml_failwith("Error performing write");
+  }
+
+  syslog(LOG_INFO, "string='%s', sectorno=%Ld, err=%d", buf, sectorno, err);
+
+  caml_leave_blocking_section();
+
+  CAMLreturn(Val_int(err));
+}
+
+value stub_vhd_read_sector(value vhd, value ml_sectorno)
+{
+  CAMLparam2(vhd,ml_sectorno);
+  CAMLlocal1(returnstr);
+  char buf[512];
+  uint64_t sectorno=Int64_val(ml_sectorno);
+  vhd_context_t *context = Vhd_val(vhd);
+  int err;
+  
+  caml_enter_blocking_section();
+  err = vhd_io_read(context, buf, sectorno, 1);
+  caml_leave_blocking_section();
+
+  returnstr=caml_alloc_string(512);
+  memcpy(String_val(returnstr),buf,512);
+  CAMLreturn(returnstr);  
+}
+
+value stub_vhd_set_log_level(value level)
+{
+  CAMLparam1(level);
+  libvhd_set_log_level(Int_val(level));
+  CAMLreturn(Val_unit);
+}
+
+value stub_vhd_set_parent(value vhd, value ml_new_parent, value ml_new_parent_is_raw)
+{
+  CAMLparam3(vhd, ml_new_parent, ml_new_parent_is_raw);
+  char *new_parent = strdup(String_val(ml_new_parent));
+  int new_parent_is_raw = 0;
+  vhd_context_t *context = Vhd_val(vhd);
+  int err;
+
+  if(Bool_val(ml_new_parent_is_raw))
+       new_parent_is_raw=1;
+
+  caml_enter_blocking_section();
+  err=vhd_change_parent(context, new_parent, new_parent_is_raw);
+  if(err) {
+    syslog(LOG_INFO, "error performing setting parent: %d", err);
+  }
+  caml_leave_blocking_section();
+
+  CAMLreturn(Val_unit);
+}
+
+/* Return a run-length encoded list of allocated blocks */
+value stub_vhd_get_bat(value vhd)
+{
+  CAMLparam1(vhd);
+  CAMLlocal3(list,tmp,pair);
+  vhd_context_t *context = Vhd_val(vhd);
+  int state=0;
+  int len=0;
+  int i;
+  int max = context->footer.curr_size >> 21;
+
+  int err = vhd_get_bat(context);
+
+  syslog(LOG_DAEMON | LOG_ERR, "stub_vhd_get_bat: max=%d",max);
+
+  if(err != 0) {
+    caml_failwith("Failed to get BAT");
+  }
+
+  list = Val_int(0);
+
+  for(i=0; i<max; i++) {
+    if(state==0) {
+      if(context->bat.bat[i] != DD_BLK_UNUSED) {
+        state=1;
+        pair = caml_alloc(2,0);
+        Store_field(pair,0,Val_int(i));
+        len=1;            
+      }
+    } else if(state==1) {
+      if(context->bat.bat[i] == DD_BLK_UNUSED) {
+        Store_field(pair,1,Val_int(len));
+        tmp = caml_alloc(2,0);
+        Store_field(tmp,0,pair);
+        Store_field(tmp,1,list);
+        list=tmp;
+        state=0;
+        len=0;
+      } else {
+        len++;
+      }
+    }
+  }
+
+  if(state==1) {
+    Store_field(pair,1,Val_int(len));
+    tmp = caml_alloc(2,0);
+    Store_field(tmp,0,pair);
+    Store_field(tmp,1,list);
+    list=tmp;
+  }
+
+
+  CAMLreturn(list);
+}
+
+value stub_vhd_get_first_allocated_block(value vhd)
+{
+  CAMLparam1(vhd);
+  vhd_context_t *context = Vhd_val(vhd);
+  uint64_t firstblock=DD_BLK_UNUSED;
+  int i,max,err;
+
+  max = context->footer.curr_size >> 21;
+  err = vhd_get_bat(context);
+  
+  for(i=0; i<max; i++) {
+    if(context->bat.bat[i]<firstblock) {
+      firstblock=context->bat.bat[i];
+    }
+  }  
+
+  CAMLreturn(caml_copy_int64(firstblock));
+}

diff --git a/xapi-libs.spec b/xapi-libs.spec
index a7cb12fb64e3987190ae03733ea7393df5422755..8b59d6574aebaefdb6f6002de25c092423e16bf4 100644 (file)
--- a/xapi-libs.spec
+++ b/xapi-libs.spec
@@ -267,6 +267,14 @@ rm -rf $RPM_BUILD_ROOT
    /usr/lib/ocaml/xml-light2/xml-light2.cmxa
    /usr/lib/ocaml/xml-light2/xml.cmi
    /usr/lib/ocaml/xml-light2/xml.cmx
+   /usr/lib/ocaml/vhd/META
+   /usr/lib/ocaml/vhd/dllvhd_stubs.so
+   /usr/lib/ocaml/vhd/libvhd_stubs.a
+   /usr/lib/ocaml/vhd/vhd.a
+   /usr/lib/ocaml/vhd/vhd.cma
+   /usr/lib/ocaml/vhd/vhd.cmi
+   /usr/lib/ocaml/vhd/vhd.cmx
+   /usr/lib/ocaml/vhd/vhd.cmxa
 
 %exclude /usr/lib/ocaml/close-and-exec/closeandexec_main.cmx
 %exclude /usr/lib/ocaml/pciutil/pciutil_main.cmx