Use rpc-light to marshal/unmarshal camldm device-mapper tables rather than the Marsha...

Signed-off-by: Jon Ludlam <Jonathan.Ludlam@eu.citrix.com>

diff --git a/camldm/META.in b/camldm/META.in
index 65c8d30f0922b439a951a990424a43c820d4c1dc..44a406025162ce190c7f9ed9f256284ef514a6c7 100644 (file)
--- a/camldm/META.in
+++ b/camldm/META.in
@@ -1,5 +1,5 @@
 version = "@VERSION@"
 description = "device-mapper ocaml interface"
-requires = "unix"
+requires = "unix,jsonrpc"
 archive(byte) = "camldm.cma"
 archive(native) = "camldm.cmxa"

diff --git a/camldm/Makefile b/camldm/Makefile
index ce2c79fb86a0e4722afa30ce3618b10ef63c0579..2d6217237b694f0448bd17f04af3d28ef43b44d2 100644 (file)
--- a/camldm/Makefile
+++ b/camldm/Makefile
@@ -3,6 +3,8 @@ CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
 OCAMLC = ocamlc -g
 OCAMLOPT = ocamlopt
 
+FEPP = camlp4o -I ../rpc-light -I $(shell ocamlfind query type-conv) pa_type_conv.cmo pa_rpc.cma
+
 LDFLAGS = -cclib -L./
 
 VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
@@ -18,6 +20,9 @@ LIBS = camldm.cma camldm.cmxa
 
 DOCDIR = /myrepos/xen-api-libs.hg/doc
 
+OCAMLFLAGS = -pp '${FEPP}' -I ../rpc-light
+
+
 all: $(INTF) $(LIBS) $(PROGRAMS)
 
 bins: $(PROGRAMS)
@@ -25,10 +30,10 @@ bins: $(PROGRAMS)
 libs: $(LIBS)
 
 camldm.cmxa: libcamldm_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
-       $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lcamldm_stubs -cclib -ldevmapper $(foreach obj,$(OBJS),$(obj).cmx)
+       $(OCAMLOPT) $(OCAMLFLAGS) -a -o $@ -cclib -lcamldm_stubs -cclib -ldevmapper $(foreach obj,$(OBJS),$(obj).cmx)
 
 camldm.cma: $(foreach obj,$(OBJS),$(obj).cmo)
-       $(OCAMLC) -a -dllib dllcamldm_stubs.so -cclib -lcamldm_stubs -cclib -ldevmapper -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+       $(OCAMLC) $(OCAMLFLAGS) -a -dllib dllcamldm_stubs.so -cclib -lcamldm_stubs -cclib -ldevmapper -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
 
 camldm_stubs.a: camldm_stubs.o
        ocamlmklib -o camldm_stubs -ldevmapper $+
@@ -38,13 +43,13 @@ libcamldm_stubs.a: camldm_stubs.o
        ocamlmklib -o camldm_stubs -ldevmapper $+
 
 %.cmo: %.ml
-       $(OCAMLC) -c -o $@ $<
+       $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
 
 %.cmi: %.mli
-       $(OCAMLC) -c -o $@ $<
+       $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
 
 %.cmx: %.ml
-       $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+       $(OCAMLOPT) $(OCAMLFLAGS) -c -o $@ $<
 
 %.o: %.c
        $(CC) $(CFLAGS) -c -o $@ $<
@@ -65,6 +70,6 @@ uninstall:
 .PHONY: doc
 doc: $(INTF)
        python ../doc/doc.py $(DOCDIR) "camldm" "package" "$(OBJS)" "." "" ""
-       
+
 clean:
        rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)

diff --git a/camldm/camldm.ml b/camldm/camldm.ml
index 9ebe4496d5edf43424f45748438a8ed25b8019cc..dffcc9efa54a1d40a1cf68a4b26d981654eae80e 100644 (file)
--- a/camldm/camldm.ml
+++ b/camldm/camldm.ml
@@ -16,27 +16,27 @@ type devty =
     | Dereferenced of string (* e.g. PV id *)
     | Real of string (* device *)
        
-type dev = {
+and dev = {
   device : devty;
   offset : int64;
 }
     
-type stripety = {
+and stripety = {
   chunk_size : int64;  (* In sectors - must be a power of 2 and at least as large as the system's PAGE_SIZE *)
   dests : dev array;
 }
 
-type mapty = 
+and mapty = 
     | Linear of dev (* Device, offset *)
     | Striped of stripety
 
-type mapping = {
+and mapping = {
   start : int64;
   len : int64; 
   map : mapty;
 }
 
-type status = {
+and status = {
   exists : bool;
   suspended : bool;
   live_table : bool;
@@ -47,7 +47,18 @@ type status = {
   minor : int32;
   read_only : bool;
   targets : (int64 * int64 * string * string) list
+} 
+
+and mapping_array = {
+  m : mapping array 
+} 
+
+and create_error_t = {
+  c : (int64 * int64 * string * string) array
 }
+with rpc
+
+
 
 external _create : string -> (int64 * int64 * string * string) array -> unit = "camldm_create"
 external _reload : string -> (int64 * int64 * string * string) array -> unit = "camldm_reload"
@@ -77,8 +88,11 @@ let convert_mapty m deref_table =
              (Array.map (fun dev -> 
                Printf.sprintf "%s %Ld" (resolve_device dev.device deref_table) dev.offset) st.dests))
 
-exception CreateError of (int64 * int64 * string * string) array
-exception ReloadError of (int64 * int64 * string * string) array
+exception CreateError of string
+exception ReloadError of string
+
+let to_string m = Jsonrpc.to_string (rpc_of_mapping_array {m=m})
+let of_string s = (mapping_array_of_rpc (Jsonrpc.of_string s)).m
  
 let _writemap dev map =
   let oc = open_out (Printf.sprintf "/tmp/%s.map" dev) in
@@ -90,23 +104,23 @@ let _getmap map dereference_table =
     let (ty,params) = convert_mapty m.map dereference_table in
     (m.start, m.len, ty, params)) map 
     
-let create dev map ?(dereference_table=[]) =
+let create dev map dereference_table =
   let newmap = _getmap map dereference_table in
   try 
     _writemap dev newmap;
     _create dev newmap
-  with e ->
-    raise (CreateError newmap)
+  with Failure x ->
+    raise (CreateError x)
       
-let reload dev map ?(dereference_table=[]) =
+let reload dev map dereference_table =
   let newmap = _getmap map dereference_table in
   try 
     _writemap dev newmap;
     _reload dev newmap
-  with e ->
-    raise (ReloadError newmap)
+  with Failure x ->
+    raise (ReloadError x)
 
-let get_sector_pos_of map sector ~dereference_table =
+let get_sector_pos_of map sector dereference_table =
   match map.map with 
     | Linear l -> (resolve_device l.device dereference_table, Int64.add l.offset sector)
     | Striped s ->
@@ -127,5 +141,3 @@ let mknods = _mknods
 let mknod = _mknod
 let suspend = _suspend
 let resume = _resume 
-let to_string (m : mapping array) = Marshal.to_string m []
-let of_string s = (Marshal.from_string s 0 : mapping array)

diff --git a/camldm/camldm.mli b/camldm/camldm.mli
index f08896034fd1e911e0882bd510f369726b1a8648..fc57112f1683face8fb1e13fc3c27b303d63cc37 100644 (file)
--- a/camldm/camldm.mli
+++ b/camldm/camldm.mli
@@ -30,18 +30,18 @@ type status = {
   targets : (int64 * int64 * string * string) list;
 }
 
-exception CreateError of (int64 * int64 * string * string) array
-exception ReloadError of (int64 * int64 * string * string) array
+exception CreateError of string
+exception ReloadError of string
 
 val convert_mapty : mapty -> (string * string) list -> string * string
-val create : string -> mapping array -> ?dereference_table : (string * string) list -> unit
-val reload : string -> mapping array -> ?dereference_table : (string * string) list -> unit
+val create : string -> mapping array -> (string * string) list -> unit
+val reload : string -> mapping array -> (string * string) list -> unit
 val suspend : string -> unit
 val resume : string -> unit
 val remove : string -> unit
 val table : string -> status
 val mknods : string -> unit
 val mknod : string -> int -> int -> int -> unit
-val get_sector_pos_of : mapping -> int64 -> dereference_table:(string * string) list -> string * int64
+val get_sector_pos_of : mapping -> int64 -> (string * string) list -> string * int64
 val to_string : mapping array -> string
 val of_string : string -> mapping array

diff --git a/camldm/camldm_stubs.c b/camldm/camldm_stubs.c
index e49120abeb172bc89e032e417c26df33b9bc47f3..015ea2f70ef7a4be11e223ddadc2c434c8d320bc 100644 (file)
--- a/camldm/camldm_stubs.c
+++ b/camldm/camldm_stubs.c
@@ -39,8 +39,10 @@ void camldm_create(value name, value map)
   if(!(dmt = dm_task_create(DM_DEVICE_CREATE)))
     caml_failwith("Failed to create task!");
 
-  if(!dm_task_set_name(dmt, String_val(name))) 
-    goto out;
+  if(!dm_task_set_name(dmt, String_val(name))) {
+    dm_task_destroy(dmt);
+    caml_failwith("Failed to set name");
+  }
 
   for(i=0; i<Wosize_val(map); i++) {
     start=Int64_val(Field(Field(map,i),0));
@@ -50,19 +52,17 @@ void camldm_create(value name, value map)
 
     printf("%" PRIu64 " %" PRIu64 " %s %s\n", start, size, ty, params);
 
-    if(!dm_task_add_target(dmt, start, size, ty, params))
-      goto out;
+    if(!dm_task_add_target(dmt, start, size, ty, params)) {
+      dm_task_destroy(dmt);
+      caml_failwith("Failed to add target");
+    }
+  }
+  
+  if(!dm_task_run(dmt)) {
+    dm_task_destroy(dmt);
+    caml_failwith("Failed to run task");
   }
   
-  if(!dm_task_run(dmt))
-    goto out;
-
-  goto win;
-
- out:
-  dm_task_destroy(dmt);
-  caml_failwith("Failed!");
-
  win:
   CAMLreturn0;  
 }