Skip to content
Permalink
Browse files

adapt to X509 0.7.0 API, minor comment and doc tweaks

  • Loading branch information...
hannesm committed May 3, 2019
1 parent 92c325a commit 50ed6a8d1ead169b3e322aaccb469e870ad72acc
@@ -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"}
@@ -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 auth = (Some (X509.key_id issuer), [], None) in
[ (false, `Subject_key_id (X509.key_id pub)) ; (false, `Authority_key_id auth) ]
let key_ids exts pub issuer =
let auth = (Some (Public_key.id issuer), General_name.empty, None) in
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,40 +35,50 @@ 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
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 ])
; (true, `Basic_constraints (false, None))
; (true, `Ext_key_usage [`Client_auth]) ;
(false, `Unsupported (Vmm_asn.oid, Vmm_asn.cert_extension_to_cstruct (version, cmd))) ] in
let csr =
let name = [ `CN name ] in
X509.CA.request name ~extensions:[`Extensions extensions] (`RSA tmpkey)
in
let mycert =
let valid_from, valid_until = timestamps 300 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 =
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)
let v = Vmm_asn.cert_extension_to_cstruct (version, cmd) in
Extension.(add Key_usage (true, [ `Digital_signature ; `Key_encipherment ])
(add Basic_constraints (true, (false, None))
(add Ext_key_usage (true, [ `Client_auth ])
(singleton (Unsupported Vmm_asn.oid) (false, v)))))
in
let issuer = X509.subject cert in
X509.CA.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
Logs.debug (fun m -> m "connecting to remote host") ;
Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun () ->
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") ;
read t
let csr =
let name = Distinguished_name.(singleton CN name) in
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
key_ids extensions Signing_request.((info csr).public_key) (`RSA capub)
in
let issuer = Certificate.subject cert in
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.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") ;
read t

let jump endp cert key ca name cmd =
Ok (Lwt_main.run (handle endp cert key ca name cmd))
@@ -29,19 +29,19 @@ let append name data =
go 0 >>= fun () ->
safe Unix.close fd

let key_ids pub issuer =
let auth = (Some (X509.key_id issuer), [], None) in
[ (false, `Subject_key_id (X509.key_id pub)) ; (false, `Authority_key_id auth) ]
let key_ids exts pub issuer =
let auth = Some (X509.Public_key.id issuer), X509.General_name.empty, None in
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)
with Not_found -> Error (`Msg "unable to discover certificate name")) >>= function
| `CN name -> Ok name
| _ -> Error (`Msg "cannot happen")) >>= fun certname ->
match X509.(Distinguished_name.find CN Signing_request.((info csr).subject)) with
| Some name -> Ok name
| None -> Error (`Msg "couldn't find name (no common name in CSR subject)")) >>= 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 () ->
let enc = X509.Encoding.Pem.Certificate.to_pem_cstruct1 cert in
append dbname (Printf.sprintf "%s %s\n" (Z.to_string (X509.Certificate.serial cert)) certname)) >>= fun () ->
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

@@ -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 ])
; (true, `Basic_constraints (false, None))
; (true, `Ext_key_usage [`Client_auth]) ]
Extension.(add Key_usage (true, [ `Digital_signature ; `Key_encipherment ])
(add Basic_constraints (true, (false, None))
(singleton Ext_key_usage (true, [ `Client_auth ]))))

let d_exts ?len () =
[ (true, (`Basic_constraints (true, len)))
; (true, (`Key_usage [ `Key_cert_sign ; `CRL_sign ; `Digital_signature ; `Content_commitment ])) ]
let kus =
[ `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 ])
; (true, `Basic_constraints (false, None))
; (true, `Ext_key_usage [`Server_auth]) ]
Extension.(add Key_usage (true, [ `Digital_signature ; `Key_encipherment ])
(add Basic_constraints (true, (false, None))
(singleton Ext_key_usage (true, [ `Server_auth ]))))

let albatross_extension csr =
let req_exts =
match
List.find (function `Extensions _ -> true | _ -> false) X509.CA.((info csr).extensions)
with
| exception Not_found -> []
| `Extensions x -> x
| _ -> []
match Signing_request.(Ext.(find Extensions ((info csr).extensions))) with
| Some x -> x
| None -> Extension.empty
in
match
List.filter (function
| (_, `Unsupported (oid, _)) when Asn.OID.equal oid Vmm_asn.oid -> true
| _ -> false)
req_exts
with
| [ (_, `Unsupported (_, v)) as ext ] -> Ok (ext, v)
| _ -> Error (`Msg "couldn't find albatross extension in CSR")
match Extension.(find (Unsupported Vmm_asn.oid) req_exts) with
| Some (_, v) -> Ok v
| None -> Error (`Msg "couldn't find albatross extension in CSR")

let sign_csr dbname cacert key csr days =
let ri = X509.CA.info csr in
Logs.app (fun m -> m "signing certificate with subject %s"
(X509.distinguished_name_to_string ri.X509.CA.subject)) ;
let issuer = X509.subject cacert in
let ri = Signing_request.info csr in
Logs.app (fun m -> m "signing certificate with subject %a"
Distinguished_name.pp ri.Signing_request.subject);
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) ;
Ok (ext :: exts) >>= fun extensions ->
Albatross_provision.sign ~dbname extensions issuer key csr (Duration.of_day days)
Logs.app (fun m -> m "signing %a" Vmm_commands.pp cmd);
(* the "false" is here since X509 validation bails on exts marked as
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 ->
let name = [ `CN name ] in
let csr = X509.CA.request name key in
Albatross_provision.sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () ->
Albatross_provision.priv_key None sname >>= fun skey ->
let sname = [ `CN sname ] in
let csr = X509.CA.request sname skey in
Albatross_provision.sign ~dbname:(Fpath.v db) s_exts name key csr (Duration.of_day sdays)
priv_key ~bits:4096 None name >>= fun key ->
let name = Distinguished_name.(singleton CN name) in
let csr = Signing_request.create name key in
sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () ->
priv_key None sname >>= fun skey ->
let sname = Distinguished_name.(singleton CN sname) in
let csr = Signing_request.create sname skey in
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 =
@@ -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))) ]
and name = [ `CN name ]
let ext =
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 =

0 comments on commit 50ed6a8

Please sign in to comment.
You can’t perform that action at this time.