This includes: - Tag.t type, which encapsulates tag strings; - use of Tag.t consistently throughout the repository; - a simplified mlvm/Makefile; - a simple unit test for checking Tag.is_valid.
signed-off-by: Rok Strnisa <[email protected]> mlvm/Makefile | 120 +++++++++++++++++++++------------------------ mlvm/lv.ml | 5 +- mlvm/redo.ml | 48 +++++++++--------- mlvm/tag.ml | 14 +++++ mlvm/tag.mli | 13 ++++ mlvm/tag_is_valid_test.ml | 13 ++++ mlvm/test_fragment.ml | 2 +- mlvm/vg.ml | 120 ++++++++++++++++++++++----------------------- 8 files changed, 183 insertions(+), 152 deletions(-)
# HG changeset patch # User Rok Strnisa <[email protected]> # Date 1276527119 -3600 # Node ID 1c7a412b69d30b5a3add95b739de020ee1d5a774 # Parent 2de29dee356ced22e0cdcfc8822071d96c7c2dfa Added support for LV tags. (guards: +rok +matthias) This includes: - Tag.t type, which encapsulates tag strings; - use of Tag.t consistently throughout the repository; - a simplified mlvm/Makefile; - a simple unit test for checking Tag.is_valid. signed-off-by: Rok Strnisa <[email protected]> diff --git a/mlvm/Makefile b/mlvm/Makefile --- a/mlvm/Makefile +++ b/mlvm/Makefile @@ -1,75 +1,62 @@ - -CC = gcc -CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml -LDFLAGS = -cclib -L./ -VERSION = 0.1 - -PP = camlp4o -I ../rpc-light -I $(shell ocamlfind query type-conv) pa_type_conv.cmo pa_rpc.cma - -DESTDIR ?= / VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0) -OCAMLABI := $(shell ocamlc -version) -OCAMLLIBDIR := $(shell ocamlc -where) -OCAMLDESTDIR ?= $(OCAMLLIBDIR) +OCAMLC = ocamlfind ocamlc -g +OCAMLOPT = ocamlfind ocamlopt +OCAMLYACC = ocamlyacc +OCAMLLEX = ocamllex +PP = camlp4o -I ../rpc-light -I $(shell ocamlfind query type-conv) pa_type_conv.cmo pa_rpc.cma +COMPFLAG = -dtypes -g -I ../stdext -I ../camldm -I ../uuid -I ../rpc-light -for-pack Lvm -pp '${PP}' -LIBOBJS = constants lvm_uuid crc utils absty lvmconfigparser lvmconfiglex lvmmarshal allocator debug redo lv pv vg -INTF = $(foreach obj, $(LIBOBJS),$(obj).cmi) -CMDOBJS = messages.cmx mlvm.cmx -OCAMLC = ocamlfind ocamlc -g -OCAMLOPT = ocamlfind ocamlopt -COMPFLAG = -dtypes -g -I ../stdext -I ../camldm -I ../uuid -for-pack Lvm -pp '${PP}' -I ../rpc-light +LIBOBJS = constants lvm_uuid crc utils absty lvmconfigparser lvmconfiglex lvmmarshal allocator debug tag redo lv pv vg +LIBCMXS = $(foreach obj, $(LIBOBJS),$(obj).cmx) +LIBCMOS = $(foreach obj, $(LIBOBJS),$(obj).cmo) +LIBCMIS = $(foreach obj, $(LIBOBJS),$(obj).cmi) + +DESTDIR ?= +DOCDIR = /myrepos/xen-api-libs.hg/doc LIBS = lvm.cma lvm.cmxa -DOCDIR = /myrepos/xen-api-libs.hg/doc +default: $(LIBS) -default : $(LIBS) +lvm.cmx: $(LIBCMXS) + $(OCAMLOPT) -pack -g -o $@ $^ -test_allocator: default - $(OCAMLOPT) -package kaputt -linkpkg -dtypes -g -I ../stdext -I ../camldm -I ../uuid -I +kaputt unix.cmxa ../rpc-light/rpc.cmx ../rpc-light/jsonrpc.cmx ../camldm/camldm.cmxa ../uuid/uuid.cmxa ../stdext/stdext.cmxa ./lvm.cmxa test_allocator.ml -o $@ - -lvm.cmx: $(foreach obj,$(LIBOBJS),$(obj).cmx) - $(OCAMLOPT) -pack -g -o $@ $(foreach obj,$(LIBOBJS),$(obj).cmx) - -lvm.cmo: $(foreach obj,$(LIBOBJS),$(obj).cmo) - $(OCAMLC) -pack -g -o $@ $(foreach obj,$(LIBOBJS),$(obj).cmo) +lvm.cmo: $(LIBCMOS) + $(OCAMLC) -pack -g -o $@ $^ lvm.cmxa: lvm.cmx - $(OCAMLOPT) -a -g -o $@ lvm.cmx + $(OCAMLOPT) -a -g -o $@ $^ lvm.cma: lvm.cmo - $(OCAMLC) -a -g -o $@ lvm.cmo + $(OCAMLC) -a -g -o $@ $^ + +lvmconfigparser.ml: lvmconfigparser.mly + $(OCAMLYACC) $< + $(OCAMLOPT) $(COMPFLAG) -c lvmconfigparser.mli + +lvmconfiglex.ml: lvmconfiglex.mll lvmconfigparser.mli + $(OCAMLLEX) $< META: META.in sed 's/@VERSION@/$(VERSION)/g' < $< > $@ -.PHONY: install +.PHONY: install uninstall doc clean install: $(LIBS) META ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore lvm META lvm.cmi lvm.cmxa lvm.cma lvm.a -.PHONY: uninstall uninstall: ocamlfind remove lvm -clean : - rm -f *.cmo *.cmi *.cmx *.o *~ *.annot lvmconfiglex.ml \ - lvmconfigparser.mli lvmconfigparser.ml - rm -f test_allocator test_fragment +doc: $(LIBCMIS) + python ../doc/doc.py $(DOCDIR) "mlvm" "package" "$(LIBOBJS)" "." "stdext,camldm,uuid,unix" "" -.PHONY: doc -doc: $(INTF) - python ../doc/doc.py $(DOCDIR) "mlvm" "package" "$(LIBOBJS)" "." "stdext,camldm,uuid,unix" "" - -lvmconfigparser.ml : lvmconfigparser.mly - ocamlyacc lvmconfigparser.mly - $(OCAMLOPT) $(COMPFLAG) -c lvmconfigparser.mli - -lvmconfiglex.ml : lvmconfiglex.mll lvmconfigparser.mli - ocamllex lvmconfiglex.mll +clean: + rm -f *.cm{o,i,x} *.{annot,o} *~ + rm -f lvmconfiglex.ml lvmconfigparser.ml{,i} + rm -f test_allocator test_fragment tag_is_valid_test .SUFFIXES: .ml .mli .cmo .cmi .cmx - .ml.cmo: $(OCAMLC) $(COMPFLAG) -c $< @@ -79,21 +66,28 @@ lvmconfiglex.ml : lvmconfiglex.mll lvmco .ml.cmx: $(OCAMLOPT) $(COMPFLAG) -c $< -.c.o: - $(OCAMLC) $(COMPFLAG) -c $< +lvmcmd.cmo: messages.cmo +lvmcmd.cmx: messages.cmx +lv.cmo: absty.cmo +lv.cmx: absty.cmx +mlvm.cmo: vg.cmo pv.cmo messages.cmo lv.cmo +mlvm.cmx: vg.cmx pv.cmx messages.cmx lv.cmx +pv.cmo: utils.cmo lvmmarshal.cmo lvm_uuid.cmo crc.cmo constants.cmo allocator.cmo absty.cmo +pv.cmx: utils.cmx lvmmarshal.cmx lvm_uuid.cmx crc.cmx constants.cmx allocator.cmx absty.cmx +vg.cmo: debug.cmo pv.cmo lvm_uuid.cmo lv.cmo allocator.cmo absty.cmo +vg.cmx: debug.cmx pv.cmx lvm_uuid.cmx lv.cmx allocator.cmx absty.cmx +redo.cmo: tag.cmi debug.cmo allocator.cmo +redo.cmx: tag.cmx debug.cmx allocator.cmx +tag.cmo: debug.cmo tag.cmi +tag.cmx: debug.cmx tag.cmi -lvmcmd.cmo: messages.cmo -lvmcmd.cmx: messages.cmx -lv.cmo: absty.cmo -lv.cmx: absty.cmx -mlvm.cmo: vg.cmo pv.cmo messages.cmo lv.cmo -mlvm.cmx: vg.cmx pv.cmx messages.cmx lv.cmx -pv.cmo: utils.cmo lvmmarshal.cmo lvm_uuid.cmo crc.cmo constants.cmo \ - allocator.cmo absty.cmo -pv.cmx: utils.cmx lvmmarshal.cmx lvm_uuid.cmx crc.cmx constants.cmx \ - allocator.cmx absty.cmx -vg.cmo: debug.cmo pv.cmo lvm_uuid.cmo lv.cmo allocator.cmo absty.cmo -vg.cmx: debug.cmx pv.cmx lvm_uuid.cmx lv.cmx allocator.cmx absty.cmx +test_allocator: default + $(OCAMLOPT) -package kaputt -linkpkg -dtypes -g -I ../stdext -I ../camldm -I ../uuid -I +kaputt $(INCLUDES) ./lvm.cmxa test_allocator.ml -o $@ -test_fragment: default $(foreach obj,$(LIBOBJS),$(obj).cmx) - $(OCAMLOPT) -linkpkg -dtypes -g -I ../stdext -I ../camldm -I ../uuid unix.cmxa ../rpc-light/rpc.cmx -I ../rpc-light ../rpc-light/jsonrpc.cmx ../camldm/camldm.cmxa ../uuid/uuid.cmxa ../stdext/stdext.cmxa ./lvm.cmxa $(foreach obj,$(LIBOBJS),$(obj).cmx) test_fragment.ml -o $@ \ No newline at end of file +INCLUDES = unix.cmxa str.cmxa ../rpc-light/rpc.cmx ../rpc-light/jsonrpc.cmx ../camldm/camldm.cmxa ../uuid/uuid.cmxa ../stdext/stdext.cmxa + +test_fragment: lvm.cmxa $(LIBCMXS) test_fragment.ml + $(OCAMLOPT) $(COMPFLAG) $(INCLUDES) $^ -o $@ + +tag_is_valid_test: $(LIBCMXS) tag.cmx tag_is_valid_test.ml + $(OCAMLOPT) $(COMPFLAG) $(INCLUDES) $^ -o $@ \ No newline at end of file diff --git a/mlvm/lv.ml b/mlvm/lv.ml --- a/mlvm/lv.ml +++ b/mlvm/lv.ml @@ -1,4 +1,5 @@ open Absty +open Fun open Listext type stat = @@ -28,7 +29,7 @@ and segment = and logical_volume = { name : string; id : string; - tags : string list; + tags : Tag.t list; status : stat list; segments : segment list; } with rpc @@ -54,7 +55,7 @@ let write_to_buffer b lv = bprintf b "\n%s {\nid = \"%s\"\nstatus = [%s]\n" lv.name lv.id (String.concat ", " (List.map (o quote status_to_string) lv.status)); if List.length lv.tags > 0 then - bprintf b "tags = [%s]\n" (String.concat ", " (List.map quote lv.tags)); + bprintf b "tags = [%s]\n" (String.concat ", " (List.map (quote ++ Tag.string_of) lv.tags)); bprintf b "segment_count = %d\n\n" (List.length lv.segments); Listext.List.iteri (fun i s -> diff --git a/mlvm/redo.ml b/mlvm/redo.ml --- a/mlvm/redo.ml +++ b/mlvm/redo.ml @@ -1,3 +1,4 @@ +open Debug type lvcreate_t = { lvc_id : string; @@ -15,21 +16,21 @@ and lvreduce_t = { and lvexpand_t = { lvex_segments : Allocator.t; } - + +(** First string corresponds to the name of the LV. *) and operation = - | LvCreate of string * lvcreate_t - | LvReduce of string * lvreduce_t - | LvExpand of string * lvexpand_t - | LvRename of string * lvrename_t - | LvRemove of string + | LvCreate of string * lvcreate_t + | LvReduce of string * lvreduce_t + | LvExpand of string * lvexpand_t + | LvRename of string * lvrename_t + | LvRemove of string + | LvAddTag of string * Tag.t and sequenced_op = { so_seqno : int; so_op : operation } with rpc -open Debug - (** Marshal to and from a string *) let redo_to_string (l : sequenced_op) = let s = Marshal.to_string l [] in @@ -98,20 +99,19 @@ let read fd offset size = let reset fd offset = write_initial_pos fd offset (Int64.add offset 12L) - + +(** Converts the redo operation to a human-readable string. *) let redo_to_human_readable op = - let lvcreate_t_to_string l = - Printf.sprintf "{id:'%s', segments:[%s]}" l.lvc_id (Allocator.to_string l.lvc_segments) - in - let lvexpand_t_to_string l = - Printf.sprintf "[%s]" (Allocator.to_string l.lvex_segments) - in - let opstr = - match op.so_op with - | LvCreate (name,lvc) -> Printf.sprintf "LvCreate(%s,%s)" name (lvcreate_t_to_string lvc) - | LvRemove name -> Printf.sprintf "LvRemove(%s)" name - | LvReduce (name,lvrd) -> Printf.sprintf "LvReduce(%s,%Ld)" name lvrd.lvrd_new_extent_count - | LvExpand (name,lvex) -> Printf.sprintf "LvExpand(%s,%s)" name (lvexpand_t_to_string lvex) - | LvRename (name,lvmv) -> Printf.sprintf "LvRename(%s,%s)" name lvmv.lvmv_new_name - in - Printf.sprintf "{seqno=%d; op=%s}" op.so_seqno opstr + let lvcreate_t_to_string l = + Printf.sprintf "{id:'%s', segments:[%s]}" l.lvc_id (Allocator.to_string l.lvc_segments) in + let lvexpand_t_to_string l = + Printf.sprintf "[%s]" (Allocator.to_string l.lvex_segments) in + let opstr = + match op.so_op with + | LvCreate (name,lvc) -> Printf.sprintf "LvCreate(%s,%s)" name (lvcreate_t_to_string lvc) + | LvRemove name -> Printf.sprintf "LvRemove(%s)" name + | LvReduce (name,lvrd) -> Printf.sprintf "LvReduce(%s,%Ld)" name lvrd.lvrd_new_extent_count + | LvExpand (name,lvex) -> Printf.sprintf "LvExpand(%s,%s)" name (lvexpand_t_to_string lvex) + | LvRename (name,lvmv) -> Printf.sprintf "LvRename(%s,%s)" name lvmv.lvmv_new_name + | LvAddTag (name,tag) -> Printf.sprintf "LvAddTag(%s,%s)" name (Tag.string_of tag) in + Printf.sprintf "{seqno=%d; op=%s}" op.so_seqno opstr diff --git a/mlvm/tag.ml b/mlvm/tag.ml new file mode 100644 --- /dev/null +++ b/mlvm/tag.ml @@ -0,0 +1,14 @@ +open Str + +type t = string with rpc + +let tag_regexp = regexp "^[A-Za-z0-9_+.][A-Za-z0-9_+.-]*$" + +let is_valid s = + (String.length s <= 128) && (string_match tag_regexp s 0) + +let of_string s = + if is_valid s then s else failwith "Tag string does not conform to the rules." + +let string_of t = + t diff --git a/mlvm/tag.mli b/mlvm/tag.mli new file mode 100644 --- /dev/null +++ b/mlvm/tag.mli @@ -0,0 +1,13 @@ +type t + +val rpc_of_t : t -> Rpc.t +val t_of_rpc : Rpc.t -> t +(** Checks whether a string is a valid tag string. + Tag character set: A-Za-z0-9_+.- + Can't start with hyphen. Max length is 128. + Empty tags are currently not allowed. *) +val is_valid : string -> bool +(** Creates a tag from a string. Fails on non-conforming strings. *) +val of_string : string -> t +(** Converts a tag to a string. *) +val string_of : t -> string diff --git a/mlvm/tag_is_valid_test.ml b/mlvm/tag_is_valid_test.ml new file mode 100644 --- /dev/null +++ b/mlvm/tag_is_valid_test.ml @@ -0,0 +1,13 @@ +open Tag + +let test_tag_string (should_be_valid, s) = + let is_valid = is_valid s in + let is_valid_string = if is_valid then " VALID" else "INVALID" in + let result = if is_valid = should_be_valid then " CORRECT" else "INCORRECT" in + print_endline (result ^ " --- " ^ is_valid_string ^ " --- '" ^ s ^ "'") + +let test_strings = + [false, ""; true, "abc"; false, "----abc"; true, "abc-----"; false, "abc###"; + true, String.make 128 'y'; false, String.make 129 'n'; true, "_0m_3+3-3.X"] + +let _ = List.map test_tag_string test_strings diff --git a/mlvm/test_fragment.ml b/mlvm/test_fragment.ml --- a/mlvm/test_fragment.ml +++ b/mlvm/test_fragment.ml @@ -1,4 +1,4 @@ -Put them into a library? *) +(* Put them into a library? *) let pvs = "/usr/sbin/pvs" let pvcreate = "/usr/sbin/pvcreate" diff --git a/mlvm/vg.ml b/mlvm/vg.ml --- a/mlvm/vg.ml +++ b/mlvm/vg.ml @@ -74,65 +74,62 @@ let to_string vg = (*************************************************************) let do_op vg op = - (if vg.seqno <> op.so_seqno then failwith "Failing to do VG operation out-of-order"); - Unixext.write_string_to_file (Printf.sprintf "/tmp/redo_op.%d" op.so_seqno) (Redo.redo_to_human_readable op); - let rec createsegs ss lstart = - match ss with - | a::ss -> - let length = Allocator.get_size a in - let pv_name = Allocator.get_name a in - ({Lv.s_start_extent=lstart; s_extent_count=length; - s_cls=Lv.Linear {Lv.l_pv_name=pv_name; - l_pv_start_extent=Allocator.get_start a}})::createsegs ss (Int64.add lstart length) - | _ -> [] - in - let change_lv lv_name fn = - let lv,others = List.partition (fun lv -> lv.Lv.name=lv_name) vg.lvs in - match lv with - | [lv] -> - fn lv others - | _ -> failwith "Unknown LV" - in - let vg = {vg with seqno = vg.seqno + 1; ops=op::vg.ops} in - match op.so_op with - | LvCreate (name,l) -> - let new_free_space = Allocator.alloc_specified_areas vg.free_space l.lvc_segments in - let segments = Lv.sort_segments (createsegs l.lvc_segments 0L) in - let lv = { Lv.name=name; - id=l.lvc_id; - tags=[]; - status=[Lv.Read; Lv.Visible]; - segments=segments } + (if vg.seqno <> op.so_seqno then failwith "Failing to do VG operation out-of-order"); + Unixext.write_string_to_file (Printf.sprintf "/tmp/redo_op.%d" op.so_seqno) (Redo.redo_to_human_readable op); + let rec createsegs ss lstart = + match ss with + | a::ss -> + let length = Allocator.get_size a in + let pv_name = Allocator.get_name a in + ({Lv.s_start_extent = lstart; s_extent_count = length; + s_cls = Lv.Linear {Lv.l_pv_name = pv_name; + l_pv_start_extent=Allocator.get_start a}})::createsegs ss (Int64.add lstart length) + | _ -> [] in - { vg with - lvs = lv::vg.lvs; - free_space=new_free_space } - | LvExpand (name,l) -> - change_lv name (fun lv others -> - let old_size = Lv.size_in_extents lv in - let free_space = Allocator.alloc_specified_areas vg.free_space l.lvex_segments in - let segments = createsegs l.lvex_segments old_size in - let lv = { lv with Lv.segments = Lv.sort_segments (segments @ lv.Lv.segments) } in - { vg with - lvs = lv::others; free_space=free_space}) - | LvReduce (name,l) -> - change_lv name (fun lv others -> - let allocation = Lv.allocation_of_lv lv in - let lv = Lv.reduce_size_to lv l.lvrd_new_extent_count in - let new_allocation = Lv.allocation_of_lv lv in - let free_space = Allocator.alloc_specified_areas (Allocator.free vg.free_space allocation) new_allocation in - {vg with - lvs = lv::others; free_space=free_space}) - | LvRemove name -> - change_lv name (fun lv others -> - let allocation = Lv.allocation_of_lv lv in - { vg with - lvs = others; - free_space = Allocator.free vg.free_space allocation }) - | LvRename (name,l) -> - change_lv name (fun lv others -> - { vg with - lvs = {lv with Lv.name=l.lvmv_new_name}::others }) + let change_lv lv_name fn = + let lv,others = List.partition (fun lv -> lv.Lv.name=lv_name) vg.lvs in + match lv with + | [lv] -> + fn lv others + | _ -> failwith "Unknown LV" + in + let vg = {vg with seqno = vg.seqno + 1; ops=op::vg.ops} in + match op.so_op with + | LvCreate (name,l) -> + let new_free_space = Allocator.alloc_specified_areas vg.free_space l.lvc_segments in + let segments = Lv.sort_segments (createsegs l.lvc_segments 0L) in + let lv = + { Lv.name = name; id = l.lvc_id; tags = []; + status = [Lv.Read; Lv.Visible]; segments = segments } in + {vg with lvs = lv::vg.lvs; free_space = new_free_space} + | LvExpand (name,l) -> + change_lv name (fun lv others -> + let old_size = Lv.size_in_extents lv in + let free_space = Allocator.alloc_specified_areas vg.free_space l.lvex_segments in + let segments = createsegs l.lvex_segments old_size in + let lv = {lv with Lv.segments = Lv.sort_segments (segments @ lv.Lv.segments)} in + {vg with lvs = lv::others; free_space=free_space}) + | LvReduce (name,l) -> + change_lv name (fun lv others -> + let allocation = Lv.allocation_of_lv lv in + let lv = Lv.reduce_size_to lv l.lvrd_new_extent_count in + let new_allocation = Lv.allocation_of_lv lv in + let free_space = Allocator.alloc_specified_areas (Allocator.free vg.free_space allocation) new_allocation in + {vg with + lvs = lv::others; free_space=free_space}) + | LvRemove name -> + change_lv name (fun lv others -> + let allocation = Lv.allocation_of_lv lv in + {vg with lvs = others; free_space = Allocator.free vg.free_space allocation }) + | LvRename (name,l) -> + change_lv name (fun lv others -> + {vg with lvs = {lv with Lv.name=l.lvmv_new_name}::others }) + | LvAddTag (name, tag) -> + change_lv name (fun lv others -> + let tags = lv.Lv.tags in + let lv' = {lv with Lv.tags = if List.mem tag tags then tags else tag::tags} in + {vg with lvs = lv'::others}) + let create_lv vg name size = let id = Lvm_uuid.create () in @@ -159,12 +156,11 @@ let resize_lv vg name new_size = let remove_lv vg name = do_op vg {so_seqno=vg.seqno; so_op=LvRemove name} +let add_tag_lv vg name tag = + do_op vg {so_seqno = vg.seqno; so_op = LvAddTag (name, tag)} + (******************************************************************************) - - - - let human_readable vg = let pv_strings = List.map Pv.human_readable vg.pvs in String.concat "\n" pv_strings
_______________________________________________ xen-api mailing list [email protected] http://lists.xensource.com/mailman/listinfo/xen-api
