IPv6 IPs in host certificates for dual-stack management interfaces (xapi-project#6419)

Adds IPv6 addresses to host certificates when their management
interfaces are configured to use Dual stack.

I've tested manually on IPv4-only hosts, and the certificates are
generated in the same way as before.
I've run the smoke and verification tests (Suite Run 215863), all of
them passed

@last-genius you probably want to test these changes, run `openssl x509
-text -in /etc/xensource/xapi-ssl.pem` on a dual host, and see that it
contains the IPv6 and IPv4 addresses.

Author: psafont

ocaml/gencert/gencert.ml

@@ -47,22 +47,20 @@ let main ~dbg ~path ~cert_gid ~sni () =
   init_inventory () ;
   let generator path =
     match sni with
-    | SNI.Default ->
-        let name, ip =
-          match Networking_info.get_management_ip_addr ~dbg with
-          | None ->
-              D.error "gencert.ml: cannot get management ip address!" ;
-              exit 1
-          | Some x ->
-              x
-        in
-        let dns_names = Networking_info.dns_names () in
-        let ips = [ip] in
-        let (_ : X509.Certificate.t) =
-          Gencertlib.Selfcert.host ~name ~dns_names ~ips ~valid_for_days path
-            cert_gid
-        in
-        ()
+    | SNI.Default -> (
+      match Networking_info.get_host_certificate_subjects ~dbg with
+      | Error cause ->
+          let msg = Networking_info.management_ip_error_to_string cause in
+          D.error
+            "gencert.ml: failed to generate certificate subjects because %s" msg ;
+          exit 1
+      | Ok (name, dns_names, ips) ->
+          let _ : X509.Certificate.t =
+            Gencertlib.Selfcert.host ~name ~dns_names ~ips ~valid_for_days path
+              cert_gid
+          in
+          ()
+    )
     | SNI.Xapi_pool ->
         let uuid = Inventory.lookup Inventory._installation_uuid in
         let (_ : X509.Certificate.t) =

ocaml/networkd/bin/network_server.ml

@@ -412,12 +412,23 @@ module Interface = struct
                 Ip.set_ipv6_link_local_addr name
               )
           | DHCP6 ->
+              let gateway =
+                Option.fold ~none:[]
+                  ~some:(fun n -> [`gateway n])
+                  !config.gateway_interface
+              in
+              let dns =
+                Option.fold ~none:[]
+                  ~some:(fun n -> [`dns n])
+                  !config.dns_interface
+              in
               if Dhclient.is_running ~ipv6:true name then
                 ignore (Dhclient.stop ~ipv6:true name) ;
               Sysctl.set_ipv6_autoconf name false ;
               Ip.flush_ip_addr ~ipv6:true name ;
               Ip.set_ipv6_link_local_addr name ;
-              ignore (Dhclient.ensure_running ~ipv6:true name [])
+              let options = gateway @ dns in
+              ignore (Dhclient.ensure_running ~ipv6:true name options)
           | Autoconf6 ->
               if Dhclient.is_running ~ipv6:true name then
                 ignore (Dhclient.stop ~ipv6:true name) ;

ocaml/xapi-aux/networking_info.ml

@@ -17,7 +17,22 @@ module L = Debug.Make (struct let name = __MODULE__ end)
 
 let get_hostname () = try Unix.gethostname () with _ -> ""
 
-exception Unexpected_address_type of string
+type management_ip_error =
+  | Interface_missing
+  | Unexpected_address_type of string
+  | IP_missing
+  | Other of exn
+
+let management_ip_error_to_string = function
+  | Interface_missing ->
+      "Management interface is missing"
+  | IP_missing ->
+      "Management IP is missing"
+  | Unexpected_address_type s ->
+      Printf.sprintf
+        "Unexpected address type. Expected 'ipv4' or 'ipv6', got %s" s
+  | Other e ->
+      Printexc.to_string e
 
 (* Try to get all FQDNs, avoid localhost *)
 let dns_names () =
@@ -46,32 +61,63 @@ let ipaddr_to_cstruct = function
   | Ipaddr.V6 addr ->
       Cstruct.of_string (Ipaddr.V6.to_octets addr)
 
-let list_head lst = List.nth_opt lst 0
-
-let get_management_ip_addr ~dbg =
+let get_management_ip_addrs ~dbg =
   let iface = Inventory.lookup Inventory._management_interface in
   try
     if iface = "" || (not @@ Net.Interface.exists dbg iface) then
-      None
+      Error Interface_missing
     else
-      let addrs =
+      let ( let* ) = Result.bind in
+      let* addrs =
+        let ipv4 = Net.Interface.get_ipv4_addr dbg iface in
+        let ipv6 = Net.Interface.get_ipv6_addr dbg iface in
         match
           String.lowercase_ascii
             (Inventory.lookup Inventory._management_address_type ~default:"ipv4")
         with
         | "ipv4" ->
-            Net.Interface.get_ipv4_addr dbg iface
+            Ok (ipv4, ipv6)
         | "ipv6" ->
-            Net.Interface.get_ipv6_addr dbg iface
+            Ok (ipv6, ipv4)
         | s ->
-            let msg = Printf.sprintf "Expected 'ipv4' or 'ipv6', got %s" s in
-            L.error "%s: %s" __FUNCTION__ msg ;
-            raise (Unexpected_address_type msg)
+            Error (Unexpected_address_type s)
       in
-      addrs
-      |> List.map (fun (addr, _) -> Ipaddr_unix.of_inet_addr addr)
       (* Filter out link-local addresses *)
-      |> List.filter (fun addr -> Ipaddr.scope addr <> Ipaddr.Link)
-      |> List.map (fun ip -> (Ipaddr.to_string ip, ipaddr_to_cstruct ip))
-      |> list_head
-  with _ -> None
+      let no_local (addr, _) =
+        let addr = Ipaddr_unix.of_inet_addr addr in
+        if Ipaddr.scope addr <> Ipaddr.Link then
+          Some addr
+        else
+          None
+      in
+      Ok
+        ( List.filter_map no_local (fst addrs)
+        , List.filter_map no_local (snd addrs)
+        )
+  with e -> Error (Other e)
+
+let get_management_ip_addr ~dbg =
+  match get_management_ip_addrs ~dbg with
+  | Ok (preferred, _) ->
+      List.nth_opt preferred 0
+      |> Option.map (fun addr -> (Ipaddr.to_string addr, ipaddr_to_cstruct addr))
+  | Error _ ->
+      None
+
+let get_host_certificate_subjects ~dbg =
+  let ( let* ) = Result.bind in
+  let* ips, preferred_ip =
+    match get_management_ip_addrs ~dbg with
+    | Error e ->
+        Error e
+    | Ok (preferred, others) ->
+        let ips = List.(rev_append (rev preferred) others) in
+        Option.fold ~none:(Error IP_missing)
+          ~some:(fun ip -> Ok (List.map ipaddr_to_cstruct ips, ip))
+          (List.nth_opt ips 0)
+  in
+  let dns_names = dns_names () in
+  let name =
+    match dns_names with [] -> Ipaddr.to_string preferred_ip | dns :: _ -> dns
+  in
+  Ok (name, dns_names, ips)

ocaml/xapi-aux/networking_info.mli

@@ -14,15 +14,23 @@ val get_hostname : unit -> string
 (** [get_hostname ()] returns the hostname as returned by Unix.gethostname.
     If there is an error "" is returned. *)
 
-exception Unexpected_address_type of string
+type management_ip_error =
+  | Interface_missing
+  | Unexpected_address_type of string
+  | IP_missing
+  | Other of exn
 
-val dns_names : unit -> string list
-(** [dns_names ()] returns a list of the hostnames that the host may have.
-    Ignores empty names as well as "localhost" *)
+val management_ip_error_to_string : management_ip_error -> string
+(** [management_ip_error err] returns a string representation of [err], useful
+    only for logging. *)
 
 val get_management_ip_addr : dbg:string -> (string * Cstruct.t) option
-(** [get_management_ip_addr ~dbg] returns the IP of the management network.
-    If the system does not have management address None is return.
-    [Unexpected_address_type] is raised if there is an unexpected address is
-    stored. The address is return in two formats: human-readable string and
-    its bytes representation. *)
+(** [get_management_ip_addr ~dbg] returns the preferred IP of the management
+    network, or None. The address is returned in two formats: a human-readable
+    string and its bytes representation. *)
+
+val get_host_certificate_subjects :
+     dbg:string
+  -> (string * string list * Cstruct.t list, management_ip_error) Result.t
+(** [get_host_certificate_subjects ~dbg] returns the main, dns names and ip
+    addresses that identify the host in secure connections. *)

ocaml/xapi/xapi_host.ml

@@ -1583,19 +1583,17 @@ let install_server_certificate ~__context ~host ~certificate ~private_key
   replace_host_certificate ~__context ~type':`host ~host write_cert_fs
 
 let _new_host_cert ~dbg ~path : X509.Certificate.t =
-  let ip_as_string, ip =
-    match Networking_info.get_management_ip_addr ~dbg with
-    | None ->
+  let name, dns_names, ips =
+    match Networking_info.get_host_certificate_subjects ~dbg with
+    | Error cause ->
+        let msg = Networking_info.management_ip_error_to_string cause in
         Helpers.internal_error ~log_err:true ~err_fun:D.error
-          "%s: failed to get management IP" __LOC__
-    | Some ip ->
-        ip
+          "%s: failed to generate certificate subjects because %s" __LOC__ msg
+    | Ok (name, dns_names, ips) ->
+        (name, dns_names, ips)
   in
-  let dns_names = Networking_info.dns_names () in
-  let cn = match dns_names with [] -> ip_as_string | dns :: _ -> dns in
-  let ips = [ip] in
   let valid_for_days = !Xapi_globs.cert_expiration_days in
-  Gencertlib.Selfcert.host ~name:cn ~dns_names ~ips ~valid_for_days path
+  Gencertlib.Selfcert.host ~name ~dns_names ~ips ~valid_for_days path
     !Xapi_globs.server_cert_group_id
 
 let reset_server_certificate ~__context ~host =