Print nice error messages if out of space

idl/errors.ml

@@ -16,7 +16,7 @@ open Lwt
 let (>>*=) m f = match m with
   | `Error (`Msg e) -> fail (Failure e)
   | `Error (`DuplicateLV lv) -> fail (Failure (Printf.sprintf "An LV with name %s already exists" lv))
-  | `Error (`OnlyThisMuchFree space) -> fail (Failure (Printf.sprintf "Only this much space is available: %Ld" space))
+  | `Error (`OnlyThisMuchFree (needed, available)) -> fail (Xenvm_interface.Insufficient_free_space(needed, available))
   | `Error (`UnknownLV lv) -> fail (Failure (Printf.sprintf "The LV with name %s was not found" lv))
   | `Ok x -> f x
 let (>>|=) m f = m >>= fun x -> x >>*= f

idl/xenvm_interface.ml

@@ -13,6 +13,10 @@ external get : unit -> Vg_wrapper.t = ""
 external create : name:string -> size:int64 -> creation_host:string -> creation_time:int64 -> tags:string list -> unit = ""
 external rename : oldname:string -> newname:string -> unit = ""
 external remove : name:string -> unit = ""
+
+exception Insufficient_free_space of (int64 (* extents needed *) * int64 (* extents available *))
+(** There's not enough space to create or resize the LV *)
+
 external resize : name:string -> size:int64 -> unit = ""
 external set_status : name:string -> readonly:bool -> unit = ""
 

test/test.ml

@@ -96,6 +96,62 @@ let lvcreate_percent =
   assert_equal ~printer:Int64.to_string 0L free;
   xenvm [ "lvremove"; vg ^ "/test" ] |> ignore_string
 
+let kib = 1024L
+let mib = Int64.mul kib 1024L
+let gib = Int64.mul mib 1024L
+let tib = Int64.mul mib 1024L
+let xib = Int64.mul tib 1024L
+
+let contains s1 s2 =
+    let re = Str.regexp_string s2 in
+    try 
+       ignore (Str.search_forward re s1 0); 
+       true
+    with Not_found -> false
+
+let lvcreate_toobig =
+  "lvcreate -n <name> -l <too many>: check that we fail nicely" >::
+  fun () ->
+  Lwt_main.run (
+    Lwt.catch
+      (fun () -> Client.create "toobig" xib "unknown" 0L [])
+      (function Xenvm_interface.Insufficient_free_space(needed, available) -> return ()
+       | e -> failwith (Printf.sprintf "Did not get Insufficient_free_space: %s" (Printexc.to_string e)))
+  );
+  try
+    xenvm [ "lvcreate"; "-n"; "test"; "-l"; Int64.to_string xib; vg ] |> ignore_string;
+    failwith "Did not get Insufficient_free_space"
+  with
+    | Bad_exit(5, _, _, stdout, stderr) ->
+      let expected = "insufficient free space" in
+      if not (contains stderr expected)
+      then failwith (Printf.sprintf "stderr [%s] did not have expected string [%s]" stderr expected)
+    | _ ->
+      failwith "Expected exit code 5"
+
+let lvextend_toobig =
+  "lvextend packer-virtualbox-iso-vg/swap_1 -L 1T: check that the failure is nice" >::
+  fun () ->
+  xenvm [ "lvcreate"; "-n"; "test"; "-l"; "100%F"; vg ] |> ignore_string;
+  begin
+    Lwt_main.run (
+      Lwt.catch
+        (fun () -> Client.resize "test" xib)
+        (function Xenvm_interface.Insufficient_free_space(needed, available) -> return ()
+         | e -> failwith (Printf.sprintf "Did not get Insufficient_free_space: %s" (Printexc.to_string e)))
+    );
+    try
+      xenvm [ "lvextend"; vg ^ "/test"; "-L"; Int64.to_string xib ] |> ignore_string;
+      failwith "Did not get Insufficient_free_space"
+    with
+      | Bad_exit(5, _, _, stdout, stderr) ->
+        let expected = "Insufficient free space" in
+        if not (contains stderr expected)
+        then failwith (Printf.sprintf "stderr [%s] did not have expected string [%s]" stderr expected)
+      | e ->
+        failwith (Printf.sprintf "Expected exit code 5: %s" (Printexc.to_string e))
+  end;
+  xenvm [ "lvremove"; vg ^ "/test" ] |> ignore_string
 
 let file_exists filename =
   try
@@ -154,7 +210,9 @@ let xenvmd_suite = "Commands which require xenvmd" >::: [
   lvcreate_L;
   lvcreate_l;
   lvcreate_percent;
+  lvcreate_toobig;
   lvchange_n;
+  lvextend_toobig;
   vgs_online;
 ]
 

xenvm-local-allocator/local_allocator.ml

@@ -165,11 +165,11 @@ module FreePool = struct
           | `Ok x ->
             free := Lvm.Pv.Allocator.sub !free x;
             return x
-          | `Error (`OnlyThisMuchFree 0L) ->
+          | `Error (`OnlyThisMuchFree (_, 0L)) ->
             Lwt_condition.wait ~mutex:m c
             >>= fun () ->
             wait ()
-          | `Error (`OnlyThisMuchFree n) ->
+          | `Error (`OnlyThisMuchFree (_, n)) ->
             begin match Lvm.Pv.Allocator.find !free n with
             | `Ok x ->
               free := Lvm.Pv.Allocator.sub !free x;

xenvm/lvcreate.ml

@@ -25,7 +25,15 @@ let lvcreate copts lv_name real_size percent_size tags vg_name =
     if vg.Lvm.Vg.name <> vg_name then failwith "Invalid VG name";
     let creation_host = Unix.gethostname () in
     let creation_time = Unix.gettimeofday () |> Int64.of_float in
-    Client.create lv_name size creation_host creation_time tags >>= fun () -> 
+    Lwt.catch
+      (fun () ->
+        Client.create lv_name size creation_host creation_time tags
+      ) (function
+        | Xenvm_interface.Insufficient_free_space(needed, available) ->
+          Printf.fprintf Pervasives.stderr "Volume group \"%s\" has insufficient free space (%Ld extents): %Ld required.\n%!" vg.Lvm.Vg.name available needed;
+          exit 5
+        | e -> fail e
+    ) >>= fun () ->
     return info) in
   match info with | Some i -> Lvchange.lvchange_activate copts vg_name lv_name (Some i.local_device) | None -> ()
 

xenvm/lvresize.ml

@@ -32,9 +32,20 @@ let lvresize copts live (vg_name,lv_opt) real_size percent_size =
 
     let resize_remotely () =
       if device_is_active then Devmapper.suspend name;
-      ( match size with
-        | `Absolute size -> Client.resize lv_name size
-        | `IncreaseBy delta -> Client.resize lv_name Int64.(add delta (mul (mul 512L vg.Lvm.Vg.extent_size) (Lvm.Lv.size_in_extents lv))) )
+      Lwt.catch
+        (fun () ->
+          match size with
+          | `Absolute size -> Client.resize lv_name size
+          | `IncreaseBy delta -> Client.resize lv_name Int64.(add delta (mul (mul 512L vg.Lvm.Vg.extent_size) (Lvm.Lv.size_in_extents lv))) 
+        ) (function
+          | Xenvm_interface.Insufficient_free_space(needed, available) ->
+            Printf.fprintf Pervasives.stderr "Insufficient free space: %Ld extents needed, but only %Ld available\n%!" needed available;
+            if device_is_active then Devmapper.resume name;
+            exit 5
+          | e ->
+            if device_is_active then Devmapper.resume name;
+            fail e
+        )
       >>= fun () ->
       if device_is_active then begin
         Client.get_lv ~name:lv_name >>= fun (vg, lv) ->

xenvm/xenvm_common.ml

@@ -462,7 +462,7 @@ let print_table noheadings header rows =
 let (>>*=) m f = match m with
   | `Error (`Msg e) -> fail (Failure e)
   | `Error (`DuplicateLV x) -> fail (Failure (Printf.sprintf "%s is a duplicate LV name" x))
-  | `Error (`OnlyThisMuchFree x) -> fail (Failure (Printf.sprintf "There is only %Ld free" x))
+  | `Error (`OnlyThisMuchFree (needed, available)) -> fail (Xenvm_interface.Insufficient_free_space(needed, available))
   | `Error (`UnknownLV x) -> fail (Failure (Printf.sprintf "I couldn't find an LV named %s" x))
   | `Ok x -> f x
 

xenvmd/xenvmd.ml

@@ -541,7 +541,7 @@ module FreePool = struct
                freename size_mib config.Config.host_low_water_mark config.Config.host_allocation_quantum;
              (* find free space in the VG *)
              begin match !journal, Lvm.Pv.Allocator.find x.Lvm.Vg.free_space Int64.(div config.Config.host_allocation_quantum extent_size_mib) with
-             | _, `Error (`OnlyThisMuchFree free_extents) ->
+             | _, `Error (`OnlyThisMuchFree (needed_extents, free_extents)) ->
                info "LV %s is %Ld MiB but total space free (%Ld MiB) is less than allocation quantum (%Ld MiB)"
                  freename size_mib Int64.(mul free_extents extent_size_mib) config.Config.host_allocation_quantum;
                (* try again later *)