# HG changeset patch # User Jonathan Ludlam # Date 1261408275 0 # Node ID 820f16fdbb7d6069828d84ff48ddb9476b57b693 # Parent 71d488cbcda8e2fa2ce316e4637fd530b45944f7 Use rpc-light to marshal/unmarshal camldm device-mapper tables rather than the Marshal module diff -r 71d488cbcda8 -r 820f16fdbb7d camldm/META.in --- a/camldm/META.in Mon Dec 21 15:11:15 2009 +0000 +++ b/camldm/META.in Mon Dec 21 15:11:15 2009 +0000 @@ -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 -r 71d488cbcda8 -r 820f16fdbb7d camldm/Makefile --- a/camldm/Makefile Mon Dec 21 15:11:15 2009 +0000 +++ b/camldm/Makefile Mon Dec 21 15:11:15 2009 +0000 @@ -3,6 +3,8 @@ 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 @@ DOCDIR = /myrepos/xen-api-libs.hg/doc +OCAMLFLAGS = -pp '${FEPP}' -I ../rpc-light + + all: $(INTF) $(LIBS) $(PROGRAMS) bins: $(PROGRAMS) @@ -25,10 +30,10 @@ 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 @@ 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 @@ .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 -r 71d488cbcda8 -r 820f16fdbb7d camldm/camldm.ml --- a/camldm/camldm.ml Mon Dec 21 15:11:15 2009 +0000 +++ b/camldm/camldm.ml Mon Dec 21 15:11:15 2009 +0000 @@ -16,27 +16,27 @@ | 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 @@ 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 @@ (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 (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 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 -r 71d488cbcda8 -r 820f16fdbb7d camldm/camldm.mli --- a/camldm/camldm.mli Mon Dec 21 15:11:15 2009 +0000 +++ b/camldm/camldm.mli Mon Dec 21 15:11:15 2009 +0000 @@ -30,18 +30,18 @@ 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 -r 71d488cbcda8 -r 820f16fdbb7d camldm/camldm_stubs.c --- a/camldm/camldm_stubs.c Mon Dec 21 15:11:15 2009 +0000 +++ b/camldm/camldm_stubs.c Mon Dec 21 15:11:15 2009 +0000 @@ -39,8 +39,10 @@ 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