vmmp_ca work

README.md

@@ -16,7 +16,7 @@ Command-line applications for local and remote management are provided as well
 - `vmmc_remote`: connects to `vmm_tls_endpoint` and executes command
 - `vmmc_bistro`: command line utility to execute a command remotely: request, sign, remote (do not use in production, requires CA key on host)
 - `vmmp_request`: creates a certificate signing request containing a command
-- `vmmp_sign`: signs a certificate signing request
+- `vmmp_ca`: certificate authority operations: sign, generate (and revoke)
 
 Please read [the blog article](https://hannes.nqsb.io/Posts/VMM) for motivation
 and an overview.

_tags

@@ -19,7 +19,7 @@ true : package(rresult logs ipaddr bos hex ptime astring duration cstruct decomp
 <app/vmmc_bistro.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
 
 <app/vmmp_request.{ml,native,byte}>: package(nocrypto.unix ptime.clock.os x509)
-<app/vmmp_sign.{ml,native,byte}>: package(nocrypto.unix ptime.clock.os x509)
+<app/vmmp_ca.{ml,native,byte}>: package(nocrypto.unix ptime.clock.os x509)
 
 <app/vmm_provision.{ml}>: package(nocrypto.unix ptime.clock.os x509)
 

app/vmmp_ca.ml

@@ -1,6 +1,4 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Vmm_provision
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
 
 open Rresult.R.Infix
 
@@ -46,17 +44,18 @@ let sign dbname cacert key csr days =
   match albatross_extension csr with
   | Ok (ext, v) ->
     Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) ->
-    (if Vmm_commands.version_eq version asn_version then
+    (if Vmm_commands.version_eq version version then
        Ok ()
      else
        Error (`Msg "unknown version in request")) >>= fun () ->
     (* TODO l_exts / d_exts trouble *)
     Logs.app (fun m -> m "signing %a" Vmm_commands.pp cmd) ;
     Ok (ext :: l_exts) >>= fun extensions ->
-    sign ~dbname extensions issuer key csr (Duration.of_day days)
+    Vmm_provision.sign ~dbname extensions issuer key csr (Duration.of_day days)
   | Error e -> Error e
 
-let jump _ db cacert cakey csrname days =
+let sign _ db cacert cakey csrname days =
+  let days = match days with None -> 1 | Some x -> x in
   Nocrypto_entropy_unix.initialize () ;
   match
     Bos.OS.File.read (Fpath.v cacert) >>= fun cacert ->
@@ -70,6 +69,27 @@ let jump _ db cacert cakey csrname days =
   | Ok () -> `Ok ()
   | Error (`Msg e) -> `Error (false, e)
 
+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 ()
+
+let generate _ name db days sname sdays =
+  let days = match days with None -> 3650 | Some x -> x in
+  Nocrypto_entropy_unix.initialize () ;
+  match
+    Vmm_provision.priv_key ~bits:4096 None name >>= fun key ->
+    let name = [ `CN name ] in
+    let csr = X509.CA.request name key in
+    Vmm_provision.sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () ->
+    Vmm_provision.priv_key None sname >>= fun skey ->
+    let sname = [ `CN sname ] in
+    let csr = X509.CA.request sname skey in
+    Vmm_provision.sign ~dbname:(Fpath.v db) s_exts name key csr (Duration.of_day sdays)
+  with
+  | Ok () -> `Ok ()
+  | Error (`Msg e) -> `Error (false, e)
+
 open Cmdliner
 open Vmm_cli
 
@@ -77,46 +97,13 @@ let csr =
   let doc = "signing request" in
   Arg.(required & pos 3 (some file) None & info [] ~doc)
 
-let days =
-  let doc = "Number of days" in
-  Arg.(value & opt int 1 & info [ "days" ] ~doc)
-
 let key =
   let doc = "Private key" in
   Arg.(required & pos 2 (some file) None & info [] ~doc)
 
-let cmd =
-  Term.(ret (const jump $ setup_log $ db $ cacert $ key $ csr $ days)),
-  Term.info "vmmp_sign" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Vmm_provision
-
-open Rresult.R.Infix
-
-let jump _ name db days sname sdays =
-  Nocrypto_entropy_unix.initialize () ;
-  match
-    priv_key ~bits:4096 None name >>= fun key ->
-    let name = [ `CN name ] in
-    let csr = X509.CA.request name key in
-    sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () ->
-    priv_key None sname >>= fun skey ->
-    let sname = [ `CN sname ] in
-    let csr = X509.CA.request sname skey in
-    sign ~dbname:(Fpath.v db) s_exts name key csr (Duration.of_day sdays)
-  with
-  | Ok () -> `Ok ()
-  | Error (`Msg e) -> `Error (false, e)
-
-
-open Cmdliner
-
 let days =
   let doc = "Number of days" in
-  Arg.(value & opt int 3650 & info [ "days" ] ~doc)
+  Arg.(value & opt (some int) None & info [ "days" ] ~doc)
 
 let db =
   let doc = "Database" in
@@ -130,8 +117,48 @@ let sday =
   let doc = "Server validity" in
   Arg.(value & opt int 365 & info [ "server-days" ] ~doc)
 
-let cmd =
-  Term.(ret (const jump $ setup_log $ nam $ db $ days $ sname $ sday)),
-  Term.info "vmmp_sign" ~version:"%%VERSION_NUM%%"
+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 () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1
+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 *)]
+
+let () =
+  match Term.eval_choice default_cmd cmds
+  with `Ok () -> exit 0 | _ -> exit 1

pkg/pkg.ml

@@ -16,5 +16,5 @@ let () =
     Pkg.bin "app/vmmc_remote" ;
     Pkg.bin "app/vmmc_bistro" ;
     Pkg.bin "app/vmmp_request" ;
-    Pkg.bin "app/vmmp_sign" ;
+    Pkg.bin "app/vmmp_ca" ;
   ]