reuse commands from Vmm_asn.wire_commands for certificates

pkg/pkg.ml

@@ -13,11 +13,9 @@ let () =
     Pkg.bin "app/vmm_client" ;
     Pkg.bin "app/vmm_tls_endpoint" ;
     Pkg.bin "app/vmmc" ;
-    Pkg.bin "provision/vmm_req_command" ;
     Pkg.bin "provision/vmm_req_delegation" ;
     Pkg.bin "provision/vmm_req_vm" ;
     Pkg.bin "provision/vmm_sign" ;
-    Pkg.bin "provision/vmm_revoke" ;
     Pkg.bin "provision/vmm_gen_ca" ;
     (* Pkg.clib "stats/libvmm_stats_stubs.clib" ; *)
     Pkg.bin "stats/vmm_stats_lwt" ;

provision/vmm_provision.ml

@@ -1,6 +1,6 @@
 (* (c) 2017 Hannes Mehnert, all rights reserved *)
 
-let asn_version = `AV1
+let asn_version = `AV2
 
 let setup_log style_renderer level =
   Fmt_tty.setup_std_outputs ?style_renderer ();

provision/vmm_req_command.ml

@@ -1,62 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Vmm_provision
-
-open Rresult.R.Infix
-
-open Vmm_asn
-
-let cmd_csr name key command block_device block_size =
-  let bd = match block_device with
-    | None -> []
-    | Some x -> [ (false, `Unsupported (Oid.block_device, string_to_cstruct x)) ]
-  in
-  let bs = match block_size with
-    | None -> []
-    | Some x -> [ (false, `Unsupported (Oid.memory, int_to_cstruct x)) ]
-  in
-  let exts =
-    [ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ;
-      (false, `Unsupported (Oid.command, command_to_cstruct command)) ] @ bd @ bs
-  and name = [ `CN name ]
-  in
-  X509.CA.request name ~extensions:[`Extensions exts] key
-
-let jump _ name key command block_device block_size =
-  Nocrypto_entropy_unix.initialize () ;
-  match
-    priv_key key name >>= fun key ->
-    let csr = cmd_csr name key command block_device block_size in
-    let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in
-    Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc)
-  with
-  | Ok () -> `Ok ()
-  | Error (`Msg m) -> `Error (false, m)
-
-open Cmdliner
-
-let cmd =
-  let parse s =
-    match Vmm_core.command_of_string s with
-    | Some x -> `Ok x
-    | None -> `Error "invalid command"
-  in
-  (parse, Vmm_core.pp_command)
-
-let command =
-  let doc = "command" in
-  Arg.(required & pos 1 (some cmd) None & info [] ~doc)
-
-let block_device =
-  let doc = "block device" in
-  Arg.(value & opt (some string) None & info [ "block-device" ] ~doc)
-
-let block_size =
-  let doc = "block size in MB" in
-  Arg.(value & opt (some int) None & info [ "block-size" ] ~doc)
-
-let cmd =
-  Term.(ret (const jump $ setup_log $ nam $ key $ command $ block_device $ block_size)),
-  Term.info "vmm_req_command" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

provision/vmm_req_delegation.ml

@@ -7,20 +7,17 @@ open Rresult.R.Infix
 
 open Astring
 
-let subca_csr key name cpus mem vms block bridges =
+let subca_csr key name cpus memory vms block bridges =
-  let block = match block with
+  let cpuids = Vmm_core.IS.of_list cpus
-    | None -> []
+  and bridges = List.fold_left (fun acc b -> match b with
-    | Some x -> [ (false, `Unsupported (Oid.block, int_to_cstruct x)) ]
+      | `Internal name -> String.Map.add name b acc
-  and bridge = match bridges with
+      | `External (name, _, _, _, _) -> String.Map.add name b acc)
-    | [] -> []
+      String.Map.empty bridges
-    | xs -> [ (false, `Unsupported (Oid.bridges, bridges_to_cstruct xs)) ]
   in
+  let policy = Vmm_core.{ vms ; cpuids ; memory ; block ; bridges } in
+  let cmd = `Policy_cmd (`Policy_add policy) in
   let exts =
-    [ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ;
+    [ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, cmd))) ]
-      (false, `Unsupported (Oid.cpuids, ints_to_cstruct cpus)) ;
-      (false, `Unsupported (Oid.memory, int_to_cstruct mem)) ;
-      (false, `Unsupported (Oid.vms, int_to_cstruct vms)) ;
-    ] @ block @ bridge
   and name = [ `CN name ]
   in
   X509.CA.request name ~extensions:[`Extensions exts] key

provision/vmm_req_vm.ml

@@ -6,31 +6,19 @@ open Rresult.R.Infix
 
 open Vmm_asn
 
-let vm_csr key name image cpu mem args block net force compression =
+let vm_csr key name image cpuid requested_memory argv block_device network force compression =
-  let block = match block with
+  let vm_config =
-    | None -> []
+    let vmimage = match compression with
-    | Some x -> [ (false, `Unsupported (Oid.block_device, string_to_cstruct x)) ]
+      | 0 -> `Hvt_amd64, image
-  and arg = match args with
+      | level ->
-    | [] -> []
+        let img = Vmm_compress.compress ~level (Cstruct.to_string image) in
-    | xs -> [ (false, `Unsupported (Oid.argv, strings_to_cstruct xs)) ]
+        `Hvt_amd64_compressed, Cstruct.of_string img
-  and net = match net with
+    and argv = match argv with [] -> None | xs -> Some xs
-    | [] -> []
+    in
-    | xs -> [ (false, `Unsupported (Oid.network, strings_to_cstruct xs)) ]
+    Vmm_core.{ cpuid ; requested_memory ; block_device ; network ; argv ; vmimage }
-  and cmd = if force then `Force_create_vm else `Create_vm
   in
-  let image = match compression with
+  let cmd = if force then `Vm_force_create vm_config else `Vm_create vm_config in
-    | 0 -> image_to_cstruct (`Hvt_amd64, image)
+  let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, `Vm_cmd cmd))) ]
-    | level ->
-      let img = Vmm_compress.compress ~level (Cstruct.to_string image) in
-      image_to_cstruct (`Hvt_amd64_compressed, Cstruct.of_string img)
-  in
-  let exts =
-    [ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ;
-      (false, `Unsupported (Oid.cpuid, int_to_cstruct cpu)) ;
-      (false, `Unsupported (Oid.memory, int_to_cstruct mem)) ;
-      (false, `Unsupported (Oid.vmimage, image)) ;
-      (false, `Unsupported (Oid.command, command_to_cstruct cmd)) ;
-    ] @ block @ arg @ net
   and name = [ `CN name ]
   in
   X509.CA.request name ~extensions:[`Extensions exts] key

provision/vmm_revoke.ml

@@ -1,98 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Vmm_provision
-
-open Astring
-
-open Rresult.R.Infix
-
-
-let parse_db lines =
-  List.fold_left (fun acc s ->
-      acc >>= fun datas ->
-      match String.cut ~sep:" " s with
-      | None -> Rresult.R.error_msgf "unable to parse entry %s" s
-      | Some (a, b) ->
-        (try Ok (Z.of_string a) with Invalid_argument x -> Error (`Msg x)) >>= fun s ->
-        Ok ((s, b) :: datas))
-    (Ok []) lines
-
-let find_in_db label db tst =
-  try Ok (List.find tst db)
-  with Not_found -> Rresult.R.error_msgf "couldn't find %s in database" label
-
-let find_name db name =
-  find_in_db name db (fun (_, n) -> String.equal n name) >>= fun (serial, _) ->
-  Ok serial
-
-
-let jump _ db cacert cakey crl cn serial =
-  Nocrypto_entropy_unix.initialize () ;
-  match
-    (match cn, serial with
-     | x, y when x = "" && String.length y > 0 ->
-       (try Ok (Z.of_string y) with Invalid_argument x -> Error (`Msg x))
-     | x, y when y = "" ->
-       Bos.OS.File.read_lines (Fpath.v db) >>= fun entries ->
-       parse_db entries >>= fun db ->
-       find_name db x
-     | _ -> Error (`Msg "please provide either common name or serial!")) >>= fun serial ->
-    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 cacert) >>= fun cacert ->
-    let cacert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string cacert) in
-
-    let this_update = Ptime_clock.now () in
-    let revoked = { X509.CRL.serial ; date = this_update ; extensions = [] } in
-    let crl = Fpath.v crl in
-    let issuer = X509.subject cacert in
-    (Bos.OS.File.exists crl >>= function
-      | true ->
-        Bos.OS.File.read crl >>= fun crl ->
-        (match X509.Encoding.crl_of_cstruct (Cstruct.of_string crl) with
-         | None -> Error (`Msg "couldn't parse CRL")
-         | Some c -> Ok (X509.CRL.revoke_certificate revoked ~this_update c cakey))
-      | false ->
-        Ok (X509.CRL.revoke
-              ~issuer
-              ~this_update
-              ~extensions:[ (false, `CRL_number 0) ]
-              [ revoked ] cakey)) >>= fun new_crl ->
-    let crl_cs = X509.Encoding.crl_to_cstruct new_crl in
-    Bos.OS.File.write crl (Cstruct.to_string crl_cs) >>= fun () ->
-    (* create temporary certificate for uploading CRL *)
-    let name = "revoke" in
-    priv_key None name >>= fun key ->
-    let csr = X509.CA.request [ `CN name ] key in
-    let extensions = [ (false, `Unsupported (Vmm_asn.Oid.version, Vmm_asn.version_to_cstruct asn_version)) ;
-                       (false, `Unsupported (Vmm_asn.Oid.command, Vmm_asn.command_to_cstruct `Crl)) ;
-                       (false, `Unsupported (Vmm_asn.Oid.crl, crl_cs)) ] @ l_exts
-    in
-    sign ~dbname:(Fpath.v db) extensions issuer cakey csr (Duration.of_hour 1)
-  with
-  | Ok () -> `Ok ()
-  | Error (`Msg e) -> `Error (false, e)
-
-open Cmdliner
-
-let key =
-  let doc = "Private key" in
-  Arg.(required & pos 2 (some file) None & info [] ~doc)
-
-let crl =
-  let doc = "Revocation list" in
-  Arg.(required & pos 3 (some file) None & info [] ~doc)
-
-let cn =
-  let doc = "Common Name" in
-  Arg.(value & opt string "" & info [ "cn" ] ~doc)
-
-let serial =
-  let doc = "Serial" in
-  Arg.(value & opt string "" & info [ "serial" ] ~doc)
-
-let cmd =
-  Term.(ret (const jump $ setup_log $ db $ cacert $ key $ crl $ cn $ serial)),
-  Term.info "vmm_revoke" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

provision/vmm_sign.ml

@@ -31,12 +31,7 @@ let sign dbname cacert key csr days =
                (X509.distinguished_name_to_string ri.X509.CA.subject)) ;
   let issuer = X509.subject cacert in
   (* TODO: handle version mismatch of the delegation cert specially here *)
-  let policy = match Vmm_asn.policy_of_cert asn_version cacert with
+  (* TODO: check delegation! *)
-    | Ok d -> Some d
-    | Error _ -> None
-  in
-  Logs.app (fun m -> m "using delegation %s: %a" (X509.distinguished_name_to_string issuer)
-               Fmt.(option ~none:(unit "no") Vmm_core.pp_policy) policy) ;
   let req_exts =
     match
       List.find (function `Extensions _ -> true | _ -> false) ri.X509.CA.extensions
@@ -45,224 +40,23 @@ let sign dbname cacert key csr days =
     | `Extensions x -> x
     | _ -> []
   in
-  req Vmm_asn.Oid.version req_exts Vmm_asn.version_of_cstruct >>= fun v ->
+  match
-  (if Vmm_asn.version_eq v asn_version then
+    List.filter (function
-     Ok ()
+        | (_, `Unsupported (oid, _)) when Asn.OID.equal oid Vmm_asn.oid -> true
-   else
+        | _ -> false)
-     Error (`Msg "unknown version in request")) >>= fun () ->
+      req_exts
-  let s_exts = [ (Vmm_asn.Oid.version, Vmm_asn.version_to_cstruct v) ] in
+  with
-  let get_int () =
+  | [ (_, `Unsupported (_, v)) as ext ] ->
-    let id = read_line () in
+    Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) ->
-    (try Ok (int_of_string id) with
+    (if Vmm_asn.version_eq version asn_version then
-     | Failure _ -> Error (`Msg "couldn't parse integer"))
+       Ok ()
-  in
+     else
-  (match has Vmm_asn.Oid.vmimage req_exts, has Vmm_asn.Oid.vms req_exts with
+       Error (`Msg "unknown version in request")) >>= fun () ->
-   | true, false -> Ok `Vm
+    (* TODO l_exts / d_exts trouble *)
-   | false, true -> Ok `Delegation
+    Logs.app (fun m -> m "signing %a" Vmm_asn.pp_wire_command cmd) ;
-   | false, false -> Ok `Command
+    Ok (ext :: l_exts) >>= fun extensions ->
-   | _ -> Error (`Msg "cannot categorise signing request")) >>= (function
+    sign ~dbname extensions issuer key csr (Duration.of_day days)
-      | `Vm ->
+  | _ -> Error (`Msg "none or multiple albatross extensions found")
-        Logs.app (fun m -> m "categorised as a virtual machine request") ;
-        req Vmm_asn.Oid.vmimage req_exts Vmm_asn.image_of_cstruct >>= fun (typ, img) ->
-        Logs.app (fun m -> m "image of type %a, size %d" Vmm_core.pp_vmtype typ (Cstruct.len img)) ;
-        let s_exts = (Vmm_asn.Oid.vmimage, Vmm_asn.image_to_cstruct (typ, img)) :: s_exts in
-        let cpuids = match policy with
-          | None -> None
-          | Some x -> Some (Vmm_core.IS.elements x.Vmm_core.cpuids)
-        in
-        (opt Vmm_asn.Oid.cpuid req_exts Vmm_asn.int_of_cstruct >>= function
-          | None ->
-            Logs.warn (fun m -> m "no CPU specified, please specify one of %a: "
-                          Fmt.(option ~none:(unit "??") (list ~sep:(unit ",") int)) cpuids) ;
-            get_int () >>= fun cpu ->
-            (match cpuids with
-             | None -> Ok cpu
-             | Some x when List.mem cpu x -> Ok cpu
-             | Some _ -> Error (`Msg "refusing to use a not-delegated CPU"))
-          | Some cpu ->
-            match cpuids with
-            | None -> Ok cpu
-            | Some x when List.mem cpu x -> Ok cpu
-            | Some x ->
-              Logs.err (fun m -> m "CPU id %d was requested, which is not delegated, please specify one of %a:"
-                           cpu Fmt.(list ~sep:(unit ",") int) x) ;
-              get_int () >>= fun cpu ->
-              if List.mem cpu x then Ok cpu
-              else Error (`Msg "refusing to use a not-delegated CPU")) >>= fun cpuid ->
-        Logs.app (fun m -> m "using CPU %d" cpuid) ;
-        let s_exts = (Vmm_asn.Oid.cpuid, Vmm_asn.int_to_cstruct cpuid) :: s_exts in
-        let memory = match policy with
-          | None -> None
-          | Some x -> Some x.Vmm_core.memory
-        in
-        (opt Vmm_asn.Oid.memory req_exts Vmm_asn.int_of_cstruct >>= function
-          | None ->
-            Logs.warn (fun m -> m "no memory specified, please specify amount (max %a):"
-                          Fmt.(option ~none:(unit "??") int) memory) ;
-            get_int () >>= fun m ->
-            (match memory with
-             | None -> Ok m
-             | Some x when m <= x -> Ok m
-             | Some _ -> Error (`Msg "refusing to overcommit memory"))
-          | Some me ->
-            match memory with
-            | None -> Ok me
-            | Some x when me < x -> Ok me
-            | Some x ->
-              Logs.err (fun m -> m "you have %d memory delegated, but %d is requested, please specify a smaller amount:" x me) ;
-              get_int () >>= fun m ->
-              if m <= x then Ok m
-              else Error (`Msg "refusing to use that much memory")) >>= fun mem ->
-        Logs.app (fun m -> m "using %d memory" mem) ;
-        let s_exts = (Vmm_asn.Oid.memory, Vmm_asn.int_to_cstruct mem) :: s_exts in
-        (opt Vmm_asn.Oid.network req_exts Vmm_asn.strings_of_cstruct >>= function
-          | None -> Ok None
-          | Some [] -> Ok None
-          | Some x ->
-            match policy with
-            | None -> Ok (Some x)
-            | Some del ->
-              let bridges = del.Vmm_core.bridges in
-              List.fold_left (fun r x ->
-                  r >>= fun () -> match String.Map.find x bridges with
-                  | None ->
-                    Rresult.R.error_msgf
-                      "won't get you a network interface on bridge %s, which is not delegated." x
-                  | Some _ -> Ok ())
-                (Ok ()) x >>= fun () ->
-              Ok (Some x)) >>= fun net ->
-        Logs.app (fun m -> m "using network interfaces %a"
-                     Fmt.(option ~none:(unit "none") (list ~sep:(unit ",") string)) net) ;
-        let s_exts =
-          match net with
-          | None -> s_exts
-          | Some n -> (Vmm_asn.Oid.network, Vmm_asn.strings_to_cstruct n) :: s_exts
-        in
-        (opt Vmm_asn.Oid.block_device req_exts Vmm_asn.string_of_cstruct >>= function
-          | None -> Ok None
-          | Some x ->
-            match policy with
-            | None -> Ok (Some x)
-            | Some d -> match d.Vmm_core.block with
-              | None -> Error (`Msg "trying to use a block device, when no block storage is delegated")
-              | Some _ -> Ok (Some x)) >>= fun block_device ->
-        Logs.app (fun m -> m "using block device %a"
-                     Fmt.(option ~none:(unit "none") string) block_device) ;
-        let s_exts = match block_device with
-          | None -> s_exts
-          | Some x -> (Vmm_asn.Oid.block_device, Vmm_asn.string_to_cstruct x) :: s_exts
-        in
-        opt Vmm_asn.Oid.argv req_exts Vmm_asn.strings_of_cstruct >>= fun argv ->
-        Logs.app (fun m -> m "using argv %a"
-                     Fmt.(option ~none:(unit "none")
-                            (list ~sep:(unit ", ") string)) argv) ;
-        let s_exts = match argv with
-          | None -> s_exts
-          | Some a -> (Vmm_asn.Oid.argv, Vmm_asn.strings_to_cstruct a) :: s_exts
-        in
-        req Vmm_asn.Oid.command req_exts Vmm_asn.command_of_cstruct >>= fun command ->
-        Logs.app (fun m -> m "using command %a" Vmm_core.pp_command command) ;
-        let s_exts = (Vmm_asn.Oid.command, Vmm_asn.command_to_cstruct command) :: s_exts in
-        let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in
-        Ok (exts @ l_exts)
-      | `Delegation ->
-        (req Vmm_asn.Oid.cpuids req_exts Vmm_asn.ints_of_cstruct >>= fun x ->
-         match policy with
-         | None -> Ok x
-         | Some d when Vmm_core.IS.subset d.Vmm_core.cpuids (Vmm_core.IS.of_list x) -> Ok x
-         | Some d -> Rresult.R.error_msgf
-                       "CPUs %a are not a subset of the delegated ones %a"
-                       Fmt.(list ~sep:(unit ",") int) x
-                       Fmt.(list ~sep:(unit ",") int) (Vmm_core.IS.elements d.Vmm_core.cpuids)) >>= fun cpuids ->
-        Logs.app (fun m -> m "delegating CPUs %a" Fmt.(list ~sep:(unit ",") int) cpuids) ;
-        let s_exts = (Vmm_asn.Oid.cpuids, Vmm_asn.ints_to_cstruct cpuids) :: s_exts in
-        (req Vmm_asn.Oid.memory req_exts Vmm_asn.int_of_cstruct >>= fun x ->
-         match policy with
-         | None -> Ok x
-         | Some d when d.Vmm_core.memory >= x -> Ok x
-         | Some d -> Rresult.R.error_msgf
-                       "cannot delegate %d memory, only have %d delegated" x d.Vmm_core.memory) >>= fun mem ->
-        Logs.app (fun m -> m "delegating %d memory" mem) ;
-        let s_exts = (Vmm_asn.Oid.memory, Vmm_asn.int_to_cstruct mem) :: s_exts in
-        (opt Vmm_asn.Oid.block req_exts Vmm_asn.int_of_cstruct >>= function
-          | None -> Ok None
-          | Some x when x = 0 -> Ok None
-          | Some x -> match policy with
-            | None -> Ok (Some x)
-            | Some d -> match d.Vmm_core.block with
-              | None -> Error (`Msg "cannot delegate block storage, don't have any delegated")
-              | Some d when d >= x -> Ok (Some x)
-              | Some d -> Rresult.R.error_msgf
-                            "cannot delegate %d block storage, only have %d delegated" x d) >>= fun bl ->
-        Logs.app (fun m -> m "delegating %a block storage" Fmt.(option ~none:(unit "none") int) bl) ;
-        let s_exts = match bl with
-          | None -> s_exts
-          | Some x -> (Vmm_asn.Oid.block, Vmm_asn.int_to_cstruct x) :: s_exts
-        in
-        (req Vmm_asn.Oid.vms req_exts Vmm_asn.int_of_cstruct >>= fun x ->
-         match policy with
-         | None -> Ok x
-         | Some d when d.Vmm_core.vms >= x -> Ok x
-         | Some d -> Rresult.R.error_msgf
-                       "cannot delegate %d vms, only have %d delegated" x d.Vmm_core.vms) >>= fun vm ->
-        Logs.app (fun m -> m "delegating %d vms" vm) ;
-        let s_exts = (Vmm_asn.Oid.vms, Vmm_asn.int_to_cstruct vm) :: s_exts in
-        (opt Vmm_asn.Oid.bridges req_exts Vmm_asn.bridges_of_cstruct >>= function
-          | None -> Ok None
-          | Some xs when xs = [] -> Ok None
-          | Some xs -> match policy with
-            | None -> Ok (Some xs)
-            | Some x ->
-              let sub =
-                let add m v =
-                  let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
-                  String.Map.add n v m
-                in
-                List.fold_left add String.Map.empty xs
-              in
-              if Vmm_core.sub_bridges x.Vmm_core.bridges sub then Ok (Some xs)
-              else Error (`Msg "cannot delegate bridges which are not delegated in this ca cert")) >>= fun bridges ->
-        Logs.app (fun m -> m "delegating bridges: %a"
-                     Fmt.(option ~none:(unit "none") (list ~sep:(unit ",") Vmm_core.pp_bridge))
-                     bridges) ;
-        let s_exts = match bridges with
-          | None -> s_exts
-          | Some b -> (Vmm_asn.Oid.bridges, Vmm_asn.bridges_to_cstruct b) :: s_exts
-        in
-        let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in
-        let pl = match X509.Extension.basic_constraints cacert with
-          | None -> None
-          | Some (true, n) -> Some n
-          | Some (false, _) -> None
-        in
-        Logs.app (fun m -> m "how much deeper should delegate be able to share? (max %a)"
-                     Fmt.(option ~none:(unit "??") (option ~none:(unit "unlimited") int)) pl) ;
-        get_int () >>= fun len ->
-        (match pl with
-         | None | Some None -> Ok ()
-         | Some (Some x) when x >= succ len -> Ok ()
-         | Some _ -> Error (`Msg "cannot delegate that deep")) >>= fun () ->
-        Ok (exts @ d_exts ~len ())
-      | `Command ->
-        req Vmm_asn.Oid.command req_exts Vmm_asn.command_of_cstruct >>= fun command ->
-        Logs.app (fun m -> m "a leaf certificate with command %a"
-                     Vmm_core.pp_command command) ;
-        let s_exts = (Vmm_asn.Oid.command, Vmm_asn.command_to_cstruct command) :: s_exts in
-        (match command with
-         | `Create_block | `Destroy_block ->
-           req Vmm_asn.Oid.block_device req_exts Vmm_asn.string_of_cstruct >>| fun block_device ->
-           Logs.app (fun m -> m "block device %s" block_device) ;
-           (Vmm_asn.Oid.block_device, Vmm_asn.string_to_cstruct block_device) :: s_exts
-         | _ -> Ok s_exts) >>= fun s_exts ->
-        (match command with
-         | `Create_block ->
-           req Vmm_asn.Oid.memory req_exts Vmm_asn.int_of_cstruct >>| fun block_size ->
-           Logs.app (fun m -> m "block size %dMB" block_size) ;
-           (Vmm_asn.Oid.memory, Vmm_asn.int_to_cstruct block_size) :: s_exts
-          | _ -> Ok s_exts) >>= fun s_exts ->
-        let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in
-        Ok (exts @ l_exts)) >>= fun extensions ->
-  sign ~dbname extensions issuer key csr (Duration.of_day days)
 
 let jump _ db cacert cakey csrname days =
   Nocrypto_entropy_unix.initialize () ;

src/vmm_asn.ml

@@ -5,53 +5,7 @@ open Vmm_core
 open Rresult
 open Astring
 
-module Oid = struct
+let oid = Asn.OID.(base 1 3 <| 6 <| 1 <| 4 <| 1 <| 49836 <| 43)
-  open Asn.OID
-
-  let m = base 1 3 <| 6 <| 1 <| 4 <| 1 <| 49836 <| 42
-
-  let version = m <| 0
-
-  (* used only in CA certs *)
-  let vms = m <| 1
-  let bridges = m <| 2
-  let block = m <| 3
-  let cpuids = m <| 4
-  (* TODO: embed host URL (well, or use common name / SubjectAlternativeName with IP, and static port?) *)
-
-  (* used in both CA and VM certs, also for block_create *)
-  let memory = m <| 5
-
-  (* used only in VM certs *)
-  let cpuid = m <| 6
-  let network = m <| 7
-  let block_device = m <| 8
-  let vmimage = m <| 9
-  let argv = m <| 10
-
-  (* used in leaf certs *)
-  let command = m <| 42
-
-  (* used in CRL certs *)
-  let crl = m <| 43
-end
-
-let command : command Asn.t =
-  let alist = [
-    0, `Info ;
-    1, `Create_vm ;
-    2, `Force_create_vm ;
-    3, `Destroy_vm ;
-    4, `Statistics ;
-    5, `Console ;
-    6, `Log ;
-    7, `Crl ;
-    8, `Create_block ;
-    9, `Destroy_block ;
-  ]
-  in
-  let rev = List.map (fun (k, v) -> (v, k)) alist in
-  Asn.S.enumerated (fun i -> List.assoc i alist) (fun k -> List.assoc k rev)
 
 open Rresult.R.Infix
 
@@ -68,9 +22,6 @@ let projections_of asn =
   let c = Asn.codec Asn.der asn in
   (decode_strict c, Asn.encode c)
 
-let int_of_cstruct, int_to_cstruct = projections_of Asn.S.int
-let ints_of_cstruct, ints_to_cstruct = projections_of Asn.S.(sequence_of int)
-
 let ipv4 =
   let f cs = Ipaddr.V4.of_bytes_exn (Cstruct.to_string cs)
   and g ip = Cstruct.of_string (Ipaddr.V4.to_bytes ip)
@@ -95,14 +46,6 @@ let bridge =
                           (required ~label:"router" ipv4)
                           (required ~label:"netmask" int))))
 
-let bridges_of_cstruct, bridges_to_cstruct =
-  projections_of (Asn.S.sequence_of bridge)
-
-let strings_of_cstruct, strings_to_cstruct =
-  projections_of Asn.S.(sequence_of utf8_string)
-
-let string_of_cstruct, string_to_cstruct = projections_of Asn.S.utf8_string
-
 let policy =
   let f (cpuids, vms, memory, block, bridges) =
     let bridges = match bridges with
@@ -143,20 +86,6 @@ let image =
            (explicit 1 octet_string)
            (explicit 2 octet_string))
 
-let image_of_cstruct, image_to_cstruct = projections_of image
-
-let command_of_cstruct, command_to_cstruct = projections_of command
-
-let req label cert oid f =
-  match X509.Extension.unsupported cert oid with
-  | None -> R.error_msgf "OID %s not present (%a)" label Asn.OID.pp oid
-  | Some (_, data) -> f data
-
-let opt cert oid f =
-  match X509.Extension.unsupported cert oid with
-  | None -> Ok None
-  | Some (_, data) -> f data >>| fun s -> Some s
-
 type version = [ `AV0 | `AV1 | `AV2 ]
 
 let version_of_int = function
@@ -184,78 +113,6 @@ let version_eq a b =
   | `AV2, `AV2 -> true
   | _ -> false
 
-let version_to_cstruct v = int_to_cstruct (version_to_int v)
-
-let version_of_cstruct cs =
-  int_of_cstruct cs >>= fun v ->
-  version_of_int v
-
-let version_of_cert version cert =
-  req "version" cert Oid.version version_of_cstruct >>= fun version' ->
-  if version_eq version version' then
-    Ok ()
-  else
-    R.error_msgf "unsupported asn version %a (expected %a)"
-      pp_version version' pp_version version
-
-let policy_of_cert version cert =
-  version_of_cert version cert >>= fun () ->
-  req "cpuids" cert Oid.cpuids ints_of_cstruct >>= fun cpuids ->
-  req "memory" cert Oid.memory int_of_cstruct >>= fun memory ->
-  opt cert Oid.block int_of_cstruct >>= fun block ->
-  req "vms" cert Oid.vms int_of_cstruct >>= fun vms ->
-  opt cert Oid.bridges bridges_of_cstruct >>= fun bridges ->
-  let bridges = match bridges with
-    | None -> String.Map.empty
-    | Some xs ->
-      let add m v =
-        let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
-        String.Map.add n v m
-      in
-      List.fold_left add String.Map.empty xs
-  and cpuids = IS.of_list cpuids
-  in
-  Ok { vms ; cpuids ; memory ; block ; bridges }
-
-let contains_vm cert =
-  match X509.Extension.unsupported cert Oid.vmimage with
-  | None -> false
-  | Some _ -> true
-
-let contains_crl cert =
-  match X509.Extension.unsupported cert Oid.crl with
-  | None -> false
-  | Some _ -> true
-
-let crl_of_cert cert =
-  let crl cs = match X509.Encoding.crl_of_cstruct cs with
-    | None -> Error (`Msg "couldn't parse revocation list")
-    | Some x -> Ok x
-  in
-  req "crl" cert Oid.crl crl
-
-let vm_of_cert prefix cert =
-  req "cpuid" cert Oid.cpuid int_of_cstruct >>= fun cpuid ->
-  req "memory" cert Oid.memory int_of_cstruct >>= fun requested_memory ->
-  opt cert Oid.block_device string_of_cstruct >>= fun block_device ->
-  opt cert Oid.network strings_of_cstruct >>= fun network ->
-  req "vmimage" cert Oid.vmimage image_of_cstruct >>= fun vmimage ->
-  opt cert Oid.argv strings_of_cstruct >>= fun argv ->
-  let network = match network with None -> [] | Some x -> x in
-  Ok { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
-
-let command_of_cert version cert =
-  version_of_cert version cert >>= fun () ->
-  req "command" cert Oid.command command_of_cstruct
-
-let block_device_of_cert version cert =
-  version_of_cert version cert >>= fun () ->
-  req "block-device" cert Oid.block_device string_of_cstruct
-
-let block_size_of_cert version cert =
-  version_of_cert version cert >>= fun () ->
-  req "block-size" cert Oid.memory int_of_cstruct
-
 (* communication protocol *)
 type console_cmd = [
   | `Console_add
@@ -699,3 +556,23 @@ let log_entry =
            (required ~label:"event" log_event))
 
 let log_entry_of_cstruct, log_entry_to_cstruct = projections_of log_entry
+
+type cert_extension = version * wire_command
+
+let cert_extension =
+  Asn.S.(sequence2
+           (required ~label:"version" version)
+           (required ~label:"command" wire_command))
+
+let cert_extension_of_cstruct, cert_extension_to_cstruct =
+  projections_of cert_extension
+
+let wire_command_of_cert version cert =
+  match X509.Extension.unsupported cert oid with
+  | None -> R.error_msgf "albatross OID is not present in certificate (%a)" Asn.OID.pp oid
+  | Some (_, data) ->
+    cert_extension_of_cstruct data >>= fun (v, wire) ->
+    if not (version_eq v version) then
+      R.error_msgf "unexpected version %a (expected %a)" pp_version v pp_version version
+    else
+      Ok wire

src/vmm_asn.mli

@@ -1,76 +1,13 @@
 (* (c) 2017 Hannes Mehnert, all rights reserved *)
 
+open Vmm_core
+
 (** ASN.1 encoding of resources and configuration *)
 
-(** Object Identifiers *)
+(** {1 Object Identifier} *)
 
-module Oid : sig
+(** OID in the Mirage namespace (enterprise arc 1.3.6.1.4.1.49836.43) *)
-
+val oid : Asn.OID.t
-  (** {1 Object identifiers} *)
-
-  (** OIDs in the Mirage namespace (enterprise arc 1.3.6.1.4.1.49836.42) *)
-
-  (** [version] specifies an [INTEGER] describing the version. *)
-  val version : Asn.OID.t
-
-  (** {2 OIDs used in delegation certificates} *)
-
-  (** [vms] is an [INTEGER] denoting the number of virtual machines. *)
-  val vms : Asn.OID.t
-
-  (** [bridges] is a [CHOICE] between [ [0] UTF8STRING], describing an internal
-      bridge, and a [ [1] SEQUENCE] of [UTF8STRING], [IPV4ADDRESS] denoting the first
-      IP to use, [IPV4ADDRESS] denoting the last IP to use, [IPV4ADDRESS]
-      denoting the default gateway, [INTEGER] denoting the netmask. *)
-  val bridges : Asn.OID.t
-
-  (** [block] is an [INTEGER] denoting the size of block storage available for
-      this delegation in MB. *)
-  val block : Asn.OID.t
-
-  (** [cpuids] is a [SEQUENCE OF INTEGER] denoting the CPU identifiers available
-      for this delegate. *)
-  val cpuids : Asn.OID.t
-
-  (** [memory] is an [INTEGER] denoting the amount of available memory, in
-      MB.  Also used in virtual machine certificates. *)
-  val memory : Asn.OID.t
-
-  (** {2 OIDs used in virtual machine certificates} *)
-
-  (** [cpuid] is an [INTEGER] denoting the CPU identifier on which this virtual
-      machine should be executed.  Must be a member of all [cpuids] in the
-      chained delegation certificates. *)
-  val cpuid : Asn.OID.t
-
-  (** [network] is a [SEQUENCE OF UTF8STRING] denoting the bridge devices to
-      hook this virtual machine up to.  Each name must be in the chained
-      delegation certificates. *)
-  val network : Asn.OID.t
-
-  (** [block_device] is a [UTF8STRING] with the name of the block device.  It
-      must exist. *)
-  val block_device : Asn.OID.t
-
-  (** [vmimage] is a [CHOICE] between [ [0] OCTET_STRING] for an hvt amd64
-     image, [ [1] OCTET_STRING] for an hvt arm64 image, and [ [2] OCTET_STRING]
-     for a compressed am64 hvt image. *)
-  val vmimage : Asn.OID.t
-
-  (** [argv] is a [SEQUENCE OF UTF8STRING] denoting the boot parameters passed
-      to the virtual machine image. *)
-  val argv : Asn.OID.t
-
-  (** {2 OID used in administrative certificates} *)
-
-  (** [command] is a [BIT_STRING] denoting the command this certificate. *)
-  val command : Asn.OID.t
-
-
-  (** [crl] is a [OCTET_STRING] denoting the revocation list of the intermediate
-      CA. *)
-  val crl : Asn.OID.t
-end
 
 (** {1 Encoding and decoding functions} *)
 
@@ -83,89 +20,6 @@ val version_eq : version -> version -> bool
 (** [pp_version ppf version] pretty prints [version] onto [ppf]. *)
 val pp_version : version Fmt.t
 
-(** [version_to_cstruct ver] is the DER encoded version. *)
-val version_to_cstruct : version -> Cstruct.t
-
-(** [version_of_cstruct buffer] is either a decoded version of the DER
-    encoding [buffer] or an error. *)
-val version_of_cstruct : Cstruct.t -> (version, [> `Msg of string ]) result
-
-(** [command_to_cstruct perms] is the DER encoded command. *)
-val command_to_cstruct : Vmm_core.command -> Cstruct.t
-
-(** [command_of_cstruct buffer] is either a decoded command of the DER encoded
-   [buffer] or an error. *)
-val command_of_cstruct : Cstruct.t -> (Vmm_core.command, [> `Msg of string ]) result
-
-(** [bridges_to_cstruct bridges] is the DER encoded bridges. *)
-val bridges_to_cstruct : Vmm_core.bridge list -> Cstruct.t
-
-(** [bridges_of_cstruct buffer] is either a decoded bridge list of the DER
-    encoded [buffer] or an error. *)
-val bridges_of_cstruct : Cstruct.t -> (Vmm_core.bridge list, [> `Msg of string ]) result
-
-(** [image_to_cstruct (typ, img)] is the DER encoded image. *)
-val image_to_cstruct : Vmm_core.vmtype * Cstruct.t -> Cstruct.t
-
-(** [image_of_cstruct buffer] is either a decoded image of the DER encoded
-    [buffer] or an error. *)
-val image_of_cstruct : Cstruct.t -> (Vmm_core.vmtype * Cstruct.t, [> `Msg of string ]) result
-
-(** [int_to_cstruct i] is the DER encoded int. *)
-val int_to_cstruct : int -> Cstruct.t
-
-(** [int_of_cstruct buffer] is either a decoded int of the DER encoded [buffer]
-    or an error. *)
-val int_of_cstruct : Cstruct.t -> (int, [> `Msg of string ]) result
-
-(** [ints_to_cstruct xs] is the DER encoded int sequence. *)
-val ints_to_cstruct : int list -> Cstruct.t
-
-(** [ints_of_cstruct buffer] is either a decoded int list of the DER encoded
-    [buffer] or an error. *)
-val ints_of_cstruct : Cstruct.t -> (int list, [> `Msg of string ]) result
-
-(** [string_to_cstruct s] is the DER encoded string. *)
-val string_to_cstruct : string -> Cstruct.t
-
-(** [string_of_cstruct buffer] is either a decoded string of the DER encoded
-    [buffer] or an error. *)
-val string_of_cstruct : Cstruct.t -> (string, [> `Msg of string ]) result
-
-(** [strings_to_cstruct xs] is the DER encoded string sequence. *)
-val strings_to_cstruct : string list -> Cstruct.t
-
-(** [strings_of_cstruct buffer] is either a decoded string list of the DER
-    encoded [buffer] or an error. *)
-val strings_of_cstruct : Cstruct.t -> (string list, [> `Msg of string ]) result
-
-(** {1 Decoding functions} *)
-
-(** [contains_vm cert] is [true] if the certificate contains a virtual machine image. *)
-val contains_vm : X509.t -> bool
-
-(** [contains_crl cert] is [true] if the certificate contains a revocation list. *)
-val contains_crl : X509.t -> bool
-
-(** [vm_of_cert id cert] is either the decoded virtual machine configuration, or an error. *)
-val vm_of_cert : Vmm_core.id -> X509.t -> (Vmm_core.vm_config, [> `Msg of string ]) result
-
-(** [crl_of_cert id cert] is either the decoded revocation list, or an error. *)
-val crl_of_cert : X509.t -> (X509.CRL.c, [> `Msg of string ]) result
-
-(** [policy_of_cert version cert] is either the decoded policy, or an error. *)
-val policy_of_cert : version -> X509.t -> (Vmm_core.policy, [> `Msg of string ]) result
-
-(** [command_of_cert version cert] is either the decoded command, or an error. *)
-val command_of_cert : version -> X509.t -> (Vmm_core.command, [> `Msg of string ]) result
-
-(** [block_device_of_cert version cert] is either the decoded block device, or an error. *)
-val block_device_of_cert : version -> X509.t -> (string, [> `Msg of string ]) result
-
-(** [block_size_of_cert version cert] is either the decoded block size, or an error. *)
-val block_size_of_cert : version -> X509.t -> (int, [> `Msg of string ]) result
-
-open Vmm_core
 type console_cmd = [
   | `Console_add
   | `Console_subscribe
@@ -204,6 +58,8 @@ type wire_command = [
   | `Vm_cmd of vm_cmd
   | `Policy_cmd of policy_cmd ]
 
+val pp_wire_command : wire_command Fmt.t
+
 type header = {
   version : version ;
   sequence : int64 ;
@@ -226,3 +82,10 @@ type log_entry = header * Ptime.t * Log.event
 val log_entry_to_cstruct : log_entry -> Cstruct.t
 
 val log_entry_of_cstruct : Cstruct.t -> (log_entry, [> `Msg of string ]) result
+
+type cert_extension = version * wire_command
+
+val cert_extension_of_cstruct : Cstruct.t -> (cert_extension, [> `Msg of string ]) result
+val cert_extension_to_cstruct : cert_extension -> Cstruct.t
+
+val wire_command_of_cert : version -> X509.t -> (wire_command, [> `Msg of string ]) result

src/vmm_core.ml

@@ -31,37 +31,6 @@ module IS = Set.Make(I)
 module IM = Map.Make(I)
 module IM64 = Map.Make(Int64)
 
-type command =
-  [ `Info | `Create_vm | `Force_create_vm | `Destroy_vm
-  | `Statistics | `Console | `Log | `Crl
-  | `Create_block | `Destroy_block ]
-
-let pp_command ppf cmd =
-  Fmt.string ppf @@ match cmd with
-  | `Info -> "info"
-  | `Create_vm -> "create-vm"
-  | `Force_create_vm -> "force-create-vm"
-  | `Destroy_vm -> "destroy-vm"
-  | `Statistics -> "statistics"
-  | `Console -> "console"
-  | `Log -> "log"
-  | `Crl -> "crl"
-  | `Create_block -> "create-block"
-  | `Destroy_block -> "destroy-block"
-
-let command_of_string = function
-  | x when x = "info" -> Some `Info
-  | x when x = "create-vm" -> Some `Create_vm
-  | x when x = "force-create-vm" -> Some `Force_create_vm
-  | x when x = "destroy-vm" -> Some `Destroy_vm
-  | x when x = "statistics" -> Some `Statistics
-  | x when x = "console" -> Some `Console
-  | x when x = "log" -> Some `Log
-  | x when x = "crl" -> Some `Crl
-  | x when x = "create-block" -> Some `Create_block
-  | x when x = "destroy-block" -> Some `Destroy_block
-  | _ -> None
-
 type vmtype = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ]
 
 let vmtype_to_int = function

src/vmm_core.mli

@@ -18,21 +18,6 @@ module IM64 : sig
   include Map.S with type key = Int64.t
 end
 
-type command =
-    [ `Console
-    | `Create_block
-    | `Create_vm
-    | `Crl
-    | `Destroy_block
-    | `Destroy_vm
-    | `Force_create_vm
-    | `Info
-    | `Log
-    | `Statistics ]
-val pp_command : command Fmt.t
-
-val command_of_string : string -> command option
-
 type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ]
 val vmtype_to_int : vmtype -> int
 val int_to_vmtype : int -> vmtype option

src/vmm_x509.ml

@@ -2,7 +2,7 @@ open Rresult.R.Infix
 
 open Vmm_core
 
-let asn_version = `AV1
+let asn_version = `AV2
 
 (* let check_policy =
      (* get names and static resources *)
@@ -28,26 +28,6 @@ let handle _addr chain =
   (* TODO here: inspect top-level-cert of chain.
      may need to create bridges and/or block device subdirectory (zfs create) *)
   (* let login_hdr, login_ev = Log.hdr name, `Login addr in *)
-  Vmm_asn.command_of_cert asn_version leaf >>= function
+  (* TODO: update policies! *)
-  | `Info -> Ok (name, `Vm_cmd `Vm_info)
+  Vmm_asn.wire_command_of_cert asn_version leaf >>| fun wire ->
-  | `Create_vm ->
+  (name, wire)
-    (* TODO: update acl *)
-    Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config ->
-    (name, `Vm_cmd (`Vm_create vm_config))
-  | `Force_create_vm ->
-    (* TODO: update acl *)
-    Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config ->
-    (name, `Vm_cmd (`Vm_force_create vm_config))
-  | `Destroy_vm -> Ok (name, `Vm_cmd `Vm_destroy)
-  | `Statistics -> Ok (name, `Stats_cmd `Stats_subscribe)
-  | `Console -> Ok (name, `Console_cmd `Console_subscribe)
-  | `Log -> Ok (name, `Log_cmd `Log_subscribe)
-  | `Crl -> assert false
-  | `Create_block -> assert false
-(*    Vmm_asn.block_device_of_cert asn_version leaf >>= fun block_name ->
-    Vmm_asn.block_size_of_cert asn_version leaf >>| fun block_size ->
-      `Create_block (block_name, block_size) *)
-  | `Destroy_block -> assert false
-(*    Vmm_asn.block_device_of_cert asn_version leaf >>| fun block_name ->
-    `Destroy_block block_name
-*)