reynir/albatross
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

adapt to X509 0.7.0 API, minor comment and doc tweaks

Browse source
This commit is contained in:
Hannes Mehnert 2019-05-03 20:57:09 +02:00
parent 92c325a7f9
commit 50ed6a8d1e
7 changed files with 133 additions and 118 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
albatross.opam
View file

@ -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"}

82
client/albatross_client_bistro.ml
View file

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

26
provision/albatross_provision.ml
View file

@ -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

89
provision/albatross_provision_ca.ml
View file

@ -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 =

11
provision/albatross_provision_request.ml
View file

@ -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 =

35
tls/vmm_tls.ml
View file

@ -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
if name = "" then
match Vmm_asn.cert_extension_of_cstruct data with
match Distinguished_name.(find CN (Certificate.subject cert)) with
| Some name -> Ok (Some name)
| 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,23 +49,21 @@ 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
| Error (`Msg p) -> Error (`Parse p)
| Ok (v, wire) ->
if not (Vmm_commands.version_eq v version) then
Error (`Version v)
else
Ok wire
Vmm_asn.cert_extension_of_cstruct data >>= fun (v, wire) ->
if not (Vmm_commands.version_eq v version) then
Error (`Version v)
else
Ok wire
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 (`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"
(X509.common_name_to_string leaf)
Fmt.(list ~sep:(unit " -> ") string)
(List.map X509.common_name_to_string rest)) ;
Logs.debug (fun m -> m "leaf is %a, chain %a"
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 *)
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) ->

6
tls/vmm_tls.mli
View file

@ -1,10 +1,10 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
val wire_command_of_cert : Vmm_commands.version -> X509.t ->
(Vmm_commands.t, [> `Parse of string | `Not_present | `Version of Vmm_commands.version ]) result
val wire_command_of_cert : Vmm_commands.version -> X509.Certificate.t ->
(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