From 7bbfb2e9fa9830ef3f377ec190945f5ff65a452a Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 26 Oct 2018 21:35:40 +0200 Subject: [PATCH] use vmm_cli --- app/vmm_cli.ml | 45 +++++++++++++++++++++++++++++++ app/vmmc_local.ml | 64 ++++++++------------------------------------- app/vmmc_remote.ml | 32 +++-------------------- app/vmmd.ml | 3 --- app/vmmd_console.ml | 15 +++-------- app/vmmd_influx.ml | 39 +++------------------------ app/vmmd_log.ml | 20 ++++---------- app/vmmd_stats.ml | 18 +++---------- app/vmmd_tls.ml | 13 +-------- app/vmmp_request.ml | 27 ++----------------- 10 files changed, 78 insertions(+), 198 deletions(-) diff --git a/app/vmm_cli.ml b/app/vmm_cli.ml index 3612518..88dd2ec 100644 --- a/app/vmm_cli.ml +++ b/app/vmm_cli.ml @@ -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) diff --git a/app/vmmc_local.ml b/app/vmmc_local.ml index 5816b4f..a741c71 100644 --- a/app/vmmc_local.ml +++ b/app/vmmc_local.ml @@ -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 = diff --git a/app/vmmc_remote.ml b/app/vmmc_remote.ml index 5572a8f..5a717db 100644 --- a/app/vmmc_remote.ml +++ b/app/vmmc_remote.ml @@ -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 diff --git a/app/vmmd.ml b/app/vmmd.ml index bb39ae4..300d209 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -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 diff --git a/app/vmmd_console.ml b/app/vmmd_console.ml index 9f025ae..96a5383 100644 --- a/app/vmmd_console.ml +++ b/app/vmmd_console.ml @@ -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)), diff --git a/app/vmmd_influx.ml b/app/vmmd_influx.ml index 2170fec..22812bf 100644 --- a/app/vmmd_influx.ml +++ b/app/vmmd_influx.ml @@ -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 () = diff --git a/app/vmmd_log.ml b/app/vmmd_log.ml index 09f1b2a..969b688 100644 --- a/app/vmmd_log.ml +++ b/app/vmmd_log.ml @@ -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 diff --git a/app/vmmd_stats.ml b/app/vmmd_stats.ml index dfe28d9..4f0e909 100644 --- a/app/vmmd_stats.ml +++ b/app/vmmd_stats.ml @@ -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)), diff --git a/app/vmmd_tls.ml b/app/vmmd_tls.ml index 6694efe..8de112f 100644 --- a/app/vmmd_tls.ml +++ b/app/vmmd_tls.ml @@ -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 diff --git a/app/vmmp_request.ml b/app/vmmp_request.ml index caa9110..8bb98c6 100644 --- a/app/vmmp_request.ml +++ b/app/vmmp_request.ml @@ -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)),