Merge pull request #144 from djs55/diagnostics

Add xenvm diagnostics commands

Author: djs55

xenvm/lvdump.ml

@@ -0,0 +1,61 @@
+(* LVM compatible bits and pieces *)
+
+open Cmdliner
+open Lwt
+open Xenvm_common
+open Errors
+
+module Vg_IO = Lvm.Vg.Make(Log)(Block)(Time)(Clock)
+
+let to_file (vg_name, lv_name) local_device oc =
+  with_block local_device
+    (fun x ->
+      Vg_IO.connect [ x ] `RO >>|= fun vg ->
+      match Vg_IO.find vg lv_name with
+      | None -> failwith (Printf.sprintf "Failed to find LV %s" lv_name)
+      | Some vol ->
+      Vg_IO.Volume.connect vol
+      >>= function
+      | `Error _ -> fail (Failure (Printf.sprintf "Failed to open %s" lv_name))
+      | `Ok disk ->
+        Vg_IO.Volume.get_info disk
+        >>= fun info ->
+        let buffer = Io_page.(to_cstruct (get 1024)) in
+        let nsectors = Cstruct.len buffer / info.Vg_IO.Volume.sector_size in
+        let rec loop = function
+          | n when n = info.Vg_IO.Volume.size_sectors -> return ()
+          | n ->
+            let remaining = Int64.sub info.Vg_IO.Volume.size_sectors n in
+            let toread = min (Int64.to_int remaining) nsectors in
+            let buffer' = Cstruct.sub buffer 0 (toread * info.Vg_IO.Volume.sector_size) in
+            Vg_IO.Volume.read disk n [ buffer' ]
+            >>= function
+            | `Ok () ->
+              Lwt_io.write oc (Cstruct.to_string buffer')
+              >>= fun () ->
+              loop (Int64.(add n (of_int toread)))
+            | _ -> failwith (Printf.sprintf "Failed to read sector %Ld" n) in
+        loop 0L
+    )
+
+let lvdump copts (vg_name, lv_name_opt) physical_device : unit =
+  let open Xenvm_common in
+  let lv_name = match lv_name_opt with Some l -> l | None -> failwith "Need LV name" in
+  Lwt_main.run (
+    get_vg_info_t copts vg_name >>= fun info ->
+    set_uri copts info;
+    let local_device : string = match (info,physical_device) with
+      | _, Some d -> d (* cmdline overrides default for the VG *)
+      | Some info, None -> info.local_device (* If we've got a default, use that *)
+      | None, None -> failwith "Need to know the local device!" in
+    to_file (vg_name, lv_name) local_device Lwt_io.stdout
+  )
+
+let lvdump_cmd =
+  let doc = "Dump the physical contents of a logical volume" in
+  let man = [
+    `S "DESCRIPTION";
+    `P "lvdump allows you to dump the physical contents of a logical volume to stdout."
+  ] in
+  Term.(pure lvdump $ Xenvm_common.copts_t $ Xenvm_common.name_arg $ Xenvm_common.physical_device_arg),
+  Term.info "lvdump" ~sdocs:"COMMON OPTIONS" ~doc ~man

xenvm/xenvm.ml

@@ -184,6 +184,23 @@ let host_disconnect copts (vg_name,_) uncooperative host =
     set_uri copts info;
     Client.Host.disconnect ~cooperative:(not uncooperative) ~name:host in
   Lwt_main.run t 
+let host_dump copts (vg_name,_) physical_device host =
+  let t =
+    get_vg_info_t copts vg_name >>= fun info ->
+    set_uri copts info;
+    let local_device : string = match (info,physical_device) with
+      | _, Some d -> d (* cmdline overrides default for the VG *)
+      | Some info, None -> info.local_device (* If we've got a default, use that *)
+      | None, None -> failwith "Need to know the local device!" in
+    Client.Host.all ()
+    >>= fun all ->
+    let open Xenvm_interface in
+    let h = List.find (fun h -> h.name = host) all in
+    Lwt_io.with_file Lwt_io.Output h.toLVM.lv (Lvdump.to_file (vg_name, h.toLVM.lv) local_device)
+    >>= fun () ->
+    Lwt_io.with_file Lwt_io.Output h.fromLVM.lv (Lvdump.to_file (vg_name, h.fromLVM.lv) local_device) in
+  Lwt_main.run t 
+
 let host_destroy copts (vg_name,_) host =
   let t =
     get_vg_info_t copts vg_name >>= fun info ->
@@ -399,6 +416,15 @@ let host_disconnect_cmd =
   Term.(pure host_disconnect $ copts_t $ name_arg $ uncooperative_flag $ hostname),
   Term.info "host-disconnect" ~sdocs:copts_sect ~doc ~man
 
+let host_dump_cmd =
+  let doc = "Dump a host's metadata volumes" in
+  let man = [
+    `S "DESCRIPTION";
+    `P "Copy the contents of a host's metadata volumes to local files in the current directory for forensic analysis.";
+  ] in
+  Term.(pure host_dump $ copts_t $ name_arg $ physical_device_arg $ hostname),
+  Term.info "host-dump" ~sdocs:copts_sect ~doc ~man
+
 let host_create_cmd =
   let doc = "Initialise a host's metadata volumes" in
   let man = [
@@ -462,7 +488,10 @@ let cmds = [
   dump_cmd;
   shutdown_cmd; host_create_cmd; host_destroy_cmd;
   host_list_cmd;
-  host_connect_cmd; host_disconnect_cmd; benchmark_cmd;
+  host_connect_cmd;
+  host_disconnect_cmd;
+  host_dump_cmd;
+  benchmark_cmd;
   Lvcreate.lvcreate_cmd;
   Lvchange.lvchange_cmd;
   Vgchange.vgchange_cmd;
@@ -477,6 +506,7 @@ let cmds = [
   Lvremove.lvremove_cmd;
   Lvrename.lvrename_cmd;
   Lvdisplay.lvdisplay_cmd;
+  Lvdump.lvdump_cmd;
 ]
 
 let () =