This is a reimplementation of LVM in ocaml. It has had light testing, and therefore might corrupt data - use with caution! It only implements simple LVM functionality - creating/destroying/activating linear LVs (code exists for striped LVs but is untested). It also features a redo log so that LVM operation can be committed to disk in constant time.
Signed-off-by: Jon Ludlam <Jonathan.Ludlam@eu.citrix.com>
$(MAKE) -C camldm
endif
$(MAKE) -C forking_executioner
+ $(MAKE) -C mlvm
.PHONY: allxen
allxen:
$(MAKE) -C camldm install
endif
$(MAKE) -C forking_executioner install
+ $(MAKE) -C mlvm install
installxen:
ifeq ($(HAVE_XEN),1)
$(MAKE) -C camldm uninstall
endif
$(MAKE) -C forking_executioner uninstall
+ $(MAKE) -C mlvm uninstall
uninstallxen:
ifeq ($(HAVE_XEN),1)
$(MAKE) -C xsrpc doc
$(MAKE) -C mmap doc
$(MAKE) -C forking_executioner doc
+ $(MAKE) -C mlvm doc
.PHONY: clean
clean:
make -C sexpr clean
make -C doc clean
make -C forking_executioner clean
+ make -C mlvm clean
cleanxen:
$(MAKE) -C mmap clean
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)
+OCAMLOPTFLAGS = -g -dtypes
OCAMLABI := $(shell ocamlc -version)
OCAMLLIBDIR := $(shell ocamlc -where)
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
-
+COMPFLAG = -dtypes -g -I ../stdext -I ../camldm -I ../uuid -for-pack Lvm
LIBS = lvm.cma lvm.cmxa
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
default : $(LIBS)
-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)
clean :
rm -f *.cmo *.cmi *.cmx *.o *~ *.annot lvmconfiglex.ml \
lvmconfigparser.mli lvmconfigparser.ml
- rm -f test_allocator
-
-.PHONY: doc
-doc: $(INTF)
- python ../doc/doc.py $(DOCDIR) "mlvm" "package" "$(LIBOBJS)" "." "stdext,camldm,uuid,unix" "" "'${PP}'"
lvmconfigparser.ml : lvmconfigparser.mly
ocamlyacc lvmconfigparser.mly
-open Pervasiveext
-open Listext
+type t = (string * (int64 * int64)) list
-(* Sparse allocation should be fast. Expanding memory should be fast, for a bunch of volumes. *)
+let create name size = [(name,(0L,size))]
-type area = (string * (int64 * int64)) with rpc
-type t = area list with rpc
+let get_size (_,(_,s)) = s
+let get_start (_,(s,_)) = s
+let get_name (n,(_,_)) = n
+
+let make_area name start size = (name,(start,size))
+
+let alloc_specified_area (t : t) a =
+ let size = get_size a in
+ let start = get_start a in
+ let name = get_name a in
+ let test a2 =
+ let size2 = get_size a2 in
+ let start2 = get_start a2 in
+ let name2 = get_name a2 in
+ name=name2 && start >= start2 && start < Int64.add size2 start2
+ in
+ let containing_areas,other_areas = List.partition test t in
+ let containing_area = List.hd containing_areas in
+ let ca_start = get_start containing_area in
+ let ca_size = get_size containing_area in
+ let ca_name = get_name containing_area in
+ let new_areas =
+ if start=ca_start then other_areas else (make_area ca_name ca_start (Int64.sub start ca_start))::other_areas
+ in
+ let new_areas =
+ if (Int64.add start size) = (Int64.add ca_start ca_size)
+ then new_areas
+ else (make_area ca_name (Int64.add start size) (Int64.sub (Int64.add ca_start ca_size) (Int64.add start size)))::new_areas
+ in
+ new_areas
+
+let alloc_specified_areas =
+ List.fold_left alloc_specified_area
+
+let rec alloc t newsize =
+ let l = List.sort (fun a1 a2 -> compare (get_size a1) (get_size a2)) t in
+ let rec find xs ys =
+ match ys with
+ | seg::[] ->
+ (* If there's only one segment left, it's the largest. Allocate. *)
+ seg,xs
+ | seg::rest ->
+ let size = get_size seg in
+ if size >= newsize
+ then seg,(xs@rest)
+ else find (seg::xs) rest
+ | _ -> failwith "Failed to find individual segment!"
+ in
+ let seg,rest = find [] l in
+ let size = get_size seg in
+ if (size < newsize) then
+ (* We couldn't find one contiguous region to allocate. Call alloc again
+ with the remainder of the size and the new list of allocated segments *)
+ let allocd,newt = alloc (rest) (Int64.sub newsize size) in
+ (seg::allocd, newt)
+ else
+ let name = get_name seg in
+ let start = get_start seg in
+ let area = make_area name start newsize in
+ ([area], alloc_specified_area t area)
+
+let rec setify = function
+ | [] -> []
+ | (x::xs) -> if List.mem x xs then setify xs else x::(setify xs)
+
+let free t segs =
+ let l = List.sort (fun a1 a2 -> compare (get_start a1) (get_start a2)) (t@segs) in
+ let pvs = List.map get_name l in
+ let pvs = setify pvs in
+
+ let rec test acc segs =
+ match segs with
+ | a1::a2::rest ->
+ let start1 = get_start a1 in
+ let size1 = get_size a1 in
+ let start2 = get_start a2 in
+ let size2 = get_size a2 in
+ let name = get_name a1 in
+ if (Int64.add start1 size1) = start2 then
+ test acc ((make_area name start1 (Int64.add size1 size2))::rest)
+ else
+ test ((List.hd segs)::acc) (List.tl segs)
+ | [x] -> x::acc
+ | [] -> acc (* shouldn't be necessary! *)
+ in
+
+ List.fold_left (fun acc pv -> test acc (List.filter (fun seg -> get_name seg = pv) l)) [] pvs
-let to_string1 (p,(s,l)) = Printf.sprintf "(%s: [%Ld,%Ld])" p s l
let to_string t =
String.concat ", "
- (List.map to_string1 t)
-
-let create name size = [(name,(0L,size))]
-let empty = []
-
-let get_name (name,(_,_)) = name
-let get_start (_,(start,_)) = start
-let get_size (_,(_,size)) = size
-let unpack_area (pv_name, (start,size)) = (pv_name, (start,size))
-
-let get_end a = Int64.add (get_start a) (get_size a)
-
-let make_area pv_name start size = (pv_name, (start,size))
-let make_area_by_end name start endAr = make_area name start (Int64.sub endAr start)
-
-(* Define operations on areas, and then use those to build the
- allocation algorithms. That should make it easier to test, and the
- algorithms are easier to read without arithmetic in them.
-*)
-
-let intersect : area -> area -> area list =
- fun a a2 ->
- let (name, (start, size)) = unpack_area a in
- let (name2, (start2, size2)) = unpack_area a2 in
- let enda = get_end a in
- let enda2 = get_end a2 in
- let startI = max start start2 in
- let endI = min enda enda2 in
- let sizeI = max Int64.zero (Int64.sub endI startI) in
- if name = name2
- then make_area name (max start start2) (max Int64.zero sizeI) :: []
- else []
-
-let combine : t -> t -> t = (* does not guarantee normalization *)
- fun t1 t2 ->
- t1 @ t2
-
-let union : area -> area -> t = (* does not guarantee normalization *)
- fun a a2 ->
- a::a2::[]
-let minus : area -> area -> t = (* does not guarantee normalization *)
- fun a a2 ->
- let (name, (start, size)) = unpack_area a in
- let (name2, (start2, size2)) = unpack_area a2 in
- let enda = get_end a in
- let enda2 = get_end a2 in
- if name = name2
- then List.filter ((<) Int64.zero ++ get_size) ++ List.fold_left combine [] ++ List.map (intersect a ++ Fun.uncurry (make_area_by_end name2)) $ ((start, start2) :: (enda2, enda)::[])
- else a :: []
-
-(* Is a contained in a2? *)
-let contained : area -> area -> bool =
- fun a a2 ->
- let (name, (start, size)) = unpack_area a in
- let (name2, (start2, size2)) = unpack_area a2 in
- name=name2 && start >= start2 && Int64.add start size <= Int64.add start2 size2
-
-exception PVS_DONT_MATCH
-
-(* assumes all areas stem from the same pv *)
-let normalize_single_pv areas =
- (* Underlying structure for merge1: foldM merge1 (for a1) on WriterMonad (for acc) over segs *)
- (* The type of the accumulator here is a bit ugly. Perhaps a real non-empty list would be better? *)
- let merge1 (a1, acc) a2 =
- let (name, (start1, size1)) = unpack_area a1
- and (name2, (start2, size2)) = unpack_area a2 in
- if (name != name2) then raise PVS_DONT_MATCH
- else if (Int64.add start1 size1) = start2 then
- (make_area name start1 (Int64.add size1 size2), acc)
- else
- (a2, List.cons a1 acc) in
- (function
- | start::segs ->
- (Fun.uncurry List.cons) $ List.fold_left merge1 (start, []) segs
- | [] -> [] (* shouldn't be necessary! *))
- ++ List.sort (Fun.on compare get_start) ++ List.filter ((<) 0L ++ get_size) $ areas
-let normalize : t -> t =
- fun areas ->
- (* The next lines are to be read backwards, since we defined function composition that way. *)
-
- let module StringMap = Mapext.Make (String) in
- (* put free areas of all PVs back together *)
- List.flatten ++ StringMap.values
- (* normalize each pv's areas *)
- ++ StringMap.map normalize_single_pv
- (* separate by pv *)
- ++ StringMap.fromListWith List.append ++ List.map (fun seg -> (get_name seg, [seg]))
- $ areas
-
-(* Which invariants does t have to satisfy? Which invariants does our
- result here satisfy?
-
- E.g. is it possible for areas to overlap or contain each other? If not, should we warn if they do?
-
- t is a free list.
-
- What if there's no containing area? Is this only called under certain circumstances? Verify. *)
-exception NonSingular_Containing_Area
-let alloc_specified_area (free_list : t) (a : area) =
- (* We assume areas don't overlap, or do we? *)
- (* Match against [] instead of _: Better die as soon as possible, when something is wrong.
- * And that was right! Just caught a bug that would have been masked otherwise. *)
- match List.partition (contained a) ++ normalize $ free_list with
- | (containing_area::[]), other_areas -> normalize $ combine (minus containing_area a) other_areas
- | x,_ -> (print_string "alloc_specified_area:\t";
- print_endline ++ to_string $ x;
- raise NonSingular_Containing_Area;)
-
-let alloc_specified_areas : t -> t -> t =
- List.fold_left alloc_specified_area
-
-let safe_alloc (free_list : t) (newsize : int64) =
- (* switched from best-fit (smallest free area that's large enough)
- to worst-fit (largest area): This may reduce fragmentation, and
- makes the code slightly easier. *)
- let rec alloc_h newsize = function
- | (seg::rest) ->
- let remainder = Int64.sub newsize (get_size seg) in
- if (remainder > Int64.zero) then
- (* We couldn't find one contiguous region to allocate. Call alloc again
- with the remainder of the size and the new list of allocated areas *)
- match alloc_h remainder rest with
- | Some (allocd,newt) -> Some (seg::allocd, newt)
- | None -> None
- else
- let (name, (start, _)) = unpack_area seg in
- let area = make_area name start newsize in
- Some ([area], try (alloc_specified_area (seg::rest) area) with (Match_failure x) -> (print_endline "alloc_specified_area"; raise (Match_failure x)))
- | [] -> None in
- alloc_h newsize
- ++ List.rev ++ List.sort (Fun.on compare get_size) $ free_list
-
-let alloc (free_list : t) (newsize : int64) =
- match safe_alloc free_list newsize
- with Some x -> x
- | None -> failwith "Failed to find individual area!"
-
-(* Probably de-allocation won't be used much. *)
-let free to_free free_list = normalize (combine to_free free_list)
+ (List.map (fun (p,(s,l)) -> Printf.sprintf "(%s: [%Ld,%Ld])" p s l) t)
let dotest a n =
let before = List.sort compare a in
let mib = Int64.mul 1024L 1024L
let tib = Int64.mul mib mib
-(* Ahem, mutable constants? *)
let dummy_mode = ref false
let dummy_base = ref "/tmp"
let mapper_name = ref "mapper"
| Write
| Visible
-and striped_segment = {
+type striped_segment = {
st_stripe_size : int64; (* In sectors *)
st_stripes : (string * int64) list; (* pv name * start extent *)
}
-and linear_segment = {
+type linear_segment = {
l_pv_name : string;
l_pv_start_extent : int64;
}
-and segclass =
+type segclass =
| Linear of linear_segment
| Striped of striped_segment
-and segment =
+type segment =
{ s_start_extent : int64;
s_extent_count : int64;
s_cls : segclass; }
-and logical_volume = {
+type logical_volume = {
name : string;
id : string;
tags : string list;
status : stat list;
segments : segment list;
-} with rpc
+}
let status_to_string s =
match s with
| "WRITE" -> Write
| "VISIBLE" -> Visible
| _ -> failwith "Bad LV status string"
-
-let sort_segments s =
- List.sort (fun s1 s2 -> compare s1.s_start_extent s2.s_start_extent) s
-
+
let write_to_buffer b lv =
let bprintf = Printf.bprintf in
bprintf b "\n%s {\nid = \"%s\"\nstatus = [%s]\n" lv.name lv.id
if List.length lv.tags > 0 then
bprintf b "tags = [%s]\n" (String.concat ", " (List.map quote lv.tags));
bprintf b "segment_count = %d\n\n" (List.length lv.segments);
- Listext.List.iteri
+ Listext.List.iteri_right
(fun i s ->
bprintf b "segment%d {\nstart_extent = %Ld\nextent_count = %Ld\n\n"
(i+1) s.s_start_extent s.s_extent_count;
id=id;
status=status;
tags=tags;
- segments=sort_segments segments }
+ segments=segments }
let allocation_of_segment s =
match s.s_cls with
let reduce_size_to lv new_seg_count =
let cur_size = size_in_extents lv in
- Debug.debug "Beginning reduce_size_to:";
if cur_size < new_seg_count then (failwith (Printf.sprintf "Cannot reduce size: current size (%Ld) is less than requested size (%Ld)" cur_size new_seg_count));
let rec doit segs left acc =
match segs with
| s::ss ->
- Debug.debug (Printf.sprintf "Lv.reduce_size_to: s.s_start_extent=%Ld s.s_extent_count=%Ld left=%Ld"
- s.s_start_extent s.s_extent_count left);
if left > s.s_extent_count then
doit ss (Int64.sub left s.s_extent_count) (s::acc)
else
{s with s_extent_count = left}::acc
| _ -> acc
in
- {lv with segments = sort_segments (doit lv.segments new_seg_count [])}
+ {lv with segments = (doit lv.segments new_seg_count [])}
let increase_allocation lv new_segs =
- {lv with segments = sort_segments (lv.segments @ new_segs)}
+ {lv with segments=lv.segments @ new_segs}
let unmarshal_uint16 ?(bigendian=false) (s, offset) =
let offsets = if bigendian then [|1;0|] else [|0;1|] in
- let (<!<) a b = a lsl b
- and (|!|) a b = a lor b in
+ let (<<) a b = a lsl b
+ and (||) a b = a lor b in
let a = int_of_char (s.[offset + offsets.(0)])
and b = int_of_char (s.[offset + offsets.(1)]) in
- (a <!< 0) |!| (b <!< 8), (s, offset + 2)
+ (a << 0) || (b << 8), (s, offset + 2)
let unmarshal_uint32 ?(bigendian=false) (s, offset) =
let offsets = if bigendian then [|3;2;1;0|] else [|0;1;2;3|] in
- let (<!<) a b = Int32.shift_left a b
- and (|!|) a b = Int32.logor a b in
+ let (<<) a b = Int32.shift_left a b
+ and (||) a b = Int32.logor a b in
let a = Int32.of_int (int_of_char (s.[offset + offsets.(0)]))
and b = Int32.of_int (int_of_char (s.[offset + offsets.(1)]))
and c = Int32.of_int (int_of_char (s.[offset + offsets.(2)]))
and d = Int32.of_int (int_of_char (s.[offset + offsets.(3)])) in
- (a <!< 0) |!| (b <!< 8) |!| (c <!< 16) |!| (d <!< 24), (s, offset + 4)
+ (a << 0) || (b << 8) || (c << 16) || (d << 24), (s, offset + 4)
let unmarshal_uint64 ?(bigendian=false) (s, offset) =
let offsets = if bigendian then [|7;6;5;4;3;2;1;0|] else [|0;1;2;3;4;5;6;7|] in
- let (<!<) a b = Int64.shift_left a b
- and (|!|) a b = Int64.logor a b in
+ let (<<) a b = Int64.shift_left a b
+ and (||) a b = Int64.logor a b in
let a = Int64.of_int (int_of_char (s.[offset + offsets.(0)]))
and b = Int64.of_int (int_of_char (s.[offset + offsets.(1)]))
and c = Int64.of_int (int_of_char (s.[offset + offsets.(2)]))
and f = Int64.of_int (int_of_char (s.[offset + offsets.(5)]))
and g = Int64.of_int (int_of_char (s.[offset + offsets.(6)]))
and h = Int64.of_int (int_of_char (s.[offset + offsets.(7)])) in
- (a <!< 0) |!| (b <!< 8) |!| (c <!< 16) |!| (d <!< 24)
- |!| (e <!< 32) |!| (f <!< 40) |!| (g <!< 48) |!| (h <!< 56), (s, offset + 8)
+ (a << 0) || (b << 8) || (c << 16) || (d << 24)
+ || (e << 32) || (f << 40) || (g << 48) || h << (56), (s, offset + 8)
let unmarshal_string len (s,offset) =
String.sub s offset len, (s, offset + len)
let marshal_int16 (s,offset) ?(bigendian=false) x =
let offsets = if bigendian then [|1;0|] else [|0;1|] in
- let (>!>) a b = a lsr b
+ let (>>) a b = a lsr b
and (&&) a b = a land b in
- let a = (x >!> 0) && 0xff
- and b = (x >!> 8) && 0xff in
+ let a = (x >> 0) && 0xff
+ and b = (x >> 8) && 0xff in
s.[offset+offsets.(0)] <- char_of_int a;
s.[offset+offsets.(1)] <- char_of_int b;
(s,offset+2)
let marshal_int32 (s,offset) ?(bigendian=false) x =
let offsets = if bigendian then [|3;2;1;0|] else [|0;1;2;3|] in
- let (>!>) a b = Int32.shift_right_logical a b
+ let (>>) a b = Int32.shift_right_logical a b
and (&&) a b = Int32.logand a b in
- let a = (x >!> 0) && 0xffl
- and b = (x >!> 8) && 0xffl
- and c = (x >!> 16) && 0xffl
- and d = (x >!> 24) && 0xffl in
+ let a = (x >> 0) && 0xffl
+ and b = (x >> 8) && 0xffl
+ and c = (x >> 16) && 0xffl
+ and d = (x >> 24) && 0xffl in
s.[offset+offsets.(0)] <- char_of_int (Int32.to_int a);
s.[offset+offsets.(1)] <- char_of_int (Int32.to_int b);
s.[offset+offsets.(2)] <- char_of_int (Int32.to_int c);
let marshal_int64 (s,offset) ?(bigendian=false) x =
let offsets = if bigendian then [|7;6;5;4;3;2;1;0|] else [|0;1;2;3;4;5;6;7|] in
- let (>!>) a b = Int64.shift_right_logical a b
+ let (>>) a b = Int64.shift_right_logical a b
and (&&) a b = Int64.logand a b in
- let a = (x >!> 0) && 0xffL
- and b = (x >!> 8) && 0xffL
- and c = (x >!> 16) && 0xffL
- and d = (x >!> 24) && 0xffL
- and e = (x >!> 32) && 0xffL
- and f = (x >!> 40) && 0xffL
- and g = (x >!> 48) && 0xffL
- and h = (x >!> 56) && 0xffL in
+ let a = (x >> 0) && 0xffL
+ and b = (x >> 8) && 0xffL
+ and c = (x >> 16) && 0xffL
+ and d = (x >> 24) && 0xffL
+ and e = (x >> 32) && 0xffL
+ and f = (x >> 40) && 0xffL
+ and g = (x >> 48) && 0xffL
+ and h = (x >> 56) && 0xffL in
s.[offset+offsets.(0)] <- char_of_int (Int64.to_int a);
s.[offset+offsets.(1)] <- char_of_int (Int64.to_int b);
s.[offset+offsets.(2)] <- char_of_int (Int64.to_int c);
ty : string (* 8 bytes, equal to "LVM2 001" - Constants.label_type*)
}
- and disk_locn = {
+ type disk_locn = {
dl_offset : int64;
dl_size : int64;
}
- and pv_header = {
+ type pv_header = {
pvh_id : string; (* 32 bytes, 'uuid' *)
pvh_device_size : int64;
pvh_extents: disk_locn list;
pvh_metadata_areas: disk_locn list;
}
- and t = {
+ type t = {
device : string;
label_header : label_header;
pv_header : pv_header;
- } with rpc
+ }
let unmarshal_header b0 =
let id,b = unmarshal_string 8 b0 in
pvh_extents=disk_areas;
pvh_metadata_areas=disk_areas2},b
- let pvh_to_ascii pvh =
- let disk_area_list_to_ascii l =
- (String.concat "," (List.map (fun da -> Printf.sprintf "{offset=%Ld,size=%Ld}" da.dl_offset da.dl_size) l)) in
- Printf.sprintf "pvh_id: %s\npvh_device_size: %Ld\npvh_areas1: %s\npvh_areas2: %s\n"
- pvh.pvh_id pvh.pvh_device_size
- (disk_area_list_to_ascii pvh.pvh_extents)
- (disk_area_list_to_ascii pvh.pvh_metadata_areas)
-
let write_label_and_pv_header l =
let label = l.label_header in
let pvh = l.pv_header in
let header = marshal_string header label.ty in
assert(snd header = 32);
-
- Debug.debug (Printf.sprintf "write_label_and_pv_header:\nPV header:\n%s" (pvh_to_ascii pvh));
-
+
(* PV header *)
let header = marshal_string header (Lvm_uuid.remove_hyphens pvh.pvh_id) in
let header = marshal_int64 header pvh.pvh_device_size in
Unix.close fd
+ let pvh_to_ascii pvh =
+ let disk_area_list_to_ascii l =
+ (String.concat "," (List.map (fun da -> Printf.sprintf "{offset=%Ld,size=%Ld}" da.dl_offset da.dl_size) l)) in
+ Printf.sprintf "pvh_id: %s\npvh_device_size: %Ld\npvh_areas1: %s\npvh_areas2: %s\n"
+ pvh.pvh_id pvh.pvh_device_size
+ (disk_area_list_to_ascii pvh.pvh_extents)
+ (disk_area_list_to_ascii pvh.pvh_metadata_areas)
+
let get_metadata_locations label =
label.pv_header.pvh_metadata_areas
end
module MDAHeader = struct
- let mda_header_size = Constants.sector_size
-
type mda_raw_locn = {
mrl_offset: int64;
mrl_size: int64;
mrl_filler: int32;
}
- and mda_header = {
+ let mda_header_size = Constants.sector_size
+
+ type mda_header = {
mdah_checksum : int32;
mdah_magic : string;
mdah_version : int32;
mdah_start: int64;
mdah_size: int64;
mdah_raw_locns : mda_raw_locn list;
- } with rpc
+ }
let unmarshal_mda_header device location =
let offset,fd =
if written <> Constants.sector_size then failwith "Wrote short!";
Unix.close fd
- let read_md dev mdah n =
- (* debug *)
- let oc = open_out "/tmp/hdr" in
- Printf.fprintf oc "%s\n%!" (to_ascii mdah);
- close_out oc;
-
- let locn = List.nth mdah.mdah_raw_locns n in
- let fd =
- if !Constants.dummy_mode then begin
- Unix.openfile (dummy_fname dev "md") [Unix.O_RDONLY] 0o000
- end else begin
- let fd = Unix.openfile dev [Unix.O_RDONLY] 0o000 in
- ignore(Unix.LargeFile.lseek fd (Int64.add mdah.mdah_start locn.mrl_offset) Unix.SEEK_SET);
- fd
- end
- in
- let md =
- (* Include terminating \0 in this string.
- * The checksum calculation in original lvm does so, too.*)
- if(Int64.add locn.mrl_offset locn.mrl_size > mdah.mdah_size)
- then (* wrap around *)
- let firstbit = Int64.to_int (Int64.sub mdah.mdah_size locn.mrl_offset) in
- let firstbitstr = really_read fd firstbit in
- let secondbit = (Int64.to_int locn.mrl_size) - firstbit in
- if not !Constants.dummy_mode then ignore(Unix.LargeFile.lseek fd (Int64.add mdah.mdah_start 512L) Unix.SEEK_SET);
- let secondbitstr = really_read fd secondbit in
- firstbitstr ^ secondbitstr
- else
- really_read fd (Int64.to_int locn.mrl_size) in
- let checksum = Crc.crc md Crc.initial_crc in
- Unix.close fd;
- if checksum <> locn.mrl_checksum then
- Printf.fprintf stderr "Checksum invalid in metadata: Found %lx, expecting %lx\n" checksum locn.mrl_checksum;
- md
+ let read_md dev mdah n =
+ (* debug *)
+ let oc = open_out "/tmp/hdr" in
+ Printf.fprintf oc "%s\n%!" (to_ascii mdah);
+ close_out oc;
+
+ let locn = List.nth mdah.mdah_raw_locns n in
+ let fd =
+ if !Constants.dummy_mode then begin
+ Unix.openfile (dummy_fname dev "md") [Unix.O_RDONLY] 0o000
+ end else begin
+ let fd = Unix.openfile dev [Unix.O_RDONLY] 0o000 in
+ ignore(Unix.LargeFile.lseek fd (Int64.add mdah.mdah_start locn.mrl_offset) Unix.SEEK_SET);
+ fd
+ end
+ in
+ let md =
+ if(Int64.add locn.mrl_offset locn.mrl_size > mdah.mdah_size)
+ then
+ let firstbit = Int64.to_int (Int64.sub mdah.mdah_size locn.mrl_offset) in
+ let firstbitstr = really_read fd firstbit in
+ let secondbit = (Int64.to_int locn.mrl_size) - firstbit - 1 in
+ if not !Constants.dummy_mode then ignore(Unix.LargeFile.lseek fd (Int64.add mdah.mdah_start 512L) Unix.SEEK_SET);
+ let secondbitstr = really_read fd secondbit in
+ firstbitstr ^ secondbitstr
+ else
+ really_read fd (Int64.to_int locn.mrl_size - 1) in
+ let checksum = Crc.crc md Crc.initial_crc in
+ Unix.close fd;
+ if checksum <> locn.mrl_checksum then
+ Printf.fprintf stderr "Checksum invalid in metadata: Found %lx, expecting %lx\n" checksum locn.mrl_checksum;
+ md
let write_md device mdah md =
(* Find the current raw location of the metadata, assuming there's only one copy *)
type status =
| Allocatable
-and physical_volume = {
+type physical_volume = {
name : string;
id : string;
dev : string;
pe_count : int64;
label : Label.t; (* The one label for this PV *)
mda_headers : MDAHeader.mda_header list;
-} with rpc
+}
let status_to_string s =
match s with
(** Find the metadata area on a device and return the text of the metadata *)
let find_metadata device =
let label = Label.find device in
- Debug.debug (Printf.sprintf "Label found: \n%s\n"
- (Label.to_ascii label));
+ (* Printf.printf "Label found: \n%s\nPV header found:\n%s\n"
+ (Pv.Label.label_to_ascii label) (Pv.Label.pvh_to_ascii pvh); *)
let mda_locs = Label.get_metadata_locations label in
let mdahs = List.map (MDAHeader.unmarshal_mda_header device) mda_locs in
let mdt = MDAHeader.read_md device (List.hd mdahs) 0 in
lvc_segments : Allocator.t
}
-and lvrename_t = {
+type lvrename_t = {
lvmv_new_name : string;
}
-and lvreduce_t = {
+type lvreduce_t = {
lvrd_new_extent_count : int64;
}
-and lvexpand_t = {
+type lvexpand_t = {
lvex_segments : Allocator.t;
}
-and operation =
+type operation =
| LvCreate of string * lvcreate_t
| LvReduce of string * lvreduce_t
| LvExpand of string * lvexpand_t
| LvRename of string * lvrename_t
| LvRemove of string
-and sequenced_op = {
+type sequenced_op = {
so_seqno : int;
so_op : operation
-} with rpc
+}
open Debug
raise (OutOfSize op.so_seqno)
else begin
ignore(Unix.LargeFile.lseek fd ofs Unix.SEEK_SET);
- ignore(Unix.write fd str 0 len);
+ Unix.write fd str 0 len;
let new_pos = Int64.add ofs (Int64.of_int len) in
write_initial_pos fd offset new_pos;
write new_pos ops
write_initial_pos fd offset (Int64.add offset 12L)
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
+ | LvCreate (name,_) -> Printf.sprintf "LvCreate(%s)" name
+ | LvRemove name -> Printf.sprintf "LvRemove(%s)" name
+ | LvReduce (name,_) -> Printf.sprintf "LvReduce(%s)" name
+ | LvExpand (name,_) -> Printf.sprintf "LvExpand(%s)" name
+ | LvRename (name,_) -> Printf.sprintf "LvRename(%s)" name
in
Printf.sprintf "{seqno=%d; op=%s}" op.so_seqno opstr
| Resizeable
| Clustered
-and vg = {
+type vg = {
name : string;
id : string;
seqno : int;
free_space : Allocator.t;
redo_lv : string option; (* Name of the redo LV *)
ops : sequenced_op list;
-} with rpc
+}
let status_to_string s =
match s with
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 ->
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 segments = (createsegs l.lvc_segments 0L) in
let lv = { Lv.name=name;
id=l.lvc_id;
tags=[];
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
+ let lv = { lv with Lv.segments = segments @ lv.Lv.segments } in
{ vg with
lvs = lv::others; free_space=free_space})
| LvReduce (name,l) ->
with _ ->
let fd = Unix.openfile fname [Unix.O_RDWR; Unix.O_CREAT] 0o644 in
(* let size = Int64.mul Constants.extent_size (Lv.size_in_extents lv) in
- if !Constants.full_provision
- then ignore(Unix.LargeFile.lseek fd (Int64.sub size 1L) Unix.SEEK_SET);*)
- ignore(Unix.write fd "\000" 0 1);
+ if !Constants.full_provision then
+ ignore(Unix.LargeFile.lseek fd (Int64.sub size 1L) Unix.SEEK_SET);*)
+ Unix.write fd "\000" 0 1;
Unix.close fd;
end;
(* Let's also make sure that the dir exists for the dev node! *)
Unix.unlink nod
let lv_deactivate vg lv =
- let dm_name = dm_name_of vg lv in
- (ignore (dev_path_of_dm_name dm_name);
- lv_deactivate_internal None dm_name)
+ let dm_name = dm_name_of vg lv in
+ let nod = dev_path_of_dm_name dm_name in
+ lv_deactivate_internal None dm_name
let lv_change_internal dm_name dm_map dereference_table =
Camldm.reload dm_name dm_map dereference_table;
find 0 sector_num
let with_open_redo vg f =
- match vg.redo_lv with
- | Some lv_name ->
- let lv = List.find (fun lv -> lv.Lv.name=lv_name) vg.lvs in
- let dev = (List.hd vg.pvs).Pv.dev in
- let (dev,pos) =
- if !Constants.dummy_mode
- then (Printf.sprintf "%s/%s/redo" !Constants.dummy_base dev,0L)
- else get_absolute_pos_of_sector vg lv 0L in
- let fd = Unix.openfile dev [Unix.O_RDWR; Unix.O_CREAT] 0o644 in
- Pervasiveext.finally (fun () -> f (fd,pos)) (fun () -> Unix.close fd)
- | None -> failwith "vg.ml/with_open_redo: vg.redo_lv == None, but should not be."
+ let Some lv_name = vg.redo_lv in
+ let lv = List.find (fun lv -> lv.Lv.name=lv_name) vg.lvs in
+ let dev = (List.hd vg.pvs).Pv.dev in
+ let (dev,pos) =
+ if !Constants.dummy_mode then
+ (Printf.sprintf "%s/%s/redo" !Constants.dummy_base dev,0L)
+ else
+ get_absolute_pos_of_sector vg lv 0L in
+ let fd = Unix.openfile dev [Unix.O_RDWR; Unix.O_CREAT] 0o644 in
+ Pervasiveext.finally (fun () -> f (fd,pos)) (fun () -> Unix.close fd)
let read_redo vg =
- with_open_redo vg (fun (fd,pos) ->
- Redo.read fd pos (Constants.extent_size))
+ with_open_redo vg (fun (fd,pos) ->
+ Redo.read fd pos (Constants.extent_size))
let write_redo vg =
with_open_redo vg (fun (fd,pos) ->
List.map (fun mdah ->
Pv.MDAHeader.write_md pv.Pv.real_device mdah md) pv.Pv.mda_headers}) pvs}
in
- Unixext.write_string_to_file (Printf.sprintf "/tmp/metadata.%d" vg.seqno) md;
(match vg.redo_lv with Some _ -> reset_redo vg | None -> ());
vg
if got_redo_lv then apply_redo vg else vg
let create_new name devices_and_names =
- let pvs = List.map (fun (dev,name) -> Pv.create_new dev name) devices_and_names in
- debug "PVs created";
- let free_space = List.flatten (List.map (fun pv -> Allocator.create pv.Pv.name pv.Pv.pe_count) pvs) in
- let vg =
- { name=name;
- id=Lvm_uuid.create ();
- seqno=1;
- status=[Read; Write];
- extent_size=Constants.extent_size_in_sectors;
- max_lv=0;
- max_pv=0;
- pvs=pvs;
- lvs=[];
- free_space=free_space;
- redo_lv=None;
- ops=[];
- }
- in
- ignore (write vg true);
- debug "VG created"
+ let pvs = List.map (fun (dev,name) -> Pv.create_new dev name) devices_and_names in
+ let free_space = List.flatten (List.map (fun pv -> Allocator.create pv.Pv.name pv.Pv.pe_count) pvs) in
+ let vg =
+ { name=name;
+ id=Lvm_uuid.create ();
+ seqno=1;
+ status=[Read; Write];
+ extent_size=Constants.extent_size_in_sectors;
+ max_lv=0;
+ max_pv=0;
+ pvs=pvs;
+ lvs=[];
+ free_space=free_space;
+ redo_lv=None;
+ ops=[];
+ }
+ in
+ write vg true
let parse text pvdatas =
let lexbuf = Lexing.from_string text in
let md = fst (List.hd mds_and_pvdatas) in
let pvdatas = List.map snd mds_and_pvdatas in
let oc = open_out "/tmp/metadata" in
- Printf.fprintf oc "%s" md;
- close_out oc;
- parse md pvdatas
+ Printf.fprintf oc "%s" md;
+ parse md pvdatas
let set_dummy_mode base_dir mapper_name full_provision =
Constants.dummy_mode := true;
projects / xcp / xen-api-libs.git / commitdiff