block device support

app/vmm_cli.ml

@@ -120,9 +120,21 @@ let vm_name =
   let doc = "Name virtual machine." in
   Arg.(required & pos 0 (some vm_c) None & info [] ~doc ~docv:"VM")
 
+let block_name =
+  let doc = "Name of block device." in
+  Arg.(required & pos 0 (some vm_c) None & info [] ~doc ~docv:"BLOCK")
+
 let block_size =
+  let doc = "Block size in MB." in
+  Arg.(required & pos 1 (some int) None & info [] ~doc ~docv:"SIZE")
+
+let opt_block_name =
+  let doc = "Name of block device." in
+  Arg.(value & opt vm_c [] & info [ "name" ] ~doc)
+
+let opt_block_size =
   let doc = "Block storage to allow in MB" in
-  Arg.(value & opt (some int) None & info [ "block" ] ~doc)
+  Arg.(value & opt (some int) None & info [ "size" ] ~doc)
 
 let mem =
   let doc = "Memory to allow in MB" in

app/vmm_stats_stubs.c

@@ -40,11 +40,11 @@ CAMLprim value vmmanage_sysctl_rusage (value pid_r) {
   if (error < 0)
     uerror("sysctl", Nothing);
 
+  ru = p.ki_rusage;
   if (ru.ru_utime.tv_usec < 0 || ru.ru_utime.tv_usec > 999999999 ||
       ru.ru_stime.tv_usec < 0 || ru.ru_stime.tv_usec > 999999999)
     uerror("sysctl", Nothing);
 
-  ru = p.ki_rusage;
   utime = caml_alloc(2, 0);
   Store_field (utime, 0, Val64(ru.ru_utime.tv_sec));
   Store_field (utime, 1, Val_int(ru.ru_utime.tv_usec));

app/vmmc_bistro.ml

@@ -93,6 +93,15 @@ let stats _ endp cert key ca name =
 let event_log _ endp cert key ca name since =
   jump endp cert key ca name (`Log_cmd (`Log_subscribe since))
 
+let block_info _ endp cert key ca block_name =
+  jump endp cert key ca block_name (`Block_cmd `Block_info)
+
+let block_create _ endp cert key ca block_name block_size =
+  jump endp cert key ca block_name (`Block_cmd (`Block_add block_size))
+
+let block_destroy _ endp cert key ca block_name =
+  jump endp cert key ca block_name (`Block_cmd `Block_remove)
+
 let help _ _ man_format cmds = function
   | None -> `Help (`Pager, None)
   | Some t when List.mem t cmds -> `Help (man_format, Some t)
@@ -159,7 +168,7 @@ let add_policy_cmd =
     [`S "DESCRIPTION";
      `P "Adds a policy."]
   in
-  Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ vms $ mem $ cpus $ block_size $ bridge)),
+  Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ vms $ mem $ cpus $ opt_block_size $ bridge)),
   Term.info "add_policy" ~doc ~man
 
 let create_cmd =
@@ -198,6 +207,33 @@ let log_cmd =
   Term.(ret (const event_log $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ since)),
   Term.info "log" ~doc ~man
 
+let block_info_cmd =
+  let doc = "Information about block devices" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Block device information."]
+  in
+  Term.(ret (const block_info $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_block_name)),
+  Term.info "block" ~doc ~man
+
+let block_create_cmd =
+  let doc = "Create a block device" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Creation of a block device."]
+  in
+  Term.(ret (const block_create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ block_name $ block_size)),
+  Term.info "create_block" ~doc ~man
+
+let block_destroy_cmd =
+  let doc = "Destroys a block device" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Destroys a block device."]
+  in
+  Term.(ret (const block_destroy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ block_name)),
+  Term.info "destroy_block" ~doc ~man
+
 let help_cmd =
   let topic =
     let doc = "The topic to get help on. `topics' lists the topics." in
@@ -220,7 +256,11 @@ let default_cmd =
   Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ Term.pure None)),
   Term.info "vmmc_bistro" ~version:"%%VERSION_NUM%%" ~doc ~man
 
-let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ]
+let cmds = [ help_cmd ; info_cmd ;
+             policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
+             destroy_cmd ; create_cmd ;
+             block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
+             console_cmd ; stats_cmd ; log_cmd ]
 
 let () =
   match Term.eval_choice default_cmd cmds

app/vmmc_local.ml

@@ -72,6 +72,15 @@ let stats _ opt_socket name =
 let event_log _ opt_socket name since =
   jump opt_socket name (`Log_cmd (`Log_subscribe since))
 
+let block_info _ opt_socket block_name =
+  jump opt_socket block_name (`Block_cmd `Block_info)
+
+let block_create _ opt_socket block_name block_size =
+  jump opt_socket block_name (`Block_cmd (`Block_add block_size))
+
+let block_destroy _ opt_socket block_name =
+  jump opt_socket block_name (`Block_cmd `Block_remove)
+
 let help _ _ man_format cmds = function
   | None -> `Help (`Pager, None)
   | Some t when List.mem t cmds -> `Help (man_format, Some t)
@@ -126,7 +135,7 @@ let add_policy_cmd =
     [`S "DESCRIPTION";
      `P "Adds a policy."]
   in
-  Term.(ret (const add_policy $ setup_log $ socket $ vm_name $ vms $ mem $ cpus $ block_size $ bridge)),
+  Term.(ret (const add_policy $ setup_log $ socket $ vm_name $ vms $ mem $ cpus $ opt_block_size $ bridge)),
   Term.info "add_policy" ~doc ~man
 
 let create_cmd =
@@ -165,6 +174,33 @@ let log_cmd =
   Term.(ret (const event_log $ setup_log $ socket $ opt_vm_name $ since)),
   Term.info "log" ~doc ~man
 
+let block_info_cmd =
+  let doc = "Information about block devices" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Block device information."]
+  in
+  Term.(ret (const block_info $ setup_log $ socket $ opt_block_name)),
+  Term.info "block" ~doc ~man
+
+let block_create_cmd =
+  let doc = "Create a block device" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Creation of a block device."]
+  in
+  Term.(ret (const block_create $ setup_log $ socket $ block_name $ block_size)),
+  Term.info "create_block" ~doc ~man
+
+let block_destroy_cmd =
+  let doc = "Destroys a block device" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Destroys a block device."]
+  in
+  Term.(ret (const block_destroy $ setup_log $ socket $ block_name)),
+  Term.info "destroy_block" ~doc ~man
+
 let help_cmd =
   let topic =
     let doc = "The topic to get help on. `topics' lists the topics." in
@@ -187,7 +223,11 @@ let default_cmd =
   Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)),
   Term.info "vmmc_local" ~version:"%%VERSION_NUM%%" ~doc ~man
 
-let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ]
+let cmds = [ help_cmd ; info_cmd ;
+             policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
+             destroy_cmd ; create_cmd ;
+             block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
+             console_cmd ; stats_cmd ; log_cmd ]
 
 let () =
   match Term.eval_choice default_cmd cmds

app/vmmp_request.ml

@@ -54,6 +54,15 @@ let stats _ name =
 let event_log _ name since =
   jump name (`Log_cmd (`Log_subscribe since))
 
+let block_info _ block_name =
+  jump block_name (`Block_cmd `Block_info)
+
+let block_create _ block_name block_size =
+  jump block_name (`Block_cmd (`Block_add block_size))
+
+let block_destroy _ block_name =
+  jump block_name (`Block_cmd `Block_remove)
+
 let help _ man_format cmds = function
   | None -> `Help (`Pager, None)
   | Some t when List.mem t cmds -> `Help (man_format, Some t)
@@ -104,7 +113,7 @@ let add_policy_cmd =
     [`S "DESCRIPTION";
      `P "Adds a policy."]
   in
-  Term.(ret (const add_policy $ setup_log $ vm_name $ vms $ mem $ cpus $ block_size $ bridge)),
+  Term.(ret (const add_policy $ setup_log $ vm_name $ vms $ mem $ cpus $ opt_block_size $ bridge)),
   Term.info "add_policy" ~doc ~man
 
 let create_cmd =
@@ -143,6 +152,33 @@ let log_cmd =
   Term.(ret (const event_log $ setup_log $ opt_vm_name $ since)),
   Term.info "log" ~doc ~man
 
+let block_info_cmd =
+  let doc = "Information about block devices" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Block device information."]
+  in
+  Term.(ret (const block_info $ setup_log $ opt_block_name)),
+  Term.info "block" ~doc ~man
+
+let block_create_cmd =
+  let doc = "Create a block device" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Creation of a block device."]
+  in
+  Term.(ret (const block_create $ setup_log $ block_name $ block_size)),
+  Term.info "create_block" ~doc ~man
+
+let block_destroy_cmd =
+  let doc = "Destroys a block device" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Destroys a block device."]
+  in
+  Term.(ret (const block_destroy $ setup_log $ block_name)),
+  Term.info "destroy_block" ~doc ~man
+
 let help_cmd =
   let topic =
     let doc = "The topic to get help on. `topics' lists the topics." in
@@ -165,7 +201,11 @@ let default_cmd =
   Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)),
   Term.info "vmmc_local" ~version:"%%VERSION_NUM%%" ~doc ~man
 
-let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ]
+let cmds = [ help_cmd ; info_cmd ;
+             policy_cmd ; remove_policy_cmd ; add_policy_cmd ;
+             destroy_cmd ; create_cmd ;
+             block_info_cmd ; block_create_cmd ; block_destroy_cmd ;
+             console_cmd ; stats_cmd ; log_cmd ]
 
 let () =
   match Term.eval_choice default_cmd cmds

src/vmm_asn.ml

@@ -305,6 +305,22 @@ let policy_cmd =
            (explicit 1 policy)
            (explicit 2 null))
 
+let block_cmd =
+  let f = function
+    | `C1 () -> `Block_info
+    | `C2 size -> `Block_add size
+    | `C3 () -> `Block_remove
+  and g = function
+    | `Block_info -> `C1 ()
+    | `Block_add size -> `C2 size
+    | `Block_remove -> `C3 ()
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice3
+           (explicit 0 null)
+           (explicit 1 int)
+           (explicit 2 null))
+
 let version =
   let f data = match data with
     | 2 -> `AV2
@@ -321,20 +337,23 @@ let wire_command =
     | `C3 log -> `Log_cmd log
     | `C4 vm -> `Vm_cmd vm
     | `C5 policy -> `Policy_cmd policy
+    | `C6 block -> `Block_cmd block
   and g = function
     | `Console_cmd c -> `C1 c
     | `Stats_cmd c -> `C2 c
     | `Log_cmd c -> `C3 c
     | `Vm_cmd c -> `C4 c
     | `Policy_cmd c -> `C5 c
+    | `Block_cmd c -> `C6 c
   in
   Asn.S.map f g @@
-  Asn.S.(choice5
+  Asn.S.(choice6
            (explicit 0 console_cmd)
            (explicit 1 stats_cmd)
            (explicit 2 log_cmd)
            (explicit 3 vm_cmd)
-           (explicit 4 policy_cmd))
+           (explicit 4 policy_cmd)
+           (explicit 5 block_cmd))
 
 let data =
   let f = function
@@ -378,14 +397,16 @@ let success =
     | `C2 str -> `String str
     | `C3 policies -> `Policies policies
     | `C4 vms -> `Vms vms
+    | `C5 blocks -> `Blocks blocks
   and g = function
     | `Empty -> `C1 ()
     | `String s -> `C2 s
     | `Policies ps -> `C3 ps
     | `Vms vms -> `C4 vms
+    | `Blocks blocks -> `C5 blocks
   in
   Asn.S.map f g @@
-  Asn.S.(choice4
+  Asn.S.(choice5
            (explicit 0 null)
            (explicit 1 utf8_string)
            (explicit 2 (sequence_of
@@ -395,7 +416,12 @@ let success =
            (explicit 3 (sequence_of
                           (sequence2
                              (required ~label:"name" (sequence_of utf8_string))
-                             (required ~label:"vm_config" vm_config)))))
+                             (required ~label:"vm_config" vm_config))))
+           (explicit 4 (sequence_of
+                          (sequence3
+                             (required ~label:"name" (sequence_of utf8_string))
+                             (required ~label:"size" int)
+                             (required ~label:"active" bool)))))
 
 let payload =
   let f = function

src/vmm_commands.ml

@@ -55,8 +55,8 @@ type vm_cmd = [
 
 let pp_vm_cmd ppf = function
   | `Vm_info -> Fmt.string ppf "vm info"
-  | `Vm_create vm_config -> Fmt.pf ppf "create %a" pp_vm_config vm_config
+  | `Vm_create vm_config -> Fmt.pf ppf "vm create %a" pp_vm_config vm_config
-  | `Vm_force_create vm_config -> Fmt.pf ppf "force create %a" pp_vm_config vm_config
+  | `Vm_force_create vm_config -> Fmt.pf ppf "vm force create %a" pp_vm_config vm_config
   | `Vm_destroy -> Fmt.string ppf "vm destroy"
 
 type policy_cmd = [
@@ -67,15 +67,27 @@ type policy_cmd = [
 
 let pp_policy_cmd ppf = function
   | `Policy_info -> Fmt.string ppf "policy info"
-  | `Policy_add policy -> Fmt.pf ppf "add policy: %a" pp_policy policy
+  | `Policy_add policy -> Fmt.pf ppf "policy add %a" pp_policy policy
   | `Policy_remove -> Fmt.string ppf "policy remove"
 
+type block_cmd = [
+  | `Block_info
+  | `Block_add of int
+  | `Block_remove
+]
+
+let pp_block_cmd ppf = function
+  | `Block_info -> Fmt.string ppf "block info"
+  | `Block_add size -> Fmt.pf ppf "block add %d" size
+  | `Block_remove -> Fmt.string ppf "block remove"
+
 type t = [
     | `Console_cmd of console_cmd
     | `Stats_cmd of stats_cmd
     | `Log_cmd of log_cmd
     | `Vm_cmd of vm_cmd
     | `Policy_cmd of policy_cmd
+    | `Block_cmd of block_cmd
   ]
 
 let pp ppf = function
@@ -84,6 +96,7 @@ let pp ppf = function
   | `Log_cmd l -> pp_log_cmd ppf l
   | `Vm_cmd v -> pp_vm_cmd ppf v
   | `Policy_cmd p -> pp_policy_cmd ppf p
+  | `Block_cmd b -> pp_block_cmd ppf b
 
 type data = [
   | `Console_data of Ptime.t * string
@@ -103,13 +116,23 @@ type header = {
   id : id ;
 }
 
-type success = [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ]
+type success = [
+  | `Empty
+  | `String of string
+  | `Policies of (id * policy) list
+  | `Vms of (id * vm_config) list
+  | `Blocks of (id * int * bool) list
+]
+
+let pp_block ppf (id, size, active) =
+  Fmt.pf ppf "block %a size %d MB active %B" pp_id id size active
 
 let pp_success ppf = function
   | `Empty -> Fmt.string ppf "success"
   | `String data -> Fmt.pf ppf "success: %s" data
   | `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_policy)) ppf ps
   | `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_vm_config)) ppf vms
+  | `Blocks blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks
 
 type wire = header * [
     | `Command of t
@@ -128,6 +151,7 @@ let pp_wire ppf (header, data) =
 let endpoint = function
   | `Vm_cmd _ -> `Vmmd, `End
   | `Policy_cmd _ -> `Vmmd, `End
+  | `Block_cmd _ -> `Vmmd, `End
   | `Stats_cmd _ -> `Stats, `Read
   | `Console_cmd _ -> `Console, `Read
   | `Log_cmd _ -> `Log, `Read

src/vmm_commands.mli

@@ -39,12 +39,20 @@ type policy_cmd = [
   | `Policy_remove
 ]
 
+type block_cmd = [
+  | `Block_info
+  | `Block_add of int
+  | `Block_remove
+]
+
 type t = [
   | `Console_cmd of console_cmd
   | `Stats_cmd of stats_cmd
   | `Log_cmd of log_cmd
   | `Vm_cmd of vm_cmd
-  | `Policy_cmd of policy_cmd ]
+  | `Policy_cmd of policy_cmd
+  | `Block_cmd of block_cmd
+]
 
 val pp : t Fmt.t
 
@@ -67,6 +75,7 @@ type success = [
   | `String of string
   | `Policies of (id * policy) list
   | `Vms of (id * vm_config) list
+  | `Blocks of (id * int * bool) list
 ]
 
 type wire = header * [

src/vmm_core.ml

@@ -1,4 +1,4 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
 
 open Astring
 
@@ -6,6 +6,7 @@ open Rresult.R.Infix
 
 let tmpdir = Fpath.(v "/var" / "run" / "albatross")
 let dbdir = Fpath.(v "/var" / "db" / "albatross")
+let blockdir = Fpath.(dbdir / "block")
 
 type service = [ `Console | `Log | `Stats | `Vmmd ]
 
@@ -60,6 +61,8 @@ let domain id = match List.rev id with
   | _::prefix -> List.rev prefix
   | [] -> []
 
+let block_name vm_name dev = List.rev (dev :: List.rev (domain vm_name))
+
 let pp_id ppf ids =
   Fmt.(pf ppf "(%d)%a" (List.length ids) (list ~sep:(unit ".") string) ids)
 
@@ -194,8 +197,9 @@ type vm = {
 }
 
 let pp_vm ppf vm =
-  Fmt.pf ppf "pid %d@ taps %a cmdline %a"
+  Fmt.pf ppf "pid %d@ taps %a (block %a) cmdline %a"
     vm.pid Fmt.(list ~sep:(unit ", ") string) vm.taps
+    Fmt.(option ~none:(unit "no") string) vm.config.block_device
     Bos.Cmd.pp vm.cmd
 
 let translate_tap vm tap =

src/vmm_core.mli

@@ -2,6 +2,7 @@
 
 val tmpdir : Fpath.t
 val dbdir : Fpath.t
+val blockdir : Fpath.t
 
 type service = [ `Console | `Log | `Stats | `Vmmd ]
 
@@ -20,12 +21,13 @@ module IM : sig
 end
 
 type id = string list
-val string_of_id : string list -> string
+val string_of_id : id -> string
-val id_of_string : string -> string list
+val id_of_string : string -> id
-val drop_super : super:string list -> sub:string list -> string list option
+val drop_super : super:id -> sub:id -> id option
-val is_sub_id : super:string list -> sub:string list -> bool
+val is_sub_id : super:id -> sub:id -> bool
-val domain : 'a list -> 'a list
+val domain : id -> id
 val pp_id : id Fmt.t
+val block_name : id -> string -> id
 
 type bridge =
   [ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int

src/vmm_resources.ml

@@ -5,9 +5,10 @@ open Vmm_core
 type res_entry = {
   running_vms : int ;
   used_memory : int ;
+  used_blockspace : int ;
 }
 
-let empty_res = { running_vms = 0 ; used_memory = 0 }
+let empty_res = { running_vms = 0 ; used_memory = 0 ; used_blockspace = 0  }
 
 let check_resource (policy : policy) (vm : vm_config) (res : res_entry) =
   succ res.running_vms <= policy.vms &&
@@ -15,41 +16,47 @@ let check_resource (policy : policy) (vm : vm_config) (res : res_entry) =
   vm_matches_res policy vm
 
 let check_resource_policy (policy : policy) (res : res_entry) =
-  res.running_vms <= policy.vms && res.used_memory <= policy.memory
+  res.running_vms <= policy.vms && res.used_memory <= policy.memory &&
-
+  match policy.block with
-let add (vm : vm) (res : res_entry) =
+  | None -> res.used_blockspace = 0
-  { running_vms = succ res.running_vms ;
+  | Some mb -> res.used_blockspace <= mb
-    used_memory = vm.config.requested_memory + res.used_memory }
 
 type entry =
   | Vm of vm
+  | Block of int * bool
   | Policy of policy
 
+let pp_entry id ppf = function
+  | Vm vm -> Fmt.pf ppf "vm %a: %a@." pp_id id pp_vm_config vm.config
+  | Policy p -> Fmt.pf ppf "policy %a: %a@." pp_id id pp_policy p
+  | Block (size, used) -> Fmt.pf ppf "block device %a: %dMB (used %B)@." pp_id id size used
+
 type t = entry Vmm_trie.t
 
 let pp ppf t =
   Vmm_trie.fold [] t
-    (fun id ele () -> match ele with
+    (fun id ele () -> pp_entry id ppf ele) ()
-       | Vm vm -> Fmt.pf ppf "vm %a: %a@." pp_id id pp_vm_config vm.config
-       | Policy p -> Fmt.pf ppf "policy %a: %a@." pp_id id pp_policy p)
-       ()
 
 let empty = Vmm_trie.empty
 
-let fold t name f g acc =
+let fold t name f g h acc =
   Vmm_trie.fold name t (fun prefix entry acc ->
       match entry with
       | Vm vm -> f prefix vm acc
-      | Policy p -> g prefix p acc) acc
+      | Policy p -> g prefix p acc
+      | Block (size, used) -> h prefix size used acc) acc
 
 (* we should hide this type and confirm the following invariant:
    - in case Vm, there are no siblings *)
 
 let resource_usage t name =
-  Vmm_trie.fold name t (fun _ entry acc ->
+  Vmm_trie.fold name t (fun _ entry res ->
       match entry with
-      | Policy _ -> acc
+      | Policy _ -> res
-      | Vm vm -> add vm acc)
+      | Block (size, _) -> { res with used_blockspace = res.used_blockspace + size }
+      | Vm vm ->
+        { res with running_vms = succ res.running_vms ;
+                   used_memory = vm.config.requested_memory + res.used_memory })
     empty_res
 
 let find_vm t name = match Vmm_trie.find name t with
@@ -60,42 +67,61 @@ let find_policy t name = match Vmm_trie.find name t with
   | Some (Policy p) -> Some p
   | _ -> None
 
+let find_block t name = match Vmm_trie.find name t with
+  | Some (Block (size, active)) -> Some (size, active)
+  | _ -> None
+
+let set_block_usage active t name vm =
+  match vm.config.block_device with
+  | None -> Ok t
+  | Some block ->
+    let block_name = block_name name block in
+    match find_block t block_name with
+    | None -> Error (`Msg "unknown block device")
+    | Some (size, curr) ->
+      if curr = active then
+        Error (`Msg "failed because the requested block usage was already set")
+      else
+        Ok (fst (Vmm_trie.insert block_name (Block (size, active)) t))
+
 let remove_vm t name =  match find_vm t name with
   | None -> Error (`Msg "unknown vm")
-  | Some _ -> Ok (Vmm_trie.remove name t)
+  | Some vm -> set_block_usage false (Vmm_trie.remove name t) name vm
 
 let remove_policy t name = match find_policy t name with
   | None -> Error (`Msg "unknown policy")
   | Some _ -> Ok (Vmm_trie.remove name t)
 
+let remove_block t name = match find_block t name with
+  | None -> Error (`Msg "unknown block")
+  | Some _ -> Ok (Vmm_trie.remove name t)
+
 let check_vm_policy t name vm =
   let dom = domain name in
   let res = resource_usage t dom in
   match Vmm_trie.find dom t with
   | None -> Ok true
-  | Some (Vm vm) ->
-    Logs.err (fun m -> m "id %a, expected policy, got vm %a" pp_id dom pp_vm vm) ;
-    Rresult.R.error_msgf "expected policy, found vm for %a" pp_id dom
   | Some (Policy p) -> Ok (check_resource p vm res)
+  | Some x ->
+    Logs.err (fun m -> m "id %a, expected policy, got %a" pp_id dom (pp_entry dom) x) ;
+    Rresult.R.error_msgf "expected policy for %a" pp_id dom
 
 let insert_vm t name vm =
   let open Rresult.R.Infix in
   check_vm_policy t name vm.config >>= function
-  | true ->
-    begin match Vmm_trie.insert name (Vm vm) t with
-      | t', None -> Ok t'
-      | _, Some _ -> Error (`Msg "vm already exists")
-    end
   | false -> Error (`Msg "resource policy mismatch")
+  | true -> match Vmm_trie.insert name (Vm vm) t with
+    | t', None -> set_block_usage true t' name vm
+    | _, Some _ -> Error (`Msg "vm already exists")
 
 let check_policy_above t name p =
   let above = Vmm_trie.collect name t in
   List.for_all (fun (id, node) -> match node with
-      | Vm vm ->
+      | Policy p' -> is_sub ~super:p' ~sub:p
-        Logs.err (fun m -> m "found vm %a, expecting a policy at %a"
+      | x ->
-                     pp_vm vm pp_id id) ;
+        Logs.err (fun m -> m "expected policy, found %a"
-        false
+                     (pp_entry id) x) ;
-      | Policy p' -> is_sub ~super:p' ~sub:p)
+        false)
     above
 
 let check_policy_below t name p =
@@ -123,3 +149,23 @@ let insert_policy t name p =
   | false, _, _ -> Error (`Msg "policy violates other policies above")
   | _, None, _ -> Error (`Msg "policy violates other policies below")
   | _, _, false -> Error (`Msg "more resources used than policy would allow")
+
+let check_block_policy t name size =
+  match find_block t name with
+  | Some _ -> Error (`Msg "block device with same name already exists")
+  | None ->
+    let dom = domain name in
+    let res = resource_usage t dom in
+    let res' = { res with used_blockspace = res.used_blockspace + size } in
+    match Vmm_trie.find dom t with
+    | None -> Ok true
+    | Some (Policy p) -> Ok (check_resource_policy p res')
+    | Some x ->
+      Logs.err (fun m -> m "id %a, expected policy, got %a" pp_id dom (pp_entry dom) x) ;
+      Rresult.R.error_msgf "expected policy for %a" pp_id dom
+
+let insert_block t name size =
+  let open Rresult.R.Infix in
+  check_block_policy t name size >>= function
+  | false -> Error (`Msg "resource policy mismatch")
+  | true -> Ok (fst (Vmm_trie.insert name (Block (size, false)) t))

src/vmm_resources.mli

@@ -23,11 +23,14 @@ val find_vm : t -> Vmm_core.id -> Vmm_core.vm option
 (** [find_policy t id] is either [Some policy] or [None]. *)
 val find_policy : t -> Vmm_core.id -> Vmm_core.policy option
 
-(** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be
+(** [find_block t id] is either [Some (size, active)] or [None]. *)
+val find_block : t -> Vmm_core.id -> (int * bool) option
+
+(** [check_vm_policy t id vm] checks whether [vm] under [id] in [t] would be
     allowed under the current policies. *)
 val check_vm_policy : t -> Vmm_core.id -> Vmm_core.vm_config -> (bool, [> `Msg of string ]) result
 
-(** [insert_vm t vm] inserts [vm] under [id] in [t], and returns the new [t] or
+(** [insert_vm t id vm] inserts [vm] under [id] in [t], and returns the new [t] or
     an error. *)
 val insert_vm : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
 
@@ -35,16 +38,28 @@ val insert_vm : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) resul
    the new [t] or an error. *)
 val insert_policy : t -> Vmm_core.id -> Vmm_core.policy -> (t, [> `Msg of string]) result
 
+(** [check_block_policy t id size] checks whether [size] under [id] in [t] would be
+    allowed under the current policies. *)
+val check_block_policy : t -> Vmm_core.id -> int -> (bool, [> `Msg of string ]) result
+
+(** [insert_block t id size] inserts [size] under [id] in [t], and returns the new [t] or
+    an error. *)
+val insert_block : t -> Vmm_core.id -> int -> (t, [> `Msg of string]) result
+
 (** [remove_vm t id] removes vm [id] from [t]. *)
 val remove_vm : t -> Vmm_core.id -> (t, [> `Msg of string ]) result
 
 (** [remove_policy t id] removes policy [id] from [t]. *)
 val remove_policy : t -> Vmm_core.id -> (t, [> `Msg of string ]) result
 
-(** [fold t id f g acc] folds [f] and [g] below [id] over [t]. *)
+(** [remove_block t id] removes block [id] from [t]. *)
+val remove_block : t -> Vmm_core.id -> (t, [> `Msg of string ]) result
+
+(** [fold t id f_vm f_policy f_block acc] folds [f_vm], [f_policy] and [f_block] below [id] over [t]. *)
 val fold : t -> Vmm_core.id ->
   (Vmm_core.id -> Vmm_core.vm -> 'a -> 'a) ->
-  (Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) -> 'a -> 'a
+  (Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) ->
+  (Vmm_core.id -> int -> bool -> 'a -> 'a) -> 'a -> 'a
 
 (** [pp] is a pretty printer for [t]. *)
 val pp : t Fmt.t

src/vmm_unix.ml

@@ -145,17 +145,24 @@ let cpuset cpu =
     Ok ([ "taskset" ; "-c" ; cpustring ])
   | x -> Error (`Msg ("unsupported operating system " ^ x))
 
-let exec name vm taps =
+let block_device_name name = Fpath.(blockdir / string_of_id name)
-  let net = List.map (fun t -> "--net=" ^ t) taps in
+
-  let argv = match vm.argv with None -> [] | Some xs -> xs in
+let exec name vm taps block =
-  (match taps with
+  (match taps, block with
-   | [] -> Ok Fpath.(dbdir / "solo5-hvt.none")
+   | [], None -> Ok "none"
-   | [_] -> Ok Fpath.(dbdir / "solo5-hvt.net")
+   | [_], None -> Ok "net"
-   | _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin ->
+   | [], Some _ -> Ok "block"
+   | [_], Some _ -> Ok "block-net"
+   | _, _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin ->
+  let net = List.map (fun t -> "--net=" ^ t) taps
+  and block = match block with None -> [] | Some dev -> [ "--disk=" ^ Fpath.to_string (block_device_name dev) ]
+  and argv = match vm.argv with None -> [] | Some xs -> xs
+  and mem = "--mem=" ^ string_of_int vm.requested_memory
+  in
   cpuset vm.cpuid >>= fun cpuset ->
-  let mem = "--mem=" ^ string_of_int vm.requested_memory in
   let cmd =
-    Bos.Cmd.(of_list cpuset % p bin % mem %% of_list net %
+    Bos.Cmd.(of_list cpuset % p Fpath.(dbdir / "solo5-hvt" + bin) % mem %%
+             of_list net %% of_list block %
              "--" % p (image_file name) %% of_list argv)
   in
   let line = Bos.Cmd.to_list cmd in
@@ -178,3 +185,47 @@ let exec name vm taps =
     R.error_msgf "cmd %a exits: %a" Bos.Cmd.pp cmd pp_unix_error e
 
 let destroy vm = Unix.kill vm.pid 15 (* 15 is SIGTERM *)
+
+let bytes_of_mb size =
+  let res = size lsl 20 in
+  if res > size then
+    Ok res
+  else
+    Error (`Msg "overflow while computing bytes")
+
+let create_block name size =
+  let block_name = block_device_name name in
+  Bos.OS.File.exists block_name >>= function
+  | true -> Error (`Msg "file already exists")
+  | false ->
+    bytes_of_mb size >>= fun size' ->
+    Bos.OS.File.truncate block_name size'
+
+let destroy_block name =
+  Bos.OS.File.delete (block_device_name name)
+
+let mb_of_bytes size =
+  if size = 0 || size land 0xFFFFF <> 0 then
+    Error (`Msg "size is either 0 or not MB aligned")
+  else
+    Ok (size lsr 20)
+
+let find_block_devices () =
+  Bos.OS.Dir.contents ~rel:true blockdir >>= fun files ->
+  List.fold_left (fun acc file ->
+      acc >>= fun acc ->
+      let path = Fpath.append blockdir file in
+      Bos.OS.File.exists path >>= function
+      | false ->
+        Logs.warn (fun m -> m "file %a doesn't exist, but was listed" Fpath.pp path) ;
+        Ok acc
+      | true ->
+        Bos.OS.Path.stat path >>= fun stats ->
+        match mb_of_bytes stats.Unix.st_size with
+        | Error (`Msg msg) ->
+          Logs.warn (fun m -> m "file %a error: %s" Fpath.pp path msg) ;
+          Ok acc
+        | Ok size ->
+          let id = id_of_string (Fpath.to_string file) in
+          Ok ((id, size) :: acc))
+    (Ok []) files

src/vmm_unix.mli

@@ -8,8 +8,14 @@ val prepare : id -> vm_config -> (string list, [> R.msg ]) result
 
 val shutdown : id -> vm -> (unit, [> R.msg ]) result
 
-val exec : id -> vm_config -> string list -> (vm, [> R.msg ]) result
+val exec : id -> vm_config -> string list -> string list option -> (vm, [> R.msg ]) result
 
 val destroy : vm -> unit
 
 val close_no_err : Unix.file_descr -> unit
+
+val create_block : id -> int -> (unit, [> R.msg ]) result
+
+val destroy_block : id -> (unit, [> R.msg ]) result
+
+val find_block_devices : unit -> ((id * int) list, [> R.msg ]) result

src/vmm_vmmd.ml

@@ -16,14 +16,30 @@ type 'a t = {
   tasks : 'a String.Map.t ;
 }
 
-let init wire_version = {
+let init wire_version =
+  let t = {
     wire_version ;
     console_counter = 1L ;
     stats_counter = 1L ;
     log_counter = 1L ;
     resources = Vmm_resources.empty ;
     tasks = String.Map.empty ;
-}
+  } in
+  match Vmm_unix.find_block_devices () with
+  | Error (`Msg msg) ->
+    Logs.warn (fun m -> m "couldn't find block devices %s" msg) ;
+    t
+  | Ok devs ->
+    let resources =
+      List.fold_left (fun r (id, size) ->
+          match Vmm_resources.insert_block r id size with
+          | Error (`Msg msg) ->
+            Logs.err (fun m -> m "couldn't insert block device %a (%dM): %s" pp_id id size msg) ;
+            r
+          | Ok r -> r)
+        t.resources devs
+    in
+    { t with resources }
 
 type service_out = [
   | `Stat of Vmm_commands.wire
@@ -40,15 +56,23 @@ let log t id event =
   Logs.debug (fun m -> m "log %a" Log.pp data) ;
   ({ t with log_counter }, `Log (header, `Data (`Log_data data)))
 
-let handle_create t hdr vm_config =
+let handle_create t reply name vm_config =
-  let name = hdr.Vmm_commands.id in
   (match Vmm_resources.find_vm t.resources name with
    | Some _ -> Error (`Msg "VM with same name is already running")
    | None -> Ok ()) >>= fun () ->
   Logs.debug (fun m -> m "now checking resource policies") ;
   (Vmm_resources.check_vm_policy t.resources name vm_config >>= function
-    | false -> Error (`Msg "resource policies don't allow this")
+    | false -> Error (`Msg "resource policies don't allow creation of this VM")
     | true -> Ok ()) >>= fun () ->
+  (match vm_config.block_device with
+   | None -> Ok None
+   | Some dev ->
+     let block_device_name = block_name name dev in
+     Logs.debug (fun m -> m "looking for block device %a" pp_id block_device_name) ;
+     match Vmm_resources.find_block t.resources block_device_name with
+     | Some (_, false) -> Ok (Some block_device_name)
+     | Some (_, true) -> Error (`Msg "block device is busy")
+     | None -> Error (`Msg "cannot find block device") ) >>= fun block_device ->
   (* prepare VM: save VM image to disk, create fifo, ... *)
   Vmm_unix.prepare name vm_config >>= fun taps ->
   Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
@@ -60,14 +84,13 @@ let handle_create t hdr vm_config =
       [ `Cons cons_out ],
       `Create (fun t task ->
           (* actually execute the vm *)
-          Vmm_unix.exec name vm_config taps >>= fun vm ->
+          Vmm_unix.exec name vm_config taps block_device >>= fun vm ->
           Logs.debug (fun m -> m "exec()ed vm") ;
           Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
           let tasks = String.Map.add (string_of_id name) task t.tasks in
           let t = { t with resources ; tasks } in
           let t, out = log t name (`Vm_start (name, vm.pid, vm.taps, None)) in
-          let data = `Success (`String "created VM") in
+          Ok (t, [ reply (`String "created VM") ; out ], name, vm)))
-          Ok (t, [ `Data (hdr, data) ; out ], name, vm)))
 
 let setup_stats t name vm =
   let stat_out = `Stats_add (vm.pid, vm.taps) in
@@ -92,21 +115,9 @@ let handle_shutdown t name vm r =
   in
   (t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ])
 
-let handle_command t (header, payload) =
+let handle_policy_cmd t reply id = function
-  let msg_to_err = function
-    | Ok x -> x
-    | Error (`Msg msg) ->
-      Logs.err (fun m -> m "error while processing command: %s" msg) ;
-      (t, [ `Data (header, `Failure msg) ], `End)
-  in
-  let reply x = `Data (header, `Success x) in
-  msg_to_err (
-    let id = header.Vmm_commands.id in
-    match payload with
-    | `Command (`Policy_cmd pc) ->
-      begin match pc with
   | `Policy_remove ->
-          Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_commands.id) ;
+    Logs.debug (fun m -> m "remove policy %a" pp_id id) ;
     Vmm_resources.remove_policy t.resources id >>= fun resources ->
     Ok ({ t with resources }, [ reply (`String "removed policy") ], `End)
   | `Policy_add policy ->
@@ -121,12 +132,12 @@ let handle_command t (header, payload) =
       Vmm_resources.insert_policy t.resources id policy >>= fun resources ->
       Ok ({ t with resources }, [ reply (`String "added policy") ], `Loop)
   | `Policy_info ->
-          begin
     Logs.debug (fun m -> m "policy %a" pp_id id) ;
     let policies =
       Vmm_resources.fold t.resources id
         (fun _ _ policies -> policies)
         (fun prefix policy policies-> (prefix, policy) :: policies)
+        (fun _ _ _ policies -> policies)
         []
     in
     match policies with
@@ -135,16 +146,15 @@ let handle_command t (header, payload) =
       Error (`Msg "policy: not found")
     | _ ->
       Ok (t, [ reply (`Policies policies) ], `End)
-          end
+
-      end
+let handle_vm_cmd t reply id msg_to_err = function
-    | `Command (`Vm_cmd vc) ->
-      begin match vc with
   | `Vm_info ->
     Logs.debug (fun m -> m "info %a" pp_id id) ;
     let vms =
       Vmm_resources.fold t.resources id
         (fun id vm vms -> (id, vm.config) :: vms)
         (fun _ _ vms-> vms)
+        (fun _ _ _ vms -> vms)
         []
     in
     begin match vms with
@@ -154,8 +164,7 @@ let handle_command t (header, payload) =
       | _ ->
         Ok (t, [ reply (`Vms vms) ], `End)
     end
-        | `Vm_create vm_config ->
+  | `Vm_create vm_config -> handle_create t reply id vm_config
-          handle_create t header vm_config
   | `Vm_force_create vm_config ->
     begin
       let resources =
@@ -166,20 +175,20 @@ let handle_command t (header, payload) =
       Vmm_resources.check_vm_policy resources id vm_config >>= function
       | false -> Error (`Msg "wouldn't match policy")
       | true -> match Vmm_resources.find_vm t.resources id with
-              | None -> handle_create t header vm_config
+        | None -> handle_create t reply id vm_config
         | Some vm ->
           Vmm_unix.destroy vm ;
           let id_str = string_of_id id in
           match String.Map.find_opt id_str t.tasks with
-                | None -> handle_create t header vm_config
+          | None -> handle_create t reply id vm_config
           | Some task ->
             let tasks = String.Map.remove id_str t.tasks in
             let t = { t with tasks } in
             Ok (t, [], `Wait_and_create
-                        (task, fun t -> msg_to_err @@ handle_create t header vm_config))
+                  (task, fun t -> msg_to_err @@ handle_create t reply id vm_config))
     end
   | `Vm_destroy ->
-          begin match Vmm_resources.find_vm t.resources id with
+    match Vmm_resources.find_vm t.resources id with
     | Some vm ->
       Vmm_unix.destroy vm ;
       let id_str = string_of_id id in
@@ -192,8 +201,61 @@ let handle_command t (header, payload) =
       let tasks = String.Map.remove id_str t.tasks in
       Ok ({ t with tasks }, out, next)
     | None -> Error (`Msg "destroy: not found")
+
+let handle_block_cmd t reply id = function
+  | `Block_remove ->
+    Logs.debug (fun m -> m "removing block %a" pp_id id) ;
+    begin match Vmm_resources.find_block t.resources id with
+      | None -> Error (`Msg "remove block: not found")
+      | Some (_, true) -> Error (`Msg "remove block: is in use")
+      | Some (_, false) ->
+        Vmm_unix.destroy_block id >>= fun () ->
+        Vmm_resources.remove_block t.resources id >>= fun resources ->
+        Ok ({ t with resources }, [ reply (`String "removed block") ], `End)
     end
+  | `Block_add size ->
+    begin
+      Logs.debug (fun m -> m "insert block %a: %dMB" pp_id id size) ;
+      match Vmm_resources.find_block t.resources id with
+      | Some _ -> Error (`Msg "block device with same name already exists")
+      | None ->
+        Vmm_resources.check_block_policy t.resources id size >>= function
+        | false -> Error (`Msg "adding block device would violate policy")
+        | true ->
+          Vmm_unix.create_block id size >>= fun () ->
+          Vmm_resources.insert_block t.resources id size >>= fun resources ->
+          Ok ({ t with resources }, [ reply (`String "added block device") ], `Loop)
     end
+  | `Block_info ->
+    Logs.debug (fun m -> m "block %a" pp_id id) ;
+    let blocks =
+      Vmm_resources.fold t.resources id
+        (fun _ _ blocks -> blocks)
+        (fun _ _ blocks-> blocks)
+        (fun prefix size active blocks -> (prefix, size, active) :: blocks)
+        []
+    in
+    match blocks with
+    | [] ->
+      Logs.debug (fun m -> m "block: couldn't find %a" pp_id id) ;
+      Error (`Msg "block: not found")
+    | _ ->
+      Ok (t, [ reply (`Blocks blocks) ], `End)
+
+let handle_command t (header, payload) =
+  let msg_to_err = function
+    | Ok x -> x
+    | Error (`Msg msg) ->
+      Logs.err (fun m -> m "error while processing command: %s" msg) ;
+      (t, [ `Data (header, `Failure msg) ], `End)
+  and reply x = `Data (header, `Success x)
+  and id = header.Vmm_commands.id
+  in
+  msg_to_err (
+    match payload with
+    | `Command (`Policy_cmd pc) -> handle_policy_cmd t reply id pc
+    | `Command (`Vm_cmd vc) -> handle_vm_cmd t reply id msg_to_err vc
+    | `Command (`Block_cmd bc) -> handle_block_cmd t reply id bc
     | _ ->
       Logs.err (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, payload)) ;
       Error (`Msg "unknown command"))