Merge pull request #216 from jonludlam/clis

Fix the memory CLI and add a network one

Author: mseri

gpumon/gpumon_cli.ml

@@ -19,4 +19,8 @@ let cli () =
   let rpc = Gpumon_client.rpc in
   Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ()))
 
-let _ = cli ()
+let _ =
+  match cli () with
+  | `Ok f -> f ()
+  | _ -> ()
+

memory/memory_cli.ml

@@ -18,6 +18,8 @@ let default_cmd =
 
 let cli () =
   let rpc = Memory_client.rpc in
-  Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ()))
+  match Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ())) with
+  | `Ok f -> f ()
+  | _ -> ()
 
 let _ = cli ()

network/jbuild

@@ -31,11 +31,26 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {|
  ((name xcp_network)
   (public_name xcp.network)
   (flags (:standard -w -39-33 %s))
+  (modules (:standard \ network_cli))
   (libraries
    (rpclib
     threads
     xcp))
   (wrapped false)
   %s))
 
+(executable
+ ((name network_cli)
+  (modules (network_cli))
+  (libraries
+   (cmdliner
+    rpclib.cmdliner
+    rpclib.markdown
+    xcp.network))))
+
+(alias
+ ((name runtest)
+   (deps (network_cli.exe))
+     (action (run ${<}))))
+
 |} (flags rewriters_ppx) coverage_rewriter

network/network_cli.ml

@@ -0,0 +1,26 @@
+(* Network CLI *)
+
+open Network_interface
+
+module Cmds = Interface_API(Cmdlinergen.Gen ())
+
+let version_str description =
+  let maj,min,mic = description.Idl.Interface.version in
+  Printf.sprintf "%d.%d.%d" maj min mic
+
+let default_cmd =
+  let doc = String.concat "" [
+    "A CLI for the network API. This allows scripting of the xcp-networkd daemon ";
+    "for testing and debugging. This tool is not intended to be used as an ";
+    "end user tool"] in
+  Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())),
+  Cmdliner.Term.info "network_cli" ~version:(version_str Cmds.description) ~doc
+
+let cli () =
+  let rpc = Network_client.rpc in
+  Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ()))
+
+let _ =
+  match cli () with
+  | `Ok f -> f ()
+  | _ -> ()

v6/v6_cli.ml

@@ -18,4 +18,8 @@ let cli () =
   let rpc = V6_client.rpc in
   Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ()))
 
-let _ = cli ()
+let _ =
+  match cli () with
+  | `Ok f -> f ()
+  | _ -> ()
+