reynir/albatross
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

reuse commands from Vmm_asn.wire_commands for certificates

Browse source
This commit is contained in:
Hannes Mehnert 2018-10-23 20:45:06 +02:00
parent d6c87bacde
commit f5ce2d8826
12 changed files with 79 additions and 788 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
pkg/pkg.ml
View file

@ -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" ;

2
provision/vmm_provision.ml
View file

@ -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 ();

62
provision/vmm_req_command.ml
View file

@ -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

21
provision/vmm_req_delegation.ml
View file

@ -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

36
provision/vmm_req_vm.ml
View file

@ -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

98
provision/vmm_revoke.ml
View file

@ -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

242
provision/vmm_sign.ml
View file

@ -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 () ;

165
src/vmm_asn.ml
View file

@ -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

165
src/vmm_asn.mli
View file

@ -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

31
src/vmm_core.ml
View file

@ -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

15
src/vmm_core.mli
View file

@ -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

28
src/vmm_x509.ml
View file

@ -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)