albatross/provision/albatross_provision_ca.ml

167 lines
5.9 KiB
OCaml
Raw Permalink Normal View History

2018-10-28 17:30:02 +00:00
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
2017-05-26 14:30:34 +00:00
open Rresult.R.Infix
open X509
open Albatross_provision
2017-05-26 14:30:34 +00:00
2018-10-26 21:23:17 +00:00
let l_exts =
Extension.(add Key_usage (true, [ `Digital_signature ; `Key_encipherment ])
(add Basic_constraints (true, (false, None))
(singleton Ext_key_usage (true, [ `Client_auth ]))))
2018-10-26 21:23:17 +00:00
let d_exts ?len () =
let kus =
[ `Key_cert_sign ; `CRL_sign ; `Digital_signature ; `Content_commitment ]
in
Extension.(add Basic_constraints (true, (true, len))
(singleton Key_usage (true, kus)))
2018-10-26 21:23:17 +00:00
let s_exts =
Extension.(add Key_usage (true, [ `Digital_signature ; `Key_encipherment ])
(add Basic_constraints (true, (false, None))
(singleton Ext_key_usage (true, [ `Server_auth ]))))
2018-10-26 21:23:17 +00:00
let albatross_extension csr =
2017-05-26 14:30:34 +00:00
let req_exts =
match Signing_request.(Ext.(find Extensions ((info csr).extensions))) with
| Some x -> x
| None -> Extension.empty
2017-05-26 14:30:34 +00:00
in
match Extension.(find (Unsupported Vmm_asn.oid) req_exts) with
| Some (_, v) -> Ok v
| None -> Error (`Msg "couldn't find albatross extension in CSR")
2018-10-26 21:23:17 +00:00
2018-10-29 16:14:51 +00:00
let sign_csr dbname cacert key csr days =
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
2018-10-28 21:28:22 +00:00
(* TODO: check delegation! verify whitelisted commands!? *)
2018-10-26 21:23:17 +00:00
match albatross_extension csr with
| Ok v ->
Vmm_asn.of_cert_extension v >>= fun (version, cmd) ->
if not Vmm_commands.(is_current version) then
Logs.warn (fun m -> m "version in request (%a) different from our version %a, using ours"
Vmm_commands.pp_version version Vmm_commands.pp_version Vmm_commands.current);
let exts, default_days = match cmd with
| `Policy_cmd (`Policy_add _) -> d_exts (), 365
| _ -> l_exts, 1
2018-10-28 21:28:22 +00:00
in
let days = match days with None -> default_days | Some x -> x in
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 v' = Vmm_asn.to_cert_extension cmd in
let extensions = Extension.(add (Unsupported Vmm_asn.oid) (false, v') exts) in
sign ~dbname extensions issuer key csr (Duration.of_day days)
2018-10-26 21:23:17 +00:00
| Error e -> Error e
2017-05-26 14:30:34 +00:00
let sign_main _ db cacert cakey csrname days =
2020-03-13 15:24:52 +00:00
Mirage_crypto_rng_unix.initialize () ;
Bos.OS.File.read (Fpath.v cacert) >>= fun cacert ->
Certificate.decode_pem (Cstruct.of_string cacert) >>= fun cacert ->
Bos.OS.File.read (Fpath.v cakey) >>= fun pk ->
Private_key.decode_pem (Cstruct.of_string pk) >>= fun cakey ->
Bos.OS.File.read (Fpath.v csrname) >>= fun enc ->
Signing_request.decode_pem (Cstruct.of_string enc) >>= fun csr ->
sign_csr (Fpath.v db) cacert cakey csr days
2017-05-26 14:30:34 +00:00
2018-10-28 17:30:02 +00:00
let help _ man_format cmds = function
| None -> `Help (`Pager, None)
| Some t when List.mem t cmds -> `Help (man_format, Some t)
| Some _ -> List.iter print_endline cmds; `Ok ()
2018-10-25 14:55:54 +00:00
2018-10-28 17:30:02 +00:00
let generate _ name db days sname sdays =
2020-03-13 15:24:52 +00:00
Mirage_crypto_rng_unix.initialize () ;
priv_key ~bits:4096 None name >>= fun key ->
2019-10-06 21:38:13 +00:00
let name = [ Distinguished_name.(Relative_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 ->
2019-10-06 21:38:13 +00:00
let sname = [ Distinguished_name.(Relative_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)
2018-10-25 14:55:54 +00:00
open Cmdliner
2019-03-27 23:11:43 +00:00
open Albatross_cli
2018-10-28 17:30:02 +00:00
let csr =
let doc = "signing request" in
2018-10-28 23:32:07 +00:00
Arg.(required & pos 3 (some file) None & info [] ~doc ~docv:"CSR")
2018-10-28 17:30:02 +00:00
let key =
let doc = "Private key" in
2018-10-28 23:32:07 +00:00
Arg.(required & pos 2 (some file) None & info [] ~doc ~docv:"KEY")
2018-10-25 14:55:54 +00:00
let days =
let doc = "Number of days" in
2018-11-23 20:13:54 +00:00
Arg.(value & opt int 3650 & info [ "days" ] ~doc)
2018-10-25 14:55:54 +00:00
let db =
let doc = "Database" in
2018-10-28 23:32:07 +00:00
Arg.(required & pos 1 (some string) None & info [] ~doc ~docv:"DB")
2018-10-25 14:55:54 +00:00
let sname =
let doc = "Server name" in
Arg.(value & opt string "server" & info [ "server" ] ~doc)
let sday =
let doc = "Server validity" in
Arg.(value & opt int 365 & info [ "server-days" ] ~doc)
2018-10-28 17:30:02 +00:00
let generate_cmd =
let doc = "generates a certificate authority" in
let man =
[`S "DESCRIPTION";
`P "Generates a certificate authority."]
in
Term.(term_result (const generate $ setup_log $ nam $ db $ days $ sname $ sday)),
2018-10-28 17:30:02 +00:00
Term.info "generate" ~doc ~man
2018-11-23 20:13:54 +00:00
let days =
let doc = "Number of days" in
Arg.(value & opt (some int) None & info [ "days" ] ~doc)
2018-11-23 20:13:54 +00:00
2019-01-13 21:02:16 +00:00
let cacert =
let doc = "cacert" in
Arg.(required & pos 0 (some file) None & info [] ~doc ~docv:"CACERT")
2018-10-28 17:30:02 +00:00
let sign_cmd =
let doc = "sign a request" in
let man =
[`S "DESCRIPTION";
`P "Signs the certificate signing request."]
in
Term.(term_result (const sign_main $ setup_log $ db $ cacert $ key $ csr $ days)),
2018-10-28 17:30:02 +00:00
Term.info "sign" ~doc ~man
let help_cmd =
let topic =
let doc = "The topic to get help on. `topics' lists the topics." in
Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc)
in
2019-03-27 23:11:43 +00:00
let doc = "display help about albatross_priviion_ca" in
2018-10-28 17:30:02 +00:00
let man =
[`S "DESCRIPTION";
`P "Prints help about commands and subcommands"]
in
Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ topic)),
Term.info "help" ~doc ~man
let default_cmd =
2019-03-27 23:11:43 +00:00
let doc = "Albatross CA provisioning" in
2018-10-28 17:30:02 +00:00
let man = [
`S "DESCRIPTION" ;
2019-03-27 23:11:43 +00:00
`P "$(tname) does CA operations (creation, sign, etc.)" ]
2018-10-28 17:30:02 +00:00
in
Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "albatross_provision_ca" ~version ~doc ~man
2018-10-28 17:30:02 +00:00
let cmds = [ help_cmd ; sign_cmd ; generate_cmd ; (* TODO revoke_cmd *)]
2017-05-26 14:30:34 +00:00
2018-10-28 17:30:02 +00:00
let () =
match Term.eval_choice default_cmd cmds
with `Ok () -> exit 0 | _ -> exit 1