From f5ce2d88263f2ac44ec257edb281beebaf055de9 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 20:45:06 +0200 Subject: [PATCH] reuse commands from Vmm_asn.wire_commands for certificates --- pkg/pkg.ml | 2 - provision/vmm_provision.ml | 2 +- provision/vmm_req_command.ml | 62 -------- provision/vmm_req_delegation.ml | 21 ++- provision/vmm_req_vm.ml | 36 ++--- provision/vmm_revoke.ml | 98 ------------- provision/vmm_sign.ml | 242 +++----------------------------- src/vmm_asn.ml | 165 +++------------------- src/vmm_asn.mli | 165 ++-------------------- src/vmm_core.ml | 31 ---- src/vmm_core.mli | 15 -- src/vmm_x509.ml | 28 +--- 12 files changed, 79 insertions(+), 788 deletions(-) delete mode 100644 provision/vmm_req_command.ml delete mode 100644 provision/vmm_revoke.ml diff --git a/pkg/pkg.ml b/pkg/pkg.ml index 42012cc..0d66ebe 100644 --- a/pkg/pkg.ml +++ b/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" ; diff --git a/provision/vmm_provision.ml b/provision/vmm_provision.ml index b8a2e98..100ad6a 100644 --- a/provision/vmm_provision.ml +++ b/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 (); diff --git a/provision/vmm_req_command.ml b/provision/vmm_req_command.ml deleted file mode 100644 index a57d3ea..0000000 --- a/provision/vmm_req_command.ml +++ /dev/null @@ -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 diff --git a/provision/vmm_req_delegation.ml b/provision/vmm_req_delegation.ml index 0c5eb96..dcdd32e 100644 --- a/provision/vmm_req_delegation.ml +++ b/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 block = match block with - | None -> [] - | Some x -> [ (false, `Unsupported (Oid.block, int_to_cstruct x)) ] - and bridge = match bridges with - | [] -> [] - | xs -> [ (false, `Unsupported (Oid.bridges, bridges_to_cstruct xs)) ] +let subca_csr key name cpus memory vms block bridges = + let cpuids = Vmm_core.IS.of_list cpus + and bridges = List.fold_left (fun acc b -> match b with + | `Internal name -> String.Map.add name b acc + | `External (name, _, _, _, _) -> String.Map.add name b acc) + String.Map.empty bridges 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.cpuids, ints_to_cstruct cpus)) ; - (false, `Unsupported (Oid.memory, int_to_cstruct mem)) ; - (false, `Unsupported (Oid.vms, int_to_cstruct vms)) ; - ] @ block @ bridge + [ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, cmd))) ] and name = [ `CN name ] in X509.CA.request name ~extensions:[`Extensions exts] key diff --git a/provision/vmm_req_vm.ml b/provision/vmm_req_vm.ml index 5e96c89..f5cde5f 100644 --- a/provision/vmm_req_vm.ml +++ b/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 block = match block with - | None -> [] - | Some x -> [ (false, `Unsupported (Oid.block_device, string_to_cstruct x)) ] - and arg = match args with - | [] -> [] - | xs -> [ (false, `Unsupported (Oid.argv, strings_to_cstruct xs)) ] - and net = match net with - | [] -> [] - | xs -> [ (false, `Unsupported (Oid.network, strings_to_cstruct xs)) ] - and cmd = if force then `Force_create_vm else `Create_vm +let vm_csr key name image cpuid requested_memory argv block_device network force compression = + let vm_config = + let vmimage = match compression with + | 0 -> `Hvt_amd64, image + | level -> + let img = Vmm_compress.compress ~level (Cstruct.to_string image) in + `Hvt_amd64_compressed, Cstruct.of_string img + and argv = match argv with [] -> None | xs -> Some xs + in + Vmm_core.{ cpuid ; requested_memory ; block_device ; network ; argv ; vmimage } in - let image = match compression with - | 0 -> image_to_cstruct (`Hvt_amd64, image) - | 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 + let cmd = if force then `Vm_force_create vm_config else `Vm_create vm_config in + let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, `Vm_cmd cmd))) ] and name = [ `CN name ] in X509.CA.request name ~extensions:[`Extensions exts] key diff --git a/provision/vmm_revoke.ml b/provision/vmm_revoke.ml deleted file mode 100644 index 84a8e78..0000000 --- a/provision/vmm_revoke.ml +++ /dev/null @@ -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 diff --git a/provision/vmm_sign.ml b/provision/vmm_sign.ml index f7bb51a..eb5b605 100644 --- a/provision/vmm_sign.ml +++ b/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 - | 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) ; + (* TODO: check delegation! *) 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 -> - (if Vmm_asn.version_eq v asn_version then - Ok () - else - Error (`Msg "unknown version in request")) >>= fun () -> - let s_exts = [ (Vmm_asn.Oid.version, Vmm_asn.version_to_cstruct v) ] in - let get_int () = - let id = read_line () in - (try Ok (int_of_string id) with - | Failure _ -> Error (`Msg "couldn't parse integer")) - in - (match has Vmm_asn.Oid.vmimage req_exts, has Vmm_asn.Oid.vms req_exts with - | true, false -> Ok `Vm - | false, true -> Ok `Delegation - | false, false -> Ok `Command - | _ -> Error (`Msg "cannot categorise signing request")) >>= (function - | `Vm -> - 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) + match + List.filter (function + | (_, `Unsupported (oid, _)) when Asn.OID.equal oid Vmm_asn.oid -> true + | _ -> false) + req_exts + with + | [ (_, `Unsupported (_, v)) as ext ] -> + Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) -> + (if Vmm_asn.version_eq version asn_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_asn.pp_wire_command cmd) ; + Ok (ext :: l_exts) >>= fun extensions -> + sign ~dbname extensions issuer key csr (Duration.of_day days) + | _ -> Error (`Msg "none or multiple albatross extensions found") let jump _ db cacert cakey csrname days = Nocrypto_entropy_unix.initialize () ; diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index dc53d72..d056521 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -5,53 +5,7 @@ open Vmm_core open Rresult open Astring -module Oid = struct - 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) +let oid = Asn.OID.(base 1 3 <| 6 <| 1 <| 4 <| 1 <| 49836 <| 43) 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 diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 03f28df..28e14e4 100644 --- a/src/vmm_asn.mli +++ b/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 - - (** {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 +(** OID in the Mirage namespace (enterprise arc 1.3.6.1.4.1.49836.43) *) +val oid : Asn.OID.t (** {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 diff --git a/src/vmm_core.ml b/src/vmm_core.ml index f27a928..41a5212 100644 --- a/src/vmm_core.ml +++ b/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 diff --git a/src/vmm_core.mli b/src/vmm_core.mli index fa9c71c..3706744 100644 --- a/src/vmm_core.mli +++ b/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 diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml index 74b2e8a..4b99e5a 100644 --- a/src/vmm_x509.ml +++ b/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 - | `Info -> Ok (name, `Vm_cmd `Vm_info) - | `Create_vm -> - (* 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 -*) + (* TODO: update policies! *) + Vmm_asn.wire_command_of_cert asn_version leaf >>| fun wire -> + (name, wire)