adapt to X509 0.7.0 API, minor comment and doc tweaks

albatross.opam

@@ -19,7 +19,7 @@ depends: [
   "cmdliner" {>= "1.0.0"}
   "fmt"
   "astring"
-  "x509" {>= "0.6.0"}
+  "x509" {>= "0.7.0"}
   "tls" {>= "0.9.0"}
   "nocrypto"
   "asn1-combinators" {>= "0.2.0"}

client/albatross_client_bistro.ml

@@ -1,6 +1,7 @@
 (* (c) 2018 Hannes Mehnert, all rights reserved *)
 
 open Lwt.Infix
+open X509
 
 let version = `AV3
 
@@ -16,13 +17,16 @@ let read fd =
   in
   loop ()
 
-let key_ids pub issuer =
+let key_ids exts pub issuer =
-  let auth = (Some (X509.key_id issuer), [], None) in
+  let auth = (Some (Public_key.id issuer), General_name.empty, None) in
-  [ (false, `Subject_key_id (X509.key_id pub)) ; (false, `Authority_key_id auth) ]
+  Extension.(add Subject_key_id (false, (Public_key.id pub))
+               (add Authority_key_id (false, auth) exts))
 
 let timestamps validity =
   let now = Ptime_clock.now () in
   match
+    (* subtracting some seconds here to not require perfectly synchronised
+       clocks on client and server *)
     Ptime.sub_span now (Ptime.Span.of_int_s 10),
     Ptime.add_span now (Ptime.Span.of_int_s validity)
   with
@@ -31,36 +35,46 @@ let timestamps validity =
 
 let handle (host, port) cert key ca id (cmd : Vmm_commands.t) =
   Vmm_lwt.read_from_file cert >>= fun cert_cs ->
-  let cert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 cert_cs in
   Vmm_lwt.read_from_file key >>= fun key_cs ->
-  let key = X509.Encoding.Pem.Private_key.of_pem_cstruct1 key_cs in
+  match Certificate.decode_pem cert_cs, Private_key.decode_pem key_cs with
+  | Error (`Msg e), _ ->
+    Lwt.fail_with ("couldn't parse certificate (" ^ cert ^ "): "  ^ e)
+  | _, Error (`Msg e) ->
+    Lwt.fail_with ("couldn't parse private key (" ^ key ^ "): "  ^ e)
+  | Ok cert, Ok key ->
     let tmpkey = Nocrypto.Rsa.generate 4096 in
     let name = Vmm_core.Name.to_string id in
     let extensions =
-    [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
+      let v = Vmm_asn.cert_extension_to_cstruct (version, cmd) in
-    ; (true, `Basic_constraints (false, None))
+      Extension.(add Key_usage (true, [ `Digital_signature ; `Key_encipherment ])
-    ; (true, `Ext_key_usage [`Client_auth]) ;
+                   (add Basic_constraints (true, (false, None))
-      (false, `Unsupported (Vmm_asn.oid, Vmm_asn.cert_extension_to_cstruct (version, cmd))) ] in
+                      (add Ext_key_usage (true, [ `Client_auth ])
+                         (singleton (Unsupported Vmm_asn.oid) (false, v)))))
+    in
     let csr =
-    let name = [ `CN name ] in
+      let name = Distinguished_name.(singleton CN name) in
-    X509.CA.request name ~extensions:[`Extensions extensions] (`RSA tmpkey)
+      let extensions = Signing_request.Ext.(singleton Extensions extensions) in
+      Signing_request.create name ~extensions (`RSA tmpkey)
     in
     let mycert =
       let valid_from, valid_until = timestamps 300 in
       let extensions =
         let capub = match key with `RSA key -> Nocrypto.Rsa.pub_of_priv key in
-      extensions @ key_ids (X509.CA.info csr).X509.CA.public_key (`RSA capub)
+        key_ids extensions Signing_request.((info csr).public_key) (`RSA capub)
       in
-    let issuer = X509.subject cert in
+      let issuer = Certificate.subject cert in
-    X509.CA.sign csr ~valid_from ~valid_until ~extensions key issuer
+      Signing_request.sign csr ~valid_from ~valid_until ~extensions key issuer
     in
     let certificates = `Single ([ mycert ; cert ], tmpkey) in
     X509_lwt.authenticator (`Ca_file ca) >>= fun authenticator ->
     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
+    let fd = Lwt_unix.(socket host_entry.h_addrtype SOCK_STREAM 0) in
     Logs.debug (fun m -> m "connecting to remote host") ;
     Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun () ->
+    (* reneg true to allow re-negotiation over the server-authenticated TLS
+       channel (to transport client certificate encrypted), once TLS 1.3 is in
+       (and required) be removed! *)
     let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
     Tls_lwt.Unix.client_of_fd client (* TODO ~host *) fd >>= fun t ->
     Logs.debug (fun m -> m "finished tls handshake") ;

provision/albatross_provision.ml

@@ -29,19 +29,19 @@ let append name data =
   go 0 >>= fun () ->
   safe Unix.close fd
 
-let key_ids pub issuer =
+let key_ids exts pub issuer =
-  let auth = (Some (X509.key_id issuer), [], None) in
+  let auth = Some (X509.Public_key.id issuer), X509.General_name.empty, None in
-  [ (false, `Subject_key_id (X509.key_id pub)) ; (false, `Authority_key_id auth) ]
+  X509.Extension.(add Subject_key_id (false, X509.Public_key.id pub)
+                    (add Authority_key_id (false, auth) exts))
 
 let sign ?dbname ?certname extensions issuer key csr delta =
   let open Rresult.R.Infix in
   (match certname with
    | Some x -> Ok x
    | None ->
-     (try Ok (List.find (function `CN _ -> true | _ -> false) (X509.CA.info csr).X509.CA.subject)
+     match X509.(Distinguished_name.find CN Signing_request.((info csr).subject)) with
-      with Not_found -> Error (`Msg "unable to discover certificate name")) >>= function
+     | Some name -> Ok name
-     | `CN name -> Ok name
+     | None -> Error (`Msg "couldn't find name (no common name in CSR subject)")) >>= fun certname ->
-     | _ -> Error (`Msg "cannot happen")) >>= fun certname ->
   timestamps delta >>= fun (valid_from, valid_until) ->
   let extensions =
     match dbname with
@@ -50,14 +50,14 @@ let sign ?dbname ?certname extensions issuer key csr delta =
       match key with
       | `RSA priv ->
         let capub = `RSA (Nocrypto.Rsa.pub_of_priv priv) in
-        extensions @ key_ids (X509.CA.info csr).X509.CA.public_key capub
+        key_ids extensions X509.Signing_request.((info csr).public_key) capub
   in
-  let cert = X509.CA.sign csr ~valid_from ~valid_until ~extensions key issuer in
+  let cert = X509.Signing_request.sign csr ~valid_from ~valid_until ~extensions key issuer in
   (match dbname with
    | None -> Ok () (* no DB! *)
    | Some dbname ->
-     append dbname (Printf.sprintf "%s %s\n" (Z.to_string (X509.serial cert)) certname)) >>= fun () ->
+     append dbname (Printf.sprintf "%s %s\n" (Z.to_string (X509.Certificate.serial cert)) certname)) >>= fun () ->
-  let enc = X509.Encoding.Pem.Certificate.to_pem_cstruct1 cert in
+  let enc = X509.Certificate.encode_pem cert in
   Bos.OS.File.write Fpath.(v certname + "pem") (Cstruct.to_string enc)
 
 let priv_key ?(bits = 2048) fn name =
@@ -70,11 +70,11 @@ let priv_key ?(bits = 2048) fn name =
   | false ->
     Logs.info (fun m -> m "creating new RSA key %a" Fpath.pp file) ;
     let priv = `RSA (Nocrypto.Rsa.generate bits) in
-    Bos.OS.File.write ~mode:0o400 file (Cstruct.to_string (X509.Encoding.Pem.Private_key.to_pem_cstruct1 priv)) >>= fun () ->
+    Bos.OS.File.write ~mode:0o400 file (Cstruct.to_string (X509.Private_key.encode_pem priv)) >>= fun () ->
     Ok priv
   | true ->
     Bos.OS.File.read file >>= fun s ->
-    Ok (X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string s))
+    X509.Private_key.decode_pem (Cstruct.of_string s)
 
 open Cmdliner
 

provision/albatross_provision_ca.ml

@@ -1,47 +1,45 @@
 (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
 
 open Rresult.R.Infix
+open X509
+
+open Albatross_provision
 
 let l_exts =
-  [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
+  Extension.(add Key_usage (true, [ `Digital_signature ; `Key_encipherment ])
-  ; (true, `Basic_constraints (false, None))
+               (add Basic_constraints (true, (false, None))
-  ; (true, `Ext_key_usage [`Client_auth]) ]
+                  (singleton Ext_key_usage (true, [ `Client_auth ]))))
 
 let d_exts ?len () =
-  [ (true, (`Basic_constraints (true, len)))
+  let kus =
-  ; (true, (`Key_usage [ `Key_cert_sign ; `CRL_sign ; `Digital_signature ; `Content_commitment ])) ]
+    [ `Key_cert_sign ; `CRL_sign ; `Digital_signature ; `Content_commitment ]
+  in
+  Extension.(add Basic_constraints (true, (true, len))
+               (singleton Key_usage (true, kus)))
 
 let s_exts =
-  [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
+  Extension.(add Key_usage (true, [ `Digital_signature ; `Key_encipherment ])
-  ; (true, `Basic_constraints (false, None))
+               (add Basic_constraints (true, (false, None))
-  ; (true, `Ext_key_usage [`Server_auth]) ]
+                  (singleton Ext_key_usage (true, [ `Server_auth ]))))
 
 let albatross_extension csr =
   let req_exts =
-    match
+    match Signing_request.(Ext.(find Extensions ((info csr).extensions))) with
-      List.find (function `Extensions _ -> true | _ -> false) X509.CA.((info csr).extensions)
+    | Some x -> x
-    with
+    | None -> Extension.empty
-    | exception Not_found -> []
-    | `Extensions x -> x
-    | _ -> []
   in
-  match
+  match Extension.(find (Unsupported Vmm_asn.oid) req_exts) with
-    List.filter (function
+  | Some (_, v) -> Ok v
-        | (_, `Unsupported (oid, _)) when Asn.OID.equal oid Vmm_asn.oid -> true
+  | None -> Error (`Msg "couldn't find albatross extension in CSR")
-        | _ -> false)
-      req_exts
-  with
-  | [ (_, `Unsupported (_, v)) as ext ] -> Ok (ext, v)
-  | _ -> Error (`Msg "couldn't find albatross extension in CSR")
 
 let sign_csr dbname cacert key csr days =
-  let ri = X509.CA.info csr in
+  let ri = Signing_request.info csr in
-  Logs.app (fun m -> m "signing certificate with subject %s"
+  Logs.app (fun m -> m "signing certificate with subject %a"
-               (X509.distinguished_name_to_string ri.X509.CA.subject)) ;
+               Distinguished_name.pp ri.Signing_request.subject);
-  let issuer = X509.subject cacert in
+  let issuer = Certificate.subject cacert in
   (* TODO: check delegation! verify whitelisted commands!? *)
   match albatross_extension csr with
-  | Ok (ext, v) ->
+  | Ok v ->
     Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) ->
     (if Vmm_commands.version_eq version version then
        Ok ()
@@ -51,19 +49,22 @@ let sign_csr dbname cacert key csr days =
       | `Policy_cmd (`Policy_add _) -> d_exts ()
       | _ -> l_exts
     in
-    Logs.app (fun m -> m "signing %a" Vmm_commands.pp cmd) ;
+    Logs.app (fun m -> m "signing %a" Vmm_commands.pp cmd);
-    Ok (ext :: exts) >>= fun extensions ->
+    (* the "false" is here since X509 validation bails on exts marked as
-    Albatross_provision.sign ~dbname extensions issuer key csr (Duration.of_day days)
+       critical (as required), but has no way to supply which extensions
+       are actually handled by the application / caller *)
+    let extensions = Extension.(add (Unsupported Vmm_asn.oid) (false, v) exts) in
+    sign ~dbname extensions issuer key csr (Duration.of_day days)
   | Error e -> Error e
 
-let sign _ db cacert cakey csrname days =
+let sign_main _ db cacert cakey csrname days =
   Nocrypto_entropy_unix.initialize () ;
   Bos.OS.File.read (Fpath.v cacert) >>= fun cacert ->
-  let cacert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string cacert) in
+  Certificate.decode_pem (Cstruct.of_string cacert) >>= fun cacert ->
   Bos.OS.File.read (Fpath.v cakey) >>= fun pk ->
-  let cakey = X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string pk) in
+  Private_key.decode_pem (Cstruct.of_string pk) >>= fun cakey ->
   Bos.OS.File.read (Fpath.v csrname) >>= fun enc ->
-  let csr = X509.Encoding.Pem.Certificate_signing_request.of_pem_cstruct1 (Cstruct.of_string enc) in
+  Signing_request.decode_pem (Cstruct.of_string enc) >>= fun csr ->
   sign_csr (Fpath.v db) cacert cakey csr days
 
 let help _ man_format cmds = function
@@ -73,14 +74,14 @@ let help _ man_format cmds = function
 
 let generate _ name db days sname sdays =
   Nocrypto_entropy_unix.initialize () ;
-  Albatross_provision.priv_key ~bits:4096 None name >>= fun key ->
+  priv_key ~bits:4096 None name >>= fun key ->
-  let name = [ `CN name ] in
+  let name = Distinguished_name.(singleton CN name) in
-  let csr = X509.CA.request name key in
+  let csr = Signing_request.create name key in
-  Albatross_provision.sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () ->
+  sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () ->
-  Albatross_provision.priv_key None sname >>= fun skey ->
+  priv_key None sname >>= fun skey ->
-  let sname = [ `CN sname ] in
+  let sname = Distinguished_name.(singleton CN sname) in
-  let csr = X509.CA.request sname skey in
+  let csr = Signing_request.create sname skey in
-  Albatross_provision.sign ~dbname:(Fpath.v db) s_exts name key csr (Duration.of_day sdays)
+  sign ~dbname:(Fpath.v db) s_exts name key csr (Duration.of_day sdays)
 
 open Cmdliner
 open Albatross_cli
@@ -115,7 +116,7 @@ let generate_cmd =
     [`S "DESCRIPTION";
      `P "Generates a certificate authority."]
   in
-  Term.(term_result (const generate $ setup_log $ Albatross_provision.nam $ db $ days $ sname $ sday)),
+  Term.(term_result (const generate $ setup_log $ nam $ db $ days $ sname $ sday)),
   Term.info "generate" ~doc ~man
 
 let days =
@@ -132,7 +133,7 @@ let sign_cmd =
     [`S "DESCRIPTION";
      `P "Signs the certificate signing request."]
   in
-  Term.(term_result (const sign $ setup_log $ db $ cacert $ key $ csr $ days)),
+  Term.(term_result (const sign_main $ setup_log $ db $ cacert $ key $ csr $ days)),
   Term.info "sign" ~doc ~man
 
 let help_cmd =

provision/albatross_provision_request.ml

@@ -8,17 +8,20 @@ open Rresult.R.Infix
 let version = `AV3
 
 let csr priv name cmd =
-  let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (version, cmd))) ]
+  let ext =
-  and name = [ `CN name ]
+    let v = cert_extension_to_cstruct (version, cmd) in
+    X509.Extension.(singleton (Unsupported oid) (false, v))
+  and name = X509.Distinguished_name.(singleton CN name)
   in
-  X509.CA.request name ~extensions:[`Extensions exts] priv
+  let extensions = X509.Signing_request.Ext.(singleton Extensions ext) in
+  X509.Signing_request.create name ~extensions priv
 
 let jump id cmd =
   Nocrypto_entropy_unix.initialize () ;
   let name = Vmm_core.Name.to_string id in
   priv_key None name >>= fun priv ->
   let csr = csr priv name cmd in
-  let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in
+  let enc = X509.Signing_request.encode_pem csr in
   Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc)
 
 let info_policy _ name =

tls/vmm_tls.ml

@@ -2,15 +2,16 @@
 
 open Rresult
 open Rresult.R.Infix
+open X509
 
 (* we skip all non-albatross certificates *)
 let cert_name cert =
-  match X509.Extension.unsupported cert Vmm_asn.oid with
+  match Extension.(find (Unsupported Vmm_asn.oid) (Certificate.extensions cert)) with
   | None -> Ok None
   | Some (_, data) ->
-    let name = X509.common_name_to_string cert in
+    match Distinguished_name.(find CN (Certificate.subject cert)) with
-    if name = "" then
+    | Some name -> Ok (Some name)
-      match Vmm_asn.cert_extension_of_cstruct data with
+    | None -> match Vmm_asn.cert_extension_of_cstruct data with
       | Error (`Msg _) -> Error (`Msg "couldn't parse albatross extension")
       | Ok (_, `Policy_cmd pc) ->
         begin match pc with
@@ -25,7 +26,6 @@ let cert_name cert =
           | `Block_info -> Ok None
         end
       | _ -> Ok None
-    else Ok (Some name)
 
 let name chain =
   List.fold_left (fun acc cert ->
@@ -49,12 +49,10 @@ let separate_chain = function
   | leaf :: xs -> Ok (leaf, List.rev xs)
 
 let wire_command_of_cert version cert =
-  match X509.Extension.unsupported cert Vmm_asn.oid with
+  match Extension.(find (Unsupported Vmm_asn.oid) (Certificate.extensions cert)) with
   | None -> Error `Not_present
   | Some (_, data) ->
-    match Vmm_asn.cert_extension_of_cstruct data with
+    Vmm_asn.cert_extension_of_cstruct data >>= fun (v, wire) ->
-    | Error (`Msg p) -> Error (`Parse p)
-    | Ok (v, wire) ->
     if not (Vmm_commands.version_eq v version) then
       Error (`Version v)
     else
@@ -65,7 +63,7 @@ let extract_policies version chain =
       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 (`Msg msg) -> Error (`Msg msg)
       | Ok _, Error (`Version received) ->
         R.error_msgf "unexpected version %a (expected %a)"
           Vmm_commands.pp_version received
@@ -82,14 +80,13 @@ let extract_policies version chain =
 let handle version chain =
   separate_chain chain >>= fun (leaf, rest) ->
   name chain >>= fun name ->
-  Logs.debug (fun m -> m "leaf is %s, chain %a"
+  Logs.debug (fun m -> m "leaf is %a, chain %a"
-                 (X509.common_name_to_string leaf)
+                 Certificate.pp leaf
-                 Fmt.(list ~sep:(unit " -> ") string)
+                 Fmt.(list ~sep:(unit " -> ") Certificate.pp) rest);
-                 (List.map X509.common_name_to_string rest)) ;
   extract_policies version rest >>= fun (_, policies) ->
   (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *)
   match wire_command_of_cert version leaf with
-  | Error (`Parse p) -> Error (`Msg p)
+  | Error (`Msg p) -> Error (`Msg p)
   | Error (`Not_present) ->
     Error (`Msg "leaf certificate does not contain an albatross extension")
   | Error (`Version received) ->

tls/vmm_tls.mli

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