albatross/app/vmmp_ca.ml

167 lines
5.5 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
2018-10-26 21:23:17 +00:00
let l_exts =
[ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
; (true, `Basic_constraints (false, None))
; (true, `Ext_key_usage [`Client_auth]) ]
let d_exts ?len () =
[ (true, (`Basic_constraints (true, len)))
; (true, (`Key_usage [ `Key_cert_sign ; `CRL_sign ; `Digital_signature ; `Content_commitment ])) ]
let s_exts =
[ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
; (true, `Basic_constraints (false, None))
; (true, `Ext_key_usage [`Server_auth]) ]
let albatross_extension csr =
2017-05-26 14:30:34 +00:00
let req_exts =
match
2018-10-26 21:23:17 +00:00
List.find (function `Extensions _ -> true | _ -> false) X509.CA.((info csr).extensions)
2017-05-26 14:30:34 +00:00
with
| exception Not_found -> []
| `Extensions x -> x
| _ -> []
in
match
List.filter (function
| (_, `Unsupported (oid, _)) when Asn.OID.equal oid Vmm_asn.oid -> true
| _ -> false)
req_exts
with
2018-10-26 21:23:17 +00:00
| [ (_, `Unsupported (_, v)) as ext ] -> Ok (ext, v)
| _ -> Error (`Msg "couldn't find albatross extension in CSR")
let sign 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
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 (ext, 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
2018-10-23 22:03:36 +00:00
Logs.app (fun m -> m "signing %a" Vmm_commands.pp cmd) ;
2018-10-28 21:28:22 +00:00
Ok (ext :: exts) >>= fun extensions ->
2018-10-28 17:30:02 +00:00
Vmm_provision.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
2018-10-28 17:30:02 +00:00
let sign _ db cacert cakey csrname days =
let days = match days with None -> 1 | Some x -> x in
2017-05-26 14:30:34 +00:00
Nocrypto_entropy_unix.initialize () ;
match
Bos.OS.File.read (Fpath.v cacert) >>= fun cacert ->
let cacert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string cacert) in
Bos.OS.File.read (Fpath.v cakey) >>= fun pk ->
let cakey = X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string pk) in
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
sign (Fpath.v db) cacert cakey csr days
with
| Ok () -> `Ok ()
| Error (`Msg e) -> `Error (false, e)
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 =
let days = match days with None -> 3650 | Some x -> x in
2018-10-25 14:55:54 +00:00
Nocrypto_entropy_unix.initialize () ;
match
2018-10-28 17:30:02 +00:00
Vmm_provision.priv_key ~bits:4096 None name >>= fun key ->
2018-10-25 14:55:54 +00:00
let name = [ `CN name ] in
let csr = X509.CA.request name key in
2018-10-28 17:30:02 +00:00
Vmm_provision.sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () ->
Vmm_provision.priv_key None sname >>= fun skey ->
2018-10-25 14:55:54 +00:00
let sname = [ `CN sname ] in
let csr = X509.CA.request sname skey in
2018-10-28 17:30:02 +00:00
Vmm_provision.sign ~dbname:(Fpath.v db) s_exts name key csr (Duration.of_day sdays)
2018-10-25 14:55:54 +00:00
with
| Ok () -> `Ok ()
| Error (`Msg e) -> `Error (false, e)
open Cmdliner
2018-10-28 17:30:02 +00:00
open Vmm_cli
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-10-28 17:30:02 +00:00
Arg.(value & opt (some int) None & 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.(ret (const generate $ setup_log $ Vmm_provision.nam $ db $ days $ sname $ sday)),
Term.info "generate" ~doc ~man
let sign_cmd =
let doc = "sign a request" in
let man =
[`S "DESCRIPTION";
`P "Signs the certificate signing request."]
in
Term.(ret (const sign $ setup_log $ db $ Vmm_provision.cacert $ key $ csr $ days)),
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
let doc = "display help about vmmp_sign" in
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 =
let doc = "VMM " in
let man = [
`S "DESCRIPTION" ;
`P "$(tname) executes the provided subcommand on a remote albatross" ]
in
Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "vmmp_ca" ~version:"%%VERSION_NUM%%" ~doc ~man
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