Merge pull request #91 from xapi-project/more-tunnelling

xenvm: log command-lines and output to syslog

Author: djs55

xenvm/lvchange.ml

@@ -49,17 +49,19 @@ let deactivate vg lv =
     let result =
       try
         if List.mem name all then Devmapper.remove name;
-        `Ok ()
+        return (`Ok ())
       with e ->
-        Printf.fprintf stderr "Caught %s while removing dm device %s\n%!" (Printexc.to_string e) name;
+        stderr "Caught %s while removing dm device %s" (Printexc.to_string e) name
+        >>= fun () ->
         if n = 0 then raise e;
-        `Retry in
-    match result with
-    | `Ok () -> ()
+        return `Retry in
+    result >>= function
+    | `Ok () -> return ()
     | `Retry ->
       Unix.sleep 1;
       retry (n - 1) in
-  retry 30;
+  retry 30
+  >>= fun () ->
   (* Delete the device node *)
   let path = dev_path_of vg.Lvm.Vg.name lv.Lvm.Lv.name in
   Lwt.catch (fun () -> Lwt_unix.unlink path) (fun _ -> Lwt.return ()) >>= fun () ->

xenvm/lvdisplay.ml

@@ -34,7 +34,7 @@ let print_verbose vg lv =
     *)
     "";
   ] in
-  List.iter (fun line -> Printf.printf "  %s\n" line) lines
+  Lwt_list.iter_s (fun line -> stdout "  %s" line) lines
 
 let print_colon vg lv =
   let sectors = Int64.mul vg.Lvm.Vg.extent_size (Lvm.Lv.size_in_extents lv) in
@@ -53,7 +53,7 @@ let print_colon vg lv =
     "?"; (* major *)
     "?"; (* minor *)
   ] in
-  Printf.printf "  %s\n" (String.concat ":" parts)
+  stdout "  %s" (String.concat ":" parts)
 
 let lvdisplay copts colon (vg_name,lv_display_opt) =
   let open Xenvm_common in
@@ -63,17 +63,17 @@ let lvdisplay copts colon (vg_name,lv_display_opt) =
     set_uri copts info;
     Client.get () >>= fun vg ->
     let print = if colon then print_colon else print_verbose in
-    let success = ref false in
-    Lvm.Vg.LVs.iter (fun _ lv -> match lv_display_opt with
-      | None ->
-        print vg lv;
-        success := true
-      | Some lv' when lv.Lvm.Lv.name = lv' ->
-        print vg lv;
-        success := true
-      | Some _ -> ()
-    ) vg.Lvm.Vg.lvs;
-    if not !success then failwith "Failed to find any matching logical volumes";
+    let to_print =
+      Lvm.Vg.LVs.bindings vg.Lvm.Vg.lvs
+      |> List.map snd (* only interested in the LV, not the id *)
+      |> List.filter (function { Lvm.Lv.name } -> match lv_display_opt with
+        | None -> true
+        | Some lv' when lv' = name -> true
+        | _ -> false
+        ) in
+    Lwt_list.iter_s (print vg) to_print
+    >>= fun () ->
+    if to_print = [] then failwith "Failed to find any matching logical volumes";
     Lwt.return () in
   Lwt_main.run t
 

xenvm/lvresize.ml

@@ -62,10 +62,12 @@ let lvresize copts live (vg_name,lv_opt) real_size percent_size =
       >>= fun () ->
       match resp with
       | ResizeResponse.Device_mapper_device_does_not_exist name ->
-        Printf.fprintf stderr "Device mapper device does not exist: %s\n%!" name;
+        stderr "Device mapper device does not exist: %s" name
+        >>= fun () ->
         exit 1
       | ResizeResponse.Request_for_no_segments nr ->
-        Printf.fprintf stderr "Request for an illegal number of segments: %Ld\n%!" nr;
+        stderr "Request for an illegal number of segments: %Ld" nr
+        >>= fun () ->
         exit 2
       | ResizeResponse.Success ->
         return () in

xenvm/lvs.ml

@@ -40,8 +40,10 @@ let lvs copts noheadings nosuffix units fields (vg_name,lv_name_opt) =
     Lwt.catch
       (Client.get)
       (fun _ ->
-        Printf.fprintf stderr "  Volume group \"%s\" not found\n" vg_name;
-        Printf.fprintf stderr "  Skipping volume group %s\n%!" vg_name;
+        stderr "  Volume group \"%s\" not found" vg_name
+        >>= fun () ->
+        stderr "  Skipping volume group %s" vg_name
+        >>= fun () ->
         exit 1)
     >>= fun vg ->
 
@@ -54,8 +56,8 @@ let lvs copts noheadings nosuffix units fields (vg_name,lv_name_opt) =
         let lv = List.find (fun lv -> lv.Lvm.Lv.name = lv_name) lvs in
 	do_row dev vg lv
     in
-    print_table noheadings (" "::headings) (List.map (fun r -> " "::r) rows);
-    Lwt.return ()
+    let lines = print_table noheadings (" "::headings) (List.map (fun r -> " "::r) rows) in
+    Lwt_list.iter_s (fun x -> stdout "%s" x) lines
   )
 
 let lvs_cmd =

xenvm/pvcreate.ml

@@ -9,8 +9,9 @@ module Pv_IO = Pv.Make(Block)
 
 let pvcreate copts ff y metadatasize filenames =
   let open Xenvm_common in
-  Printf.fprintf stderr "NOTE: pvcreate is currently a no-op\n%!";
-  ()
+  Lwt_main.run (
+    stderr "NOTE: pvcreate is currently a no-op"
+  )
 
 let f =
   let doc = "Force the command and override safety-checks" in

xenvm/pvs.ml

@@ -32,8 +32,8 @@ let pvs copts noheadings nosuffix units fields devices =
       vg.Lvm.Vg.pvs in
     let headings = headings_of fields in
     let rows = List.concat (List.map (fun vg -> do_row (Vg_IO.metadata_of vg)) vgs) in
-    print_table noheadings (" "::headings) (List.map (fun r -> " "::r) rows);
-    Lwt.return ()
+    let lines = print_table noheadings (" "::headings) (List.map (fun r -> " "::r) rows) in
+    Lwt_list.iter_s (fun x -> stdout "%s" x) lines
   )
 
 let pvs_cmd =

xenvm/vgs.ml

@@ -50,14 +50,16 @@ let vgs copts noheadings nosuffix units fields vg_names =
               )
           )
           (fun _ ->
-            Printf.fprintf stderr "  Volume group \"%s\" not found\n" vg_name;
-            Printf.fprintf stderr "  Skipping volume group %s\n%!" vg_name;
+            stderr "  Volume group \"%s\" not found" vg_name
+            >>= fun () ->
+            stderr "  Skipping volume group %s" vg_name
+            >>= fun () ->
             exit 1)
         >>= fun vg ->
       Lwt.return (info,vg)) vg_names >>= fun vgs ->
     let rows = List.concat (List.map do_row vgs) in
-    print_table noheadings (" "::headings) (List.map (fun r -> " "::r) rows);
-    Lwt.return ()
+    let lines = print_table noheadings (" "::headings) (List.map (fun r -> " "::r) rows) in
+    Lwt_list.iter_s (fun x -> stdout "%s" x) lines
   )
 
 let vgs_cmd =

xenvm/xenvm.ml

@@ -47,13 +47,6 @@ let table_of_vg vg =
   [ "free_space"; Int64.to_string (Pv.Allocator.size vg.Vg.free_space) ];
 ]
 
-let lvs config =
-  set_uri config None;
-  Lwt_main.run 
-    (Client.get () >>= fun vg ->
-     print_table true [ "key"; "value" ] (table_of_vg vg);
-     Lwt.return ())
-
 let format config name filenames =
     let t =
       let module Vg_IO = Vg.Make(Log)(Block)(Time)(Clock) in
@@ -145,8 +138,8 @@ let host_list copts (vg_name,_) =
       fromLVM @ toLVM @ [ [ "freeExtents"; Int64.to_string h.freeExtents ] ] in
     List.map (fun h -> add_prefix h.name (table_of_host h)) hosts
     |> List.concat
-    |> print_table true [ "key"; "value" ];
-    return () in
+    |> print_table true [ "key"; "value" ]
+    |> Lwt_list.iter_s (fun x -> stdout "%s" x) in
   Lwt_main.run t
 
 let shutdown copts (vg_name,_) =
@@ -162,7 +155,8 @@ let shutdown copts (vg_name,_) =
         (fun () ->
           Client.Host.all ()
           >>= fun _ ->
-          Printf.fprintf stderr "Xenvmd is still alive: will sleep 5s and try again\n%!";
+          stderr "Xenvmd is still alive: will sleep 5s and try again"
+          >>= fun () ->
           Lwt_unix.sleep 5.
         ) (fun _ ->
           finished := true;
@@ -184,8 +178,9 @@ let benchmark copts (vg_name,_) =
     | n ->
       f n
       >>= fun () ->
-      if ((n * 100) / number) <> (((n + 1) * 100) / number)
-      then Printf.fprintf stderr "%s %d %% complete\n%!" test_name (100 - (n * 100) / number);
+      ( if ((n * 100) / number) <> (((n + 1) * 100) / number)
+        then stderr "%s %d %% complete\n%!" test_name (100 - (n * 100) / number)
+        else return () ) >>= fun () ->
       fori test_name ((number - n, Unix.gettimeofday () -. start) :: acc) f (n - 1) in
     fori "Creating volumes" [] (fun i -> Client.create ~name:(Printf.sprintf "test-lv-%d" i) ~size:mib ~tags:[]) number
     >>= fun creates ->
@@ -205,8 +200,9 @@ let benchmark copts (vg_name,_) =
   Lwt_main.run t
 
 let help config =
-  Printf.printf "help - %s %s\n" config.config (match config.uri_override with | Some u -> u | None -> "URI unset")
-
+  Lwt_main.run (
+    stdout "help - %s %s" config.config (match config.uri_override with | Some u -> u | None -> "URI unset")
+  )
 
 open Cmdliner
 let info =
@@ -242,17 +238,6 @@ let size =
   let doc = "Size of the LV in megs" in
   Arg.(value & opt int64 4L & info ["size"] ~docv:"SIZE" ~doc)
 
-
-let lvs_cmd =
-  let doc = "List the logical volumes in the VG" in
-  let man = [
-    `S "DESCRIPTION";
-    `P "Contacts the XenVM LVM daemon and retreives a list of
-      all of the currently defined logical volumes";
-  ] in
-  Term.(pure lvs $ copts_t),
-  Term.info "lvs" ~sdocs:copts_sect ~doc ~man
-
 let format_cmd =
   let doc = "Format the specified file as a VG" in
   let man = [
@@ -377,6 +362,8 @@ let cmds = [
 
 let () =
   Random.self_init ();
+  Lwt_main.run (
+    Lwt_log.log ~logger:syslog ~level:Lwt_log.Notice (String.concat " " (Array.to_list Sys.argv))
+  );
   match Term.eval_choice default_cmd cmds with
   | `Error _ -> exit 1 | _ -> exit 0
-

xenvm/xenvm_common.ml

@@ -3,6 +3,17 @@ open Cmdliner
 open Lwt
 open Errors
 
+let syslog = Lwt_log.syslog ~facility:`Daemon ()
+
+let stdout fmt = Printf.ksprintf (fun s ->
+  Printf.printf "%s\n%!" s;
+  Lwt_log.log ~logger:syslog ~level:Lwt_log.Notice ("stdout:" ^ s)
+) fmt
+let stderr fmt = Printf.ksprintf (fun s ->
+  Printf.fprintf stderr "%s\n%!" s;
+  Lwt_log.log ~logger:syslog ~level:Lwt_log.Notice ("stderr:" ^ s)
+) fmt
+
 module Time = struct
   type 'a io = 'a Lwt.t
   let sleep = Lwt_unix.sleep
@@ -355,10 +366,12 @@ let set_vg_info_t copts uri local_device local_allocator_path unix_domain_sock_p
       Lwt_io.fprintf f "%s" s))
     (function
     | Unix.Unix_error(Unix.ENOENT, _, s) ->
-      Printf.fprintf stderr "Unable to open file: Does the config dir '%s' exist?\n" copts.config;
+      stderr "Unable to open file: Does the config dir '%s' exist?" copts.config
+      >>= fun () ->
       exit 1
     | Unix.Unix_error(Unix.EACCES, _, _) ->
-      Printf.fprintf stderr "Permission denied. You may need to rerun with 'sudo'\n";
+      stderr "Permission denied. You may need to rerun with 'sudo'"
+      >>= fun () ->
       exit 1
     |e -> Lwt.fail e)
 
@@ -422,10 +435,10 @@ let print_table noheadings header rows =
     List.fold_left max 0 widths in
   let widths = List.rev (snd(List.fold_left (fun (i, acc) _ -> (i + 1, (width_of_column i) :: acc)) (0, []) header)) in
   let print_row row =
-    List.iter (fun (n, s) -> Printf.printf "%s " (padto ' ' n s)) (List.combine widths row);
-    Printf.printf "\n" in
-  if not noheadings then print_row header;
-  List.iter print_row rows
+    String.concat "" (List.map (fun (n, s) -> Printf.sprintf "%s " (padto ' ' n s)) (List.combine widths row)) in
+  if noheadings
+  then List.map print_row rows
+  else print_row header :: (List.map print_row rows)
 
 let (>>*=) m f = match m with
   | `Error (`Msg e) -> fail (Failure e)