diff --git a/daemon/albatross_influx.ml b/daemon/albatross_influx.ml index ca9655c..85e5f04 100644 --- a/daemon/albatross_influx.ml +++ b/daemon/albatross_influx.ml @@ -174,7 +174,7 @@ let safe_close s = Logs.err (fun m -> m "exception %s while closing" (Printexc.to_string e)) ; Lwt.return_unit) -let rec read_sock_write_tcp c ?fd addr = +let rec read_sock_write_tcp drop c ?fd addr = match fd with | None -> begin @@ -184,10 +184,10 @@ let rec read_sock_write_tcp c ?fd addr = Logs.warn (fun m -> m "error connecting to influxd %a, retrying in 5s" Vmm_lwt.pp_sockaddr addr); Lwt_unix.sleep 5.0 >>= fun () -> - read_sock_write_tcp c addr + read_sock_write_tcp drop c addr | Some fd -> Lwt_unix.setsockopt fd Lwt_unix.SO_KEEPALIVE true ; - read_sock_write_tcp c ~fd addr + read_sock_write_tcp drop c ~fd addr end | Some fd -> Logs.debug (fun m -> m "reading from unix socket") ; @@ -206,7 +206,14 @@ let rec read_sock_write_tcp c ?fd addr = safe_close c >|= fun () -> false end else - let name = Name.to_string hdr.Vmm_commands.name in + let name = + let orig = hdr.Vmm_commands.name + and f = if drop then Name.drop_front else (fun a -> a) + in + let n = f orig in + let safe = if Name.is_root n then orig else n in + Name.to_string safe + in let ru = P.encode_ru name ru in let mem = match mem with None -> [] | Some m -> [ P.encode_kinfo_mem name m ] in let vmm = match vmm with None -> [] | Some vmm -> [ P.encode_vmm name vmm ] in @@ -216,7 +223,7 @@ let rec read_sock_write_tcp c ?fd addr = Vmm_lwt.write_raw fd (Bytes.unsafe_of_string out) >>= function | Ok () -> Logs.debug (fun m -> m "wrote successfully") ; - read_sock_write_tcp c ~fd addr + read_sock_write_tcp drop c ~fd addr | Error e -> Logs.err (fun m -> m "error %s while writing to tcp (%s)" (str_of_e e) name) ; @@ -226,7 +233,7 @@ let rec read_sock_write_tcp c ?fd addr = | Ok wire -> Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ; Lwt.return (Some fd) >>= fun fd -> - read_sock_write_tcp c ?fd addr + read_sock_write_tcp drop c ?fd addr let query_sock vm c = let header = Vmm_commands.{ version = my_version ; sequence = !command ; name = vm } in @@ -246,7 +253,7 @@ let rec maybe_connect () = Logs.debug (fun m -> m "connected"); Lwt.return c -let client influx vm = +let client influx vm drop = match influx with | None -> Lwt.return (Error (`Msg "influx host not provided")) | Some (ip, port) -> @@ -276,25 +283,29 @@ let client influx vm = in Lwt.return err | Ok () -> - read_sock_write_tcp c addr >>= fun restart -> + read_sock_write_tcp drop c addr >>= fun restart -> if restart then loop () else Lwt.return (Ok ()) in loop () -let run_client _ influx vm = +let run_client _ influx vm drop = Sys.(set_signal sigpipe Signal_ignore) ; - Lwt_main.run (client influx vm) + Lwt_main.run (client influx vm drop) open Cmdliner open Albatross_cli +let drop_label = + let doc = "Drop leftmost label" in + Arg.(value & flag & info [ "drop-label" ] ~doc) + let cmd = let doc = "Albatross Influx connector" in let man = [ `S "DESCRIPTION" ; `P "$(tname) connects to a albatross stats socket, pulls statistics and pushes them via TCP to influxdb" ] in - Term.(term_result (const run_client $ setup_log $ influx $ opt_vm_name)), + Term.(term_result (const run_client $ setup_log $ influx $ opt_vm_name $ drop_label)), Term.info "albatross_influx" ~version:"%%VERSION_NUM%%" ~doc ~man let () = diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 181221c..8249573 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -76,6 +76,10 @@ module Name = struct | [] -> [] | _::tl -> List.rev tl + let drop_front = function + | [] -> [] + | _::tl -> tl + let append_exn lbl x = if valid_label lbl then x @ [ lbl ] @@ -94,6 +98,8 @@ module Name = struct else Error (`Msg "label not valid") + let concat a b = a @ b + let domain id = match List.rev id with | _::prefix -> List.rev prefix | [] -> [] diff --git a/src/vmm_core.mli b/src/vmm_core.mli index cd72785..cdcc238 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -27,9 +27,11 @@ module Name : sig val of_list : string list -> (t, [> `Msg of string ]) result val to_list : t -> string list val drop : t -> t + val drop_front : t -> t val append : string -> t -> (t, [> `Msg of string ]) result val prepend : string -> t -> (t, [> `Msg of string ]) result val append_exn : string -> t -> t + val concat : t -> t -> t val root : t val valid_label : string -> bool diff --git a/tls/vmm_tls.ml b/tls/vmm_tls.ml index ca7cbde..6db8fb3 100644 --- a/tls/vmm_tls.ml +++ b/tls/vmm_tls.ml @@ -33,12 +33,8 @@ let name chain = | Error e, _ -> Error e | _, Error e -> Error e | Ok acc, Ok None -> Ok acc - | Ok acc, Ok (Some data) -> Vmm_core.Name.prepend data acc) - (Ok Vmm_core.Name.root) chain >>= fun lbl -> - if List.length (Vmm_core.Name.to_list lbl) < 10 then - Ok lbl - else - Error (`Msg "too deep") + | Ok acc, Ok (Some data) -> Vmm_core.Name.append data acc) + (Ok Vmm_core.Name.root) chain (* this separates the leaf and top-level certificate from the chain, and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA') @@ -78,10 +74,21 @@ let extract_policies version chain = (Ok (Vmm_core.Name.root, [])) chain let handle version chain = + (if List.length chain < 10 then + Ok () + else + Error (`Msg "certificate chain too long")) >>= fun () -> separate_chain chain >>= fun (leaf, rest) -> - name chain >>= fun name -> - Logs.debug (fun m -> m "leaf is %a, chain %a" - Certificate.pp leaf + (* use subject common names of intermediate certs as prefix *) + name rest >>= fun name' -> + (* and subject common name of leaf certificate -- allowing dots in CN -- as postfix *) + (cert_name leaf >>= function + | None -> Ok name' + | Some x -> + Vmm_core.Name.of_string x >>| fun post -> + Vmm_core.Name.concat name' post) >>= fun name -> + Logs.debug (fun m -> m "name is %a leaf is %a, chain %a" + Vmm_core.Name.pp name Certificate.pp leaf Fmt.(list ~sep:(unit " -> ") Certificate.pp) rest); extract_policies version rest >>= fun (_, policies) -> (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *)