albatross/provision/vmm_sign.ml

286 lines
13 KiB
OCaml
Raw Normal View History

2017-05-26 14:30:34 +00:00
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Vmm_provision
open Rresult.R.Infix
open Astring
let has oid exts =
List.exists (function (_, `Unsupported (x, _)) when x = oid -> true | _ -> false) exts
let req oid exts f =
try
let ext = List.find (function (_, `Unsupported (x, _)) when x = oid -> true | _ -> false) exts in
match ext with
| (_, `Unsupported (_, y)) -> f y
| _ -> Error (`Msg "not found")
with Not_found -> Error (`Msg "not found")
let opt oid exts f =
try
let ext = List.find (function (_, `Unsupported (x, _)) when x = oid -> true | _ -> false) exts in
match ext with
| (_, `Unsupported (_, y)) -> f y >>= fun x -> Ok (Some x)
| _ -> Ok None
with Not_found -> Ok None
let sign dbname cacert key csr days =
let ri = X509.CA.info csr in
Logs.app (fun m -> m "signing certificate with subject %s"
(X509.distinguished_name_to_string ri.X509.CA.subject)) ;
let issuer = X509.subject cacert in
(* TODO: handle version mismatch of the delegation cert specially here *)
let delegation = match Vmm_asn.delegation_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_delegation) delegation) ;
let req_exts =
match
List.find (function `Extensions _ -> true | _ -> false) ri.X509.CA.extensions
with
| exception Not_found -> []
| `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 `Permission
| _ -> 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 delegation 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 delegation 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 delegation 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 delegation 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
let s_exts = (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct [ `Image ]) :: 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 delegation 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 delegation 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 delegation 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 delegation 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 delegation 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 ())
| `Permission ->
req Vmm_asn.Oid.permissions req_exts Vmm_asn.permissions_of_cstruct >>= fun perms ->
Logs.app (fun m -> m "an interactive certificate with permissions %a"
Fmt.(list ~sep:(unit ", ") Vmm_core.pp_permission) perms) ;
let s_exts = (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct perms) :: s_exts in
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 () ;
match
Bos.OS.File.read (Fpath.v cacert) >>= fun cacert ->
let cacert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string cacert) in
Bos.OS.File.read (Fpath.v cakey) >>= fun pk ->
let cakey = X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string pk) in
Bos.OS.File.read (Fpath.v csrname) >>= fun enc ->
let csr = X509.Encoding.Pem.Certificate_signing_request.of_pem_cstruct1 (Cstruct.of_string enc) in
sign (Fpath.v db) cacert cakey csr days
with
| Ok () -> `Ok ()
| Error (`Msg e) -> `Error (false, e)
open Cmdliner
let csr =
let doc = "signing request" in
Arg.(required & pos 3 (some file) None & info [] ~doc)
let days =
let doc = "Number of days" in
Arg.(value & opt int 1 & info [ "days" ] ~doc)
let key =
let doc = "Private key" in
Arg.(required & pos 2 (some file) None & info [] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ db $ cacert $ key $ csr $ days)),
Term.info "vmm_sign" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1