issue policy_add commands by vmmd_tls for certificate chain

app/vmmd_tls.ml

@@ -55,6 +55,7 @@ let process fd tls =
   Vmm_lwt.read_wire fd >>= function
   | Error _ -> Lwt.return (Error (`Msg "read error"))
   | Ok wire ->
+    (* TODO check version *)
     Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire wire) ;
     Vmm_tls_lwt.write_tls tls wire >|= function
     | Ok () -> Ok ()
@@ -66,9 +67,42 @@ let handle ca (tls, addr) =
   | Error (`Msg m) ->
     Vmm_tls_lwt.close tls >>= fun () ->
     Lwt.fail_with m
-  | Ok (name, cmd) ->
+  | Ok (name, policies, cmd) ->
     let sock, next = Vmm_commands.endpoint cmd in
     connect (Vmm_core.socket_path sock) >>= fun fd ->
+    (match sock with
+     | `Vmmd ->
+       Lwt_list.fold_left_s (fun r (id, policy) ->
+           match r with
+           | Error (`Msg msg) -> Lwt.return (Error (`Msg msg))
+           | Ok () ->
+             Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.pp_id id Vmm_core.pp_policy policy) ;
+             let header = Vmm_commands.{version = my_version ; sequence = !command ; id } in
+             command := Int64.succ !command ;
+             Vmm_lwt.write_wire fd (header, `Command (`Policy_cmd (`Policy_add policy))) >>= function
+             | Error `Exception -> Lwt.return (Error (`Msg "failed to write policy"))
+             | Ok () ->
+               Vmm_lwt.read_wire fd >|= function
+               | Error _ -> Error (`Msg "read error")
+               | Ok (_, `Success _) -> Ok ()
+               | Ok _ ->
+                 (* TODO check version *)
+                 Error (`Msg ("expected success, received something else when adding policy")))
+         (Ok ()) policies
+     | _ -> Lwt.return (Ok ())) >>= function
+    | Error (`Msg msg) ->
+      begin
+        Logs.debug (fun m -> m "error while applying policies %s" msg) ;
+        let wire =
+          let header = Vmm_commands.{version = my_version ; sequence = 0L ; id = name } in
+          header, `Failure msg
+        in
+        Vmm_tls_lwt.write_tls tls wire >>= fun _ ->
+        Vmm_tls_lwt.close tls >>= fun () ->
+        Vmm_lwt.safe_close fd >>= fun () ->
+        Lwt.fail_with msg
+      end
+    | Ok () ->
       let wire =
         let header = Vmm_commands.{version = my_version ; sequence = !command ; id = name } in
         command := Int64.succ !command ;

src/vmm_tls.ml

@@ -4,17 +4,22 @@ open Rresult
 open Rresult.R.Infix
 
 (* we skip all non-albatross certificates *)
-let name chain =
+let cert_name cert =
-  List.fold_left (fun acc cert ->
   match X509.Extension.unsupported cert Vmm_asn.oid with
-      | None -> acc
+  | None -> None
   | Some _ ->
     let data = X509.common_name_to_string cert in
     (* if the common name is empty, skip [useful for vmmc_bistro at least]
        TODO: document properly and investigate potential security issue with
        multi-tenant system (likely ca should ensure to never sign a delegation
        with empty common name) *)
-        if data = "" then acc else data :: acc)
+    if data = "" then None else Some data
+
+let name chain =
+  List.fold_left (fun acc cert ->
+      match cert_name cert with
+      | None -> acc
+      | Some data -> data :: acc)
     [] chain
 
 (* this separates the leaf and top-level certificate from the chain,
@@ -27,13 +32,13 @@ let separate_chain = function
 
 let wire_command_of_cert version cert =
   match X509.Extension.unsupported cert Vmm_asn.oid with
-  | None -> R.error_msgf "albatross OID is not present in certificate (%a)" Asn.OID.pp Vmm_asn.oid
+  | None -> Error `Not_present
   | Some (_, data) ->
-    Vmm_asn.cert_extension_of_cstruct data >>= fun (v, wire) ->
+    match Vmm_asn.cert_extension_of_cstruct data with
+    | Error (`Msg p) -> Error (`Parse p)
+    | Ok (v, wire) ->
       if not (Vmm_commands.version_eq v version) then
-      R.error_msgf "unexpected version %a (expected %a)"
+        Error (`Version v)
-        Vmm_commands.pp_version v
-        Vmm_commands.pp_version version
       else
         Ok wire
 
@@ -50,6 +55,26 @@ let wire_command_of_cert version cert =
      check_policies vm_config (List.map snd policies) >>= fun () ->
 *)
 
+let extract_policies version chain =
+  List.fold_left (fun acc cert ->
+      match acc, wire_command_of_cert version cert with
+      | Error e, _ -> Error e
+      | Ok acc, Error `Not_present -> Ok acc
+      | Ok _, Error (`Parse msg) -> Error (`Msg msg)
+      | Ok _, Error (`Version received) ->
+        R.error_msgf "unexpected version %a (expected %a)"
+          Vmm_commands.pp_version received
+          Vmm_commands.pp_version version
+      | Ok (prefix, acc), Ok (`Policy_cmd (`Policy_add p)) ->
+        let name = match cert_name cert with
+          | None -> prefix
+          | Some x -> x :: prefix
+        in
+        Ok (name, (name, p) :: acc)
+      | _, Ok wire ->
+        R.error_msgf "unexpected wire %a" Vmm_commands.pp wire)
+    (Ok ([], [])) chain
+
 let handle _addr version chain =
   separate_chain chain >>= fun (leaf, rest) ->
   let name = name chain in
@@ -57,15 +82,22 @@ let handle _addr version chain =
                  (X509.common_name_to_string leaf)
                  Fmt.(list ~sep:(unit " -> ") string)
                  (List.map X509.common_name_to_string rest)) ;
-  (* TODO: inspect top-level-cert of chain. *)
+  extract_policies version rest >>= fun (_, policies) ->
   (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *)
-  (* TODO: update policies (parse chain for policy, and apply them)! *)
+  match wire_command_of_cert version leaf with
-  wire_command_of_cert version leaf >>= fun wire ->
+  | Error (`Parse p) -> Error (`Msg p)
+  | Error (`Not_present) ->
+    Error (`Msg "leaf certificate does not contain an albatross extension")
+  | Error (`Version received) ->
+    R.error_msgf "unexpected version %a (expected %a)"
+      Vmm_commands.pp_version received
+      Vmm_commands.pp_version version
+  | Ok wire ->
     (* we only allow some commands via certificate *)
     match wire with
     | `Console_cmd (`Console_subscribe _)
     | `Stats_cmd `Stats_subscribe
     | `Log_cmd (`Log_subscribe _)
     | `Vm_cmd _
-  | `Policy_cmd _ -> Ok (name, wire) (* TODO policy_cmd is special (via delegation chain) *)
+    | `Policy_cmd `Policy_info -> Ok (name, policies, wire)
     | _ -> Error (`Msg "unexpected command")

src/vmm_tls.mli

@@ -1,9 +1,10 @@
 (* (c) 2018 Hannes Mehnert, all rights reserved *)
 
 val wire_command_of_cert : Vmm_commands.version -> X509.t ->
-  (Vmm_commands.t, [> `Msg of string ]) result
+  (Vmm_commands.t, [> `Parse of string | `Not_present | `Version of Vmm_commands.version ]) result
 
 val handle :
   'a -> Vmm_commands.version ->
   X509.t list ->
-  (string list * Vmm_commands.t, [> `Msg of string ]) Result.result
+  (string list * (Vmm_core.id * Vmm_core.policy) list * Vmm_commands.t,
+   [> `Msg of string ]) Result.result