diff --git a/albatross.opam b/albatross.opam index c036cf0..a479b20 100644 --- a/albatross.opam +++ b/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"} diff --git a/client/albatross_client_bistro.ml b/client/albatross_client_bistro.ml index 02224d4..92b5d5a 100644 --- a/client/albatross_client_bistro.ml +++ b/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 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)) diff --git a/provision/albatross_provision.ml b/provision/albatross_provision.ml index 8ff2615..4d7e9aa 100644 --- a/provision/albatross_provision.ml +++ b/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 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 diff --git a/provision/albatross_provision_ca.ml b/provision/albatross_provision_ca.ml index 56cc5da..d70cbc9 100644 --- a/provision/albatross_provision_ca.ml +++ b/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 ]) - ; (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 = diff --git a/provision/albatross_provision_request.ml b/provision/albatross_provision_request.ml index 22f8287..2a692e6 100644 --- a/provision/albatross_provision_request.ml +++ b/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))) ] - 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 = diff --git a/tls/vmm_tls.ml b/tls/vmm_tls.ml index 768ef18..fc83428 100644 --- a/tls/vmm_tls.ml +++ b/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 - 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) -> diff --git a/tls/vmm_tls.mli b/tls/vmm_tls.mli index 619a8ca..b534dfe 100644 --- a/tls/vmm_tls.mli +++ b/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 -> - (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