albatross/provision/albatross_provision_ca.ml

166 lines
5.7 KiB
OCaml
Raw 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.cert_extension_of_cstruct v >>= fun (version, cmd) ->
2018-10-28 17:30:02 +00:00
(if Vmm_commands.version_eq version version then
Ok ()
else
Error (`Msg "unknown version in request")) >>= fun () ->
2018-10-28 21:28:22 +00:00
let exts = match cmd with
| `Policy_cmd (`Policy_add _) -> d_exts ()
| _ -> l_exts
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 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 =
2017-05-26 14:30:34 +00:00
Nocrypto_entropy_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 =
2018-10-25 14:55:54 +00:00
Nocrypto_entropy_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 int 1 & info [ "days" ] ~doc)
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)),
2019-03-27 23:11:43 +00:00
Term.info "albatross_provision_ca" ~version:"%%VERSION_NUM%%" ~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