From bb61388cfc4b7c3b0ee7ef6501fc6a0cdffdc63f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 16 Jan 2018 01:10:22 +0100 Subject: [PATCH] new permission: force_create a client certificate may either contain `Create or `Force_create permission. If the latter is used (vmm_req_vm --force), and a VM with the same name already exists, this is destroyed (if the dynamic resources without the existing would allow the new one to be deployed) and the new one is started. I had this concrete deployment scenario, where kill ; create takes some minutes since it is 10MB data which needs to be transferred from my laptop to a remote server (me behind dialup). - renamed `Image to `Create - renamed `Destroy_image to `Destroy_vm --- README.md | 11 +++++++++-- provision/vmm_req_vm.ml | 15 ++++++++++----- provision/vmm_sign.ml | 15 ++++++++++++++- src/vmm_asn.ml | 3 ++- src/vmm_core.ml | 16 +++++++++------- src/vmm_engine.ml | 27 +++++++++++++++++++-------- src/vmm_resources.ml | 7 ++++++- src/vmm_wire.ml | 4 ++-- 8 files changed, 71 insertions(+), 27 deletions(-) diff --git a/README.md b/README.md index a491ed2..148afbe 100644 --- a/README.md +++ b/README.md @@ -124,11 +124,18 @@ This produced in the first step two files, `admin.req` and `admin.key`, and in the second step two more files, `dev.db` and `admin.pem`. ``` -DEV> vmm_req_vm hello mirage-skeleton/tutorial/hello/hello.ukvm 512 1 +DEV> vmm_req_vm hello mirage-skeleton/tutorial/hello/hello.ukvm 12 1 DEV> vmm_sign dev.db dev.pem dev.key hello.req ``` -This produced three more files, `hello.{req,key,pem}` and modified `dev.db`. +This generates a private key `hello.key` and a certificate signing request named +`hello.req` including the virtual machine image `hello.ukvm`, which gets 12MB +memory and CPU id 1. The second command used the `dev.key` to sign the signing +request and output a `hello.pem`. + +The flag `--force` can be passed to `vmm_req_vm`. This means: if there already +exists a running virtual machine with the same name, kill it and start the new +one provided in the certificate. To actually deploy anything, the server needs the chain (i.e. the vm certificate and the delegation certificate). Our client needs the main CA certificate to diff --git a/provision/vmm_req_vm.ml b/provision/vmm_req_vm.ml index 605fb45..1a7cc37 100644 --- a/provision/vmm_req_vm.ml +++ b/provision/vmm_req_vm.ml @@ -6,7 +6,7 @@ open Rresult.R.Infix open Vmm_asn -let vm_csr key name image cpu mem args block net = +let vm_csr key name image cpu mem args block net force = let block = match block with | None -> [] | Some x -> [ (false, `Unsupported (Oid.block_device, string_to_cstruct x)) ] @@ -16,25 +16,26 @@ let vm_csr key name image cpu mem args block net = and net = match net with | [] -> [] | xs -> [ (false, `Unsupported (Oid.network, strings_to_cstruct xs)) ] + and cmd = if force then `Force_create else `Create 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_to_cstruct (`Ukvm_amd64, image))) ; - (false, `Unsupported (Oid.permissions, permissions_to_cstruct [ `Image ])) ; + (false, `Unsupported (Oid.permissions, permissions_to_cstruct [ cmd ])) ; ] @ block @ arg @ net and name = [ `CN name ] in X509.CA.request name ~extensions:[`Extensions exts] key -let jump _ name key image mem cpu args block net = +let jump _ name key image mem cpu args block net force = Nocrypto_entropy_unix.initialize () ; match priv_key key name >>= fun key -> (Bos.OS.File.read (Fpath.v image) >>= fun s -> Ok (Cstruct.of_string s)) >>= fun image -> - let csr = vm_csr key name image cpu mem args block net in + let csr = vm_csr key name image cpu mem args block net force 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 @@ -63,8 +64,12 @@ let net = let doc = "Network device" in Arg.(value & opt_all string [] & info [ "net" ] ~doc) +let force = + let doc = "Force creation (destroy VM with same name if it exists)" in + Arg.(value & flag & info [ "force" ] ~doc) + let cmd = - Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net)), + Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force)), Term.info "vmm_req_vm" ~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 8a63eaa..8803ace 100644 --- a/provision/vmm_sign.ml +++ b/provision/vmm_sign.ml @@ -160,7 +160,20 @@ let sign dbname cacert key csr days = | 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 + opt Vmm_asn.Oid.permissions req_exts Vmm_asn.permissions_of_cstruct >>= fun perms -> + Logs.app (fun m -> m "using permission %a" + Fmt.(option ~none:(unit "none") + (list ~sep:(unit ", ") Vmm_core.pp_permission)) perms) ; + let perm = match perms with + | Some [ `Force_create ] -> [ `Force_create ] + | Some [ `Create ] -> [ `Create ] + | _ -> + Logs.warn (fun m -> m "weird permissions (%a), replaced with create" + Fmt.(option ~none:(unit "none") + (list ~sep:(unit ", ") Vmm_core.pp_permission)) perms) ; + [ `Create ] + in + let s_exts = (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct perm) :: s_exts in let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in Ok (exts @ l_exts) | `Delegation -> diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index ae94c15..59ba520 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -40,12 +40,13 @@ let perms : permission list Asn.t = Asn.S.bit_string_flags [ 0, `All ; 1, `Info ; - 2, `Image ; + 2, `Create ; 3, `Block ; 4, `Statistics ; 5, `Console ; 6, `Log ; 7, `Crl ; + 9, `Force_create ; ] open Rresult.R.Infix diff --git a/src/vmm_core.ml b/src/vmm_core.ml index cbb9136..40b0c5e 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -13,32 +13,34 @@ module IS = Set.Make(I) module IM = Map.Make(I) type permission = - [ `All | `Info | `Image | `Block | `Statistics | `Console | `Log | `Crl ] + [ `All | `Info | `Create | `Block | `Statistics | `Console | `Log | `Crl | `Force_create] let pp_permission ppf = function | `All -> Fmt.pf ppf "all" | `Info -> Fmt.pf ppf "info" - | `Image -> Fmt.pf ppf "image" + | `Create -> Fmt.pf ppf "create" | `Block -> Fmt.pf ppf "block" | `Statistics -> Fmt.pf ppf "statistics" | `Console -> Fmt.pf ppf "console" | `Log -> Fmt.pf ppf "log" | `Crl -> Fmt.pf ppf "crl" + | `Force_create -> Fmt.pf ppf "force-create" let permission_of_string = function | x when x = "all" -> Some `All | x when x = "info" -> Some `Info - | x when x = "image" -> Some `Image + | x when x = "create" -> Some `Create | x when x = "block" -> Some `Block | 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 = "force-create" -> Some `Force_create | _ -> None type cmd = [ `Info - | `Destroy_image + | `Destroy_vm | `Create_block | `Destroy_block | `Statistics @@ -49,7 +51,7 @@ type cmd = let pp_cmd ppf = function | `Info -> Fmt.pf ppf "info" - | `Destroy_image -> Fmt.pf ppf "destroy" + | `Destroy_vm -> Fmt.pf ppf "destroy" | `Create_block -> Fmt.pf ppf "create-block" | `Destroy_block -> Fmt.pf ppf "destroy-block" | `Statistics -> Fmt.pf ppf "statistics" @@ -59,7 +61,7 @@ let pp_cmd ppf = function let cmd_of_string = function | x when x = "info" -> Some `Info - | x when x = "destroy" -> Some `Destroy_image + | x when x = "destroy" -> Some `Destroy_vm | x when x = "create-block" -> Some `Create_block | x when x = "destroy-block" -> Some `Destroy_block | x when x = "statistics" -> Some `Statistics @@ -72,7 +74,7 @@ let cmd_allowed permissions cmd = List.mem `All permissions || let perm = match cmd with | `Info -> `Info - | `Destroy_image -> `Image + | `Destroy_vm -> `Create | `Create_block -> `Block | `Destroy_block -> `Block | `Statistics -> `Statistics diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index e33c239..01985d0 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -109,17 +109,13 @@ let handle_disconnect state t = in { state with console_attached ; console_counter ; log_attached }, out -let handle_create t prefix chain cert = +let handle_create t prefix chain cert force = Logs.debug (fun m -> m "starting with vms %a" Vmm_resources.pp t.resources) ; (* convert certificate to vm_config *) Vmm_asn.vm_of_cert prefix cert >>= fun vm_config -> Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ; (* check whether vm with same name is already running *) let full = fullname vm_config in - (if Vmm_resources.exists t.resources full then - Error (`Msg "VM with same name is already running") - else - Ok ()) >>= fun () -> (* get names and static resources *) List.fold_left (fun acc ca -> acc >>= fun acc -> @@ -130,9 +126,23 @@ let handle_create t prefix chain cert = (* check static policies *) Logs.debug (fun m -> m "now checking static policies") ; check_policies vm_config (List.map snd res) >>= fun () -> + (* may retract currently running vm to evaluate force-create! *) + (if force then + match Vmm_resources.find_vm t.resources full with + | None -> Ok (t.resources, None) + | Some vm -> + Vmm_resources.remove t.resources full vm >>= fun r -> Ok (r, Some vm) + else if Vmm_resources.exists t.resources full then + Error (`Msg "VM with same name is already running") + else + Ok (t.resources, None)) >>= fun (resources, vm) -> (* check dynamic usage *) Logs.debug (fun m -> m "now checking dynamic policies") ; - Vmm_resources.check_dynamic t.resources vm_config res >>= fun resource_usage -> + Vmm_resources.check_dynamic resources vm_config res >>= fun () -> + (* need to kill *) + (match vm with + | Some vm -> Vmm_commands.destroy vm + | None -> ()) ; (* prepare VM: save VM image to disk, create fifo, ... *) Vmm_commands.prepare vm_config >>= fun (tmpfile, taps) -> Logs.debug (fun m -> m "prepared vm %a" Fpath.pp tmpfile) ; @@ -378,8 +388,9 @@ let handle_initial t s addr chain ca = let t, out = log t (login_hdr, login_ev) in let initial_out = `Tls (s, Vmm_wire.Client.log login_hdr login_ev t.client_version) in Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms -> - (if List.mem `Image perms && Vmm_asn.contains_vm leaf then - handle_create t prefix chain leaf >>= fun (file, cont) -> + (if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then + let force = List.mem `Force_create perms in + handle_create t prefix chain leaf force >>= fun (file, cont) -> let cons = Vmm_wire.Console.add t.console_counter t.console_version file in Ok ({ t with console_counter = succ t.console_counter }, [ `Raw (t.console_socket, cons) ], diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index fd8ae6d..298d851 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -110,7 +110,12 @@ let insert m name v = let remove m name vm = let rec del m = function | [] -> Error (`Msg "should not happen: empty labels in remove") - | [l] -> Ok (String.Map.remove l m) + | [l] -> + (match String.Map.find l m with + | None -> Ok m + | Some (Leaf vm') when vm'.pid = vm.pid -> Ok (String.Map.remove l m) + | Some (Leaf _) -> Ok m + | Some (Subtree _) -> Ok (String.Map.remove l m)) (* TODO: not sure about this case *) | l::ls -> match String.Map.find l m with | None -> Error (`Msg "should not happen: found nothing in remove while still had some labels") | Some (Subtree (r, m')) -> diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml index 8701d0c..651402f 100644 --- a/src/vmm_wire.ml +++ b/src/vmm_wire.ml @@ -576,7 +576,7 @@ end module Client = struct let cmd_to_int = function | `Info -> 0 - | `Destroy_image -> 1 + | `Destroy_vm -> 1 | `Create_block -> 2 | `Destroy_block -> 3 | `Statistics -> 4 @@ -585,7 +585,7 @@ module Client = struct | `Log -> 7 and cmd_of_int = function | 0 -> Some `Info - | 1 -> Some `Destroy_image + | 1 -> Some `Destroy_vm | 2 -> Some `Create_block | 3 -> Some `Destroy_block | 4 -> Some `Statistics