revise naming freedom: multiple labels are allowed in certificate common names

influx may drop topmost label (if --drop-label provided)

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 () =

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
     | [] -> []

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

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 *)