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

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

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

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

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

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

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
+  (if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then
-     handle_create t prefix chain leaf >>= fun (file, cont) ->
+     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) ],

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

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