reynir
/
albatross
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

use vmm_cli

This commit is contained in:
Hannes Mehnert 2018-10-26 21:35:40 +02:00
parent cc29ddc98c
commit 7bbfb2e9fa
10 changed files with 78 additions and 198 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
app/vmm_cli.ml
View File

@ -9,3 +9,48 @@ let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
let host_port : (string * int) Arg.converter =
let parse s =
match Astring.String.cut ~sep:":" s with
| None -> `Error "broken: no port specified"
| Some (hostname, port) ->
try
`Ok (hostname, int_of_string port)
with
Not_found -> `Error "failed to parse port"
in
parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d" h p
let bridge =
let parse s =
match Astring.String.cuts ~sep:"/" s with
| [ name ; fst ; lst ; gw ; nm ] ->
begin match Ipaddr.V4.(of_string fst, of_string lst, of_string gw) with
| Some fst, Some lst, Some gw ->
(try
let nm = int_of_string nm in
if nm > 0 && nm <= 32 then
let net = Ipaddr.V4.Prefix.make nm gw in
if Ipaddr.V4.Prefix.mem fst net && Ipaddr.V4.Prefix.mem lst net then
`Ok (`External (name, fst, lst, gw, nm))
else
`Error "first or last IP are not in subnet"
else
`Error "netmask must be > 0 and <= 32"
with Failure _ -> `Error "couldn't parse netmask")
| _ -> `Error "couldn't parse IP address"
end
| [ name ] -> `Ok (`Internal name)
| _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')"
in
(parse, Vmm_core.pp_bridge)
let vm_c =
let parse s = `Ok (Vmm_core.id_of_string s)
in
(parse, Vmm_core.pp_id)
let opt_vm_name =
let doc = "name of virtual machine." in
Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc)

64
app/vmmc_local.ml
View File

@ -117,21 +117,12 @@ let help _ _ man_format cmds = function
| Some t when List.mem t cmds -> `Help (man_format, Some t)
| Some _ -> List.iter print_endline cmds; `Ok ()
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
open Vmm_cli
let socket =
let doc = "Socket to connect to" in
Arg.(value & opt (some string) None & info [ "s" ; "socket" ] ~doc)
Arg.(value & opt (some string) None & info [ "socket" ] ~doc)
let force =
let doc = "force VM creation." in
@ -141,11 +132,6 @@ let image =
let doc = "File of virtual machine image." in
Arg.(required & pos 1 (some file) None & info [] ~doc)
let vm_c =
let parse s = `Ok (Vmm_core.id_of_string s)
in
(parse, Vmm_core.pp_id)
let vm_name =
let doc = "Name virtual machine." in
Arg.(required & pos 0 (some vm_c) None & info [] ~doc)
@ -159,17 +145,13 @@ let destroy_cmd =
Term.(ret (const destroy $ setup_log $ socket $ vm_name)),
Term.info "destroy" ~doc ~man
let opt_vmname =
let doc = "Name virtual machine." in
Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc)
let remove_policy_cmd =
let doc = "removes a policy" in
let man =
[`S "DESCRIPTION";
`P "Removes a policy."]
in
Term.(ret (const remove_policy $ setup_log $ socket $ opt_vmname)),
Term.(ret (const remove_policy $ setup_log $ socket $ opt_vm_name)),
Term.info "remove_policy" ~doc ~man
let info_cmd =
@ -178,7 +160,7 @@ let info_cmd =
[`S "DESCRIPTION";
`P "Shows information about VMs."]
in
Term.(ret (const info_ $ setup_log $ socket $ opt_vmname)),
Term.(ret (const info_ $ setup_log $ socket $ opt_vm_name)),
Term.info "info" ~doc ~man
let policy_cmd =
@ -187,11 +169,11 @@ let policy_cmd =
[`S "DESCRIPTION";
`P "Shows information about policies."]
in
Term.(ret (const policy $ setup_log $ socket $ opt_vmname)),
Term.(ret (const policy $ setup_log $ socket $ opt_vm_name)),
Term.info "policy" ~doc ~man
let cpus =
let doc = "CPUids to allow" in
let doc = "CPUs to allow" in
Arg.(value & opt_all int [] & info [ "cpu" ] ~doc)
let vms =
@ -206,33 +188,9 @@ let mem =
let doc = "Memory to allow" in
Arg.(value & opt int 512 & info [ "mem" ] ~doc)
let b =
let parse s =
match String.cuts ~sep:"/" s with
| [ name ; fst ; lst ; gw ; nm ] ->
begin match Ipaddr.V4.(of_string fst, of_string lst, of_string gw) with
| Some fst, Some lst, Some gw ->
(try
let nm = int_of_string nm in
if nm > 0 && nm <= 32 then
let net = Ipaddr.V4.Prefix.make nm gw in
if Ipaddr.V4.Prefix.mem fst net && Ipaddr.V4.Prefix.mem lst net then
`Ok (`External (name, fst, lst, gw, nm))
else
`Error "first or last IP are not in subnet"
else
`Error "netmask must be > 0 and <= 32"
with Failure _ -> `Error "couldn't parse netmask")
| _ -> `Error "couldn't parse IP address"
end
| [ name ] -> `Ok (`Internal name)
| _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')"
in
(parse, Vmm_core.pp_bridge)
let bridge =
let doc = "Bridge to provision" in
Arg.(value & opt_all b [] & info [ "bridge" ] ~doc)
let doc = "Bridge to allow" in
Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc)
let add_policy_cmd =
let doc = "Add a policy" in
@ -240,7 +198,7 @@ let add_policy_cmd =
[`S "DESCRIPTION";
`P "Adds a policy."]
in
Term.(ret (const add_policy $ setup_log $ socket $ opt_vmname $ vms $ mem $ cpus $ block $ bridge)),
Term.(ret (const add_policy $ setup_log $ socket $ opt_vm_name $ vms $ mem $ cpus $ block $ bridge)),
Term.info "add_policy" ~doc ~man
let cpu =
@ -294,7 +252,7 @@ let stats_cmd =
[`S "DESCRIPTION";
`P "Shows statistics of VMs."]
in
Term.(ret (const stats $ setup_log $ socket $ opt_vmname)),
Term.(ret (const stats $ setup_log $ socket $ opt_vm_name)),
Term.info "stats" ~doc ~man
let log_cmd =
@ -303,7 +261,7 @@ let log_cmd =
[`S "DESCRIPTION";
`P "Shows event log of VM."]
in
Term.(ret (const event_log $ setup_log $ socket $ opt_vmname $ since)),
Term.(ret (const event_log $ setup_log $ socket $ opt_vm_name $ since)),
Term.info "log" ~doc ~man
let help_cmd =

32
app/vmmc_remote.ml
View File

@ -23,7 +23,6 @@ let client cas host port cert priv_key =
Lwt_unix.gethostbyname host >>= fun host_entry ->
let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in
let fd = Lwt_unix.socket host_entry.Lwt_unix.h_addrtype Lwt_unix.SOCK_STREAM 0 in
Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ ->
X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
let certificates = `Single cert in
@ -43,33 +42,8 @@ let run_client _ cas cert key (host, port) =
Sys.(set_signal sigpipe Signal_ignore) ;
Lwt_main.run (client cas host port cert key)
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
let host_port : (string * int) Arg.converter =
let parse s =
try
let open String in
let colon = index s ':' in
let hostname = sub s 0 colon
and port =
let csucc = succ colon in
sub s csucc (length s - csucc)
in
`Ok (hostname, int_of_string port)
with
Not_found -> `Error "broken"
in
parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d" h p
open Vmm_cli
let cas =
let doc = "The full path to PEM encoded certificate authorities. Can either be a FILE or a DIRECTORY." in
@ -88,13 +62,13 @@ let destination =
~doc:"the destination hostname:port to connect to")
let cmd =
let doc = "VMM TLS client" in
let doc = "VMM remote TLS client" in
let man = [
`S "DESCRIPTION" ;
`P "$(tname) connects to a server and initiates a TLS handshake" ]
in
Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination),
Term.info "vmmd_remote" ~version:"%%VERSION_NUM%%" ~doc ~man
Term.info "vmmc_remote" ~version:"%%VERSION_NUM%%" ~doc ~man
let () =
match Term.eval cmd

3
app/vmmd.ml
View File

@ -51,7 +51,6 @@ let create process cont =
| Ok () -> ()
let handle out fd addr =
(* out is for `Log | `Stat | `Cons (including reconnect semantics) *)
Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ;
(* now we need to read a packet and handle it
(1)
@ -152,8 +151,6 @@ let rec stats_loop () =
Lwt_unix.sleep 600. >>= fun () ->
stats_loop ()
(* TODO nobody reads stat and log file descriptors - that's likely a bad idea!
- create_mbox could after take & write do a read and check for failures! *)
let jump _ =
Sys.(set_signal sigpipe Signal_ignore) ;
Lwt_main.run

15
app/vmmd_console.ml
View File

@ -170,22 +170,13 @@ let jump _ file =
in
loop ())
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
open Vmm_cli
let socket =
let doc = "Socket to listen on" in
let sock = Vmm_core.socket_path `Console in
Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
let doc = "socket to use" in
Arg.(value & opt string (Vmm_core.socket_path `Console) & info [ "socket" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ socket)),

39
app/vmmd_influx.ml
View File

@ -279,55 +279,24 @@ let run_client _ socket (influxhost, influxport) vm =
Sys.(set_signal sigpipe Signal_ignore) ;
Lwt_main.run (client socket influxhost influxport vm)
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
let host_port : (string * int) Arg.converter =
let parse s =
match String.cut ~sep:":" s with
| None -> `Error "broken: no port specified"
| Some (hostname, port) ->
try
`Ok (hostname, int_of_string port)
with
Not_found -> `Error "failed to parse port"
in
parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d" h p
open Vmm_cli
let socket =
let doc = "Stat socket to connect onto" in
let sock = Vmm_core.socket_path `Stats in
Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
let doc = "socket to use" in
Arg.(value & opt string (Vmm_core.socket_path `Stats) & info [ "socket" ] ~doc)
let influx =
Arg.(required & pos 0 (some host_port) None & info [] ~docv:"influx"
~doc:"the influx hostname:port to connect to")
let vm_c =
let parse s = `Ok (Vmm_core.id_of_string s)
in
(parse, Vmm_core.pp_id)
let opt_vmname =
let doc = "Name virtual machine." in
Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc)
let cmd =
let doc = "VMM InfluxDB connector" in
let man = [
`S "DESCRIPTION" ;
`P "$(tname) connects to a vmm stats socket, pulls statistics and pushes them via TCP to influxdb" ]
in
Term.(pure run_client $ setup_log $ socket $ influx $ opt_vmname),
Term.(pure run_client $ setup_log $ socket $ influx $ opt_vm_name),
Term.info "vmmd_influx" ~version:"%%VERSION_NUM%%" ~doc ~man
let () =

20
app/vmmd_log.ml
View File

@ -71,8 +71,6 @@ let write_to_file file =
in
mvar, write_loop
let tree = ref Vmm_trie.empty
let send_history s ring id ts =
let elements =
match ts with
@ -96,6 +94,8 @@ let send_history s ring id ts =
| Error e -> Lwt.return (Error e))
(Ok ()) (List.rev res)
let tree = ref Vmm_trie.empty
let handle_data s mvar ring hdr entry =
if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin
Logs.warn (fun m -> m "unsupported version") ;
@ -187,22 +187,12 @@ let jump _ file sock =
Lwt.pick [ loop () ; writer () ]) ;
`Ok ()
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
open Vmm_cli
let socket =
let doc = "Socket to listen on" in
let sock = Vmm_core.socket_path `Log in
Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
let doc = "socket to use" in
Arg.(value & opt string (Vmm_core.socket_path `Log) & info [ "socket" ] ~doc)
let file =
let doc = "File to write the log to" in

18
app/vmmd_stats.ml
View File

@ -92,26 +92,16 @@ let jump _ file interval =
in
loop ())
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
open Vmm_cli
let socket =
let doc = "Socket to listen on" in
let sock = Vmm_core.socket_path `Stats in
Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
let doc = "socket to use" in
Arg.(value & opt string (Vmm_core.socket_path `Stats) & info [ "socket" ] ~doc)
let interval =
let doc = "Interval between statistics gatherings (in seconds)" in
Arg.(value & opt int 10 & info [ "internval" ] ~doc)
Arg.(value & opt int 10 & info [ "interval" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ socket $ interval)),

13
app/vmmd_tls.ml
View File

@ -135,19 +135,8 @@ let jump _ cacert cert priv_key port =
in
loop ())
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
(* TODO needs CRL as well, plus socket(s) *)
open Vmm_cli
let cacert =
let doc = "CA certificate" in

27
app/vmmp_request.ml
View File

@ -107,6 +107,7 @@ let jump _ name key vms mem cpus block bridges =
| Error (`Msg m) -> `Error (false, m)
open Cmdliner
open Vmm_cli
let cpus =
let doc = "CPUids to provision" in
@ -120,33 +121,9 @@ let block =
let doc = "Block storage to provision" in
Arg.(value & opt (some int) None & info [ "block" ] ~doc)
let b =
let parse s =
match String.cuts ~sep:"/" s with
| [ name ; fst ; lst ; gw ; nm ] ->
begin match Ipaddr.V4.(of_string fst, of_string lst, of_string gw) with
| Some fst, Some lst, Some gw ->
(try
let nm = int_of_string nm in
if nm > 0 && nm <= 32 then
let net = Ipaddr.V4.Prefix.make nm gw in
if Ipaddr.V4.Prefix.mem fst net && Ipaddr.V4.Prefix.mem lst net then
`Ok (`External (name, fst, lst, gw, nm))
else
`Error "first or last IP are not in subnet"
else
`Error "netmask must be > 0 and <= 32"
with Failure _ -> `Error "couldn't parse netmask")
| _ -> `Error "couldn't parse IP address"
end
| [ name ] -> `Ok (`Internal name)
| _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')"
in
(parse, Vmm_core.pp_bridge)
let bridge =
let doc = "Bridge to provision" in
Arg.(value & opt_all b [] & info [ "bridge" ] ~doc)
Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ nam $ key $ vms $ mem $ cpus $ block $ bridge)),