move Vm to submodule

app/vmm_cli.ml

@@ -27,7 +27,7 @@ let create_vm force image cpuid requested_memory argv block_device network compr
       `Hvt_amd64_compressed, Cstruct.of_string img
   and argv = match argv with [] -> None | xs -> Some xs
   in
-  let vm_config = { cpuid ; requested_memory ; block_device ; network ; argv ; vmimage } in
+  let vm_config = Vm.{ cpuid ; requested_memory ; block_device ; network ; argv ; vmimage } in
   if force then `Vm_force_create vm_config else `Vm_create vm_config
 
 let policy vms memory cpus block bridges =

app/vmmd.ml

@@ -32,7 +32,7 @@ let create process cont =
     state := state'' ;
     s := { !s with vm_created = succ !s.vm_created } ;
     Lwt.async (fun () ->
-        Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r ->
+        Vmm_lwt.wait_and_clear vm.Vmm_core.Vm.pid vm.Vmm_core.Vm.stdout >>= fun r ->
         let state', out' = Vmm_vmmd.handle_shutdown !state name vm r in
         s := { !s with vm_destroyed = succ !s.vm_destroyed } ;
         state := state' ;

src/vmm_asn.ml

@@ -265,10 +265,10 @@ let log_cmd =
 let vm_config =
   let f (cpuid, requested_memory, block_device, network, vmimage, argv) =
     let network = match network with None -> [] | Some xs -> xs in
-    { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
+    Vm.{ cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
   and g vm =
-    let network = match vm.network with [] -> None | xs -> Some xs in
+    let network = match vm.Vm.network with [] -> None | xs -> Some xs in
-    (vm.cpuid, vm.requested_memory, vm.block_device, network, vm.vmimage, vm.argv)
+    (vm.Vm.cpuid, vm.Vm.requested_memory, vm.Vm.block_device, network, vm.Vm.vmimage, vm.Vm.argv)
   in
   Asn.S.map f g @@
   Asn.S.(sequence6

src/vmm_commands.ml

@@ -48,15 +48,15 @@ let pp_log_cmd ppf = function
 
 type vm_cmd = [
   | `Vm_info
-  | `Vm_create of vm_config
+  | `Vm_create of Vm.config
-  | `Vm_force_create of vm_config
+  | `Vm_force_create of Vm.config
   | `Vm_destroy
 ]
 
 let pp_vm_cmd ppf = function
   | `Vm_info -> Fmt.string ppf "vm info"
-  | `Vm_create vm_config -> Fmt.pf ppf "vm create %a" pp_vm_config vm_config
+  | `Vm_create vm_config -> Fmt.pf ppf "vm create %a" Vm.pp_config vm_config
-  | `Vm_force_create vm_config -> Fmt.pf ppf "vm force create %a" pp_vm_config vm_config
+  | `Vm_force_create vm_config -> Fmt.pf ppf "vm force create %a" Vm.pp_config vm_config
   | `Vm_destroy -> Fmt.string ppf "vm destroy"
 
 type policy_cmd = [
@@ -120,7 +120,7 @@ type success = [
   | `Empty
   | `String of string
   | `Policies of (Name.t * Policy.t) list
-  | `Vms of (Name.t * vm_config) list
+  | `Vms of (Name.t * Vm.config) list
   | `Blocks of (Name.t * int * bool) list
 ]
 
@@ -131,7 +131,7 @@ 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 ": ") Name.pp Policy.pp)) ppf ps
-  | `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp pp_vm_config)) ppf vms
+  | `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp Vm.pp_config)) ppf vms
   | `Blocks blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks
 
 type wire = header * [

src/vmm_commands.mli

@@ -28,8 +28,8 @@ type log_cmd = [
 
 type vm_cmd = [
   | `Vm_info
-  | `Vm_create of vm_config
+  | `Vm_create of Vm.config
-  | `Vm_force_create of vm_config
+  | `Vm_force_create of Vm.config
   | `Vm_destroy
 ]
 
@@ -74,7 +74,7 @@ type success = [
   | `Empty
   | `String of string
   | `Policies of (Name.t * Policy.t) list
-  | `Vms of (Name.t * vm_config) list
+  | `Vms of (Name.t * Vm.config) list
   | `Blocks of (Name.t * int * bool) list
 ]
 

src/vmm_core.ml

@@ -30,13 +30,6 @@ end
 module IS = Set.Make(I)
 module IM = Map.Make(I)
 
-type vmtype = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ]
-
-let pp_vmtype ppf = function
-  | `Hvt_amd64 -> Fmt.pf ppf "hvt-amd64"
-  | `Hvt_amd64_compressed -> Fmt.pf ppf "hvt-amd64-compressed"
-  | `Hvt_arm64 -> Fmt.pf ppf "hvt-arm64"
-
 module Name = struct
   type t = string list
 
@@ -201,7 +194,15 @@ module Policy = struct
     sub_bridges super.bridges sub.bridges && sub_block super.block sub.block
 end
 
-type vm_config = {
+module Vm = struct
+  type vmtype = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ]
+
+  let pp_vmtype ppf = function
+    | `Hvt_amd64 -> Fmt.pf ppf "hvt-amd64"
+    | `Hvt_amd64_compressed -> Fmt.pf ppf "hvt-amd64-compressed"
+    | `Hvt_arm64 -> Fmt.pf ppf "hvt-arm64"
+
+  type config = {
     cpuid : int ;
     requested_memory : int ;
     block_device : string option ;
@@ -214,7 +215,7 @@ let pp_image ppf (typ, blob) =
     let l = Cstruct.len blob in
     Fmt.pf ppf "%a: %d bytes" pp_vmtype typ l
 
-let pp_vm_config ppf (vm : vm_config) =
+  let pp_config ppf (vm : config) =
     Fmt.pf ppf "cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a"
       vm.cpuid vm.requested_memory
       Fmt.(option ~none:(unit "no") string) vm.block_device
@@ -226,10 +227,10 @@ let good_bridge idxs nets =
     (* TODO: uniqueness of n -- it should be an ordered set? *)
     List.for_all (fun n -> String.Map.mem n nets) idxs
 
-let vm_matches_res (res : Policy.t) (vm : vm_config)  =
+  let vm_matches_res (res : Policy.t) (vm : config)  =
     res.Policy.vms >= 1 && IS.mem vm.cpuid res.Policy.cpuids &&
-  vm.requested_memory <= res.memory &&
+    vm.requested_memory <= res.Policy.memory &&
-  good_bridge vm.network res.bridges
+    good_bridge vm.network res.Policy.bridges
 
   let check_policies vm res =
     let rec climb = function
@@ -242,24 +243,20 @@ let check_policies vm res =
     climb res >>= fun res ->
     if vm_matches_res res vm then Ok () else Error (`Msg "VM does not match policy")
 
-type vm = {
+  type t = {
-  config : vm_config ;
+    config : config ;
     cmd : Bos.Cmd.t ;
     pid : int ;
     taps : string list ;
     stdout : Unix.file_descr (* ringbuffer thingy *)
   }
 
-let pp_vm ppf vm =
+  let pp ppf vm =
     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
-
+end
-let translate_tap vm tap =
-  match List.filter (fun (t, _) -> tap = t) (List.combine vm.taps vm.config.network) with
-  | [ (_, b) ] -> Some b
-  | _ -> None
 
 module Stats = struct
   type rusage = {

src/vmm_core.mli

@@ -62,10 +62,11 @@ module Policy : sig
   val is_sub : super:t -> sub:t -> bool
 end
 
+module Vm : sig
   type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ]
   val pp_vmtype : vmtype Fmt.t
 
-type vm_config = {
+  type config = {
     cpuid : int;
     requested_memory : int;
     block_device : string option;
@@ -76,24 +77,24 @@ type vm_config = {
 
   val pp_image : (vmtype * Cstruct.t) Fmt.t
 
-val pp_vm_config : vm_config Fmt.t
+  val pp_config : config Fmt.t
   val good_bridge : string list -> 'a Astring.String.map -> bool
 
-val vm_matches_res : Policy.t -> vm_config -> bool
+  val vm_matches_res : Policy.t -> config -> bool
 
   val check_policies :
-  vm_config -> Policy.t list -> (unit, [> `Msg of string ]) Result.result
+    config -> Policy.t list -> (unit, [> `Msg of string ]) Result.result
 
-type vm = {
+  type t = {
-  config : vm_config;
+    config : config;
     cmd : Bos.Cmd.t;
     pid : int;
     taps : string list;
     stdout : Unix.file_descr;
   }
 
-val pp_vm : vm Fmt.t
+  val pp : t Fmt.t
-val translate_tap : vm -> string -> string option
+end
 
 module Stats : sig
   type rusage = {

src/vmm_resources.ml

@@ -10,10 +10,10 @@ type res_entry = {
 
 let empty_res = { running_vms = 0 ; used_memory = 0 ; used_blockspace = 0  }
 
-let check_resource (p : Policy.t) (vm : vm_config) (res : res_entry) =
+let check_resource (p : Policy.t) (vm : Vm.config) (res : res_entry) =
   succ res.running_vms <= p.Policy.vms &&
-  res.used_memory + vm.requested_memory <= p.Policy.memory &&
+  res.used_memory + vm.Vm.requested_memory <= p.Policy.memory &&
-  vm_matches_res p vm
+  Vm.vm_matches_res p vm
 
 let check_resource_policy (p : Policy.t) (res : res_entry) =
   res.running_vms <= p.Policy.vms && res.used_memory <= p.Policy.memory &&
@@ -22,12 +22,12 @@ let check_resource_policy (p : Policy.t) (res : res_entry) =
   | Some mb -> res.used_blockspace <= mb
 
 type entry =
-  | Vm of vm
+  | Vm of Vm.t
   | Block of int * bool
   | Policy of Policy.t
 
 let pp_entry id ppf = function
-  | Vm vm -> Fmt.pf ppf "vm %a: %a@." Name.pp id pp_vm_config vm.config
+  | Vm vm -> Fmt.pf ppf "vm %a: %a@." Name.pp id Vm.pp_config vm.Vm.config
   | Policy p -> Fmt.pf ppf "policy %a: %a@." Name.pp id Policy.pp p
   | Block (size, used) -> Fmt.pf ppf "block device %a: %dMB (used %B)@." Name.pp id size used
 
@@ -56,7 +56,7 @@ let resource_usage t name =
       | 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 })
+                   used_memory = vm.Vm.config.Vm.requested_memory + res.used_memory })
     empty_res
 
 let find_vm t name = match Vmm_trie.find name t with
@@ -72,7 +72,7 @@ let find_block t name = match Vmm_trie.find name t with
   | _ -> None
 
 let set_block_usage active t name vm =
-  match vm.config.block_device with
+  match vm.Vm.config.Vm.block_device with
   | None -> Ok t
   | Some block ->
     let block_name = Name.block_name name block in
@@ -108,7 +108,7 @@ let check_vm_policy t name vm =
 
 let insert_vm t name vm =
   let open Rresult.R.Infix in
-  check_vm_policy t name vm.config >>= function
+  check_vm_policy t name vm.Vm.config >>= function
   | 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
@@ -135,8 +135,8 @@ let check_policy_below t name p =
           then Some p'
           else None
         | Vm vm, Some p ->
-          let cfg = vm.config in
+          let cfg = vm.Vm.config in
-          if IS.mem cfg.cpuid p.cpuids && good_bridge cfg.network p.bridges
+          if IS.mem cfg.Vm.cpuid p.Policy.cpuids && Vm.good_bridge cfg.Vm.network p.Policy.bridges
           then Some p
           else None
         | _, res -> res)

src/vmm_resources.mli

@@ -18,7 +18,7 @@ type t
 val empty : t
 
 (** [find_vm t id] is either [Some vm] or [None]. *)
-val find_vm : t -> Vmm_core.Name.t -> Vmm_core.vm option
+val find_vm : t -> Vmm_core.Name.t -> Vmm_core.Vm.t option
 
 (** [find_policy t Name.t] is either [Some policy] or [None]. *)
 val find_policy : t -> Vmm_core.Name.t -> Vmm_core.Policy.t option
@@ -28,11 +28,11 @@ val find_block : t -> Vmm_core.Name.t -> (int * bool) option
 
 (** [check_vm_policy t Name.t vm] checks whether [vm] under [Name.t] in [t] would be
     allowed under the current policies. *)
-val check_vm_policy : t -> Vmm_core.Name.t -> Vmm_core.vm_config -> (bool, [> `Msg of string ]) result
+val check_vm_policy : t -> Vmm_core.Name.t -> Vmm_core.Vm.config -> (bool, [> `Msg of string ]) result
 
 (** [insert_vm t Name.t vm] inserts [vm] under [Name.t] in [t], and returns the new [t] or
     an error. *)
-val insert_vm : t -> Vmm_core.Name.t -> Vmm_core.vm -> (t, [> `Msg of string]) result
+val insert_vm : t -> Vmm_core.Name.t -> Vmm_core.Vm.t -> (t, [> `Msg of string]) result
 
 (** [insert_policy t Name.t policy] inserts [policy] under [Name.t] in [t], and returns
    the new [t] or an error. *)
@@ -57,7 +57,7 @@ val remove_block : t -> Vmm_core.Name.t -> (t, [> `Msg of string ]) result
 
 (** [fold t Name.t f_vm f_policy f_block acc] folds [f_vm], [f_policy] and [f_block] below [Name.t] over [t]. *)
 val fold : t -> Vmm_core.Name.t ->
-  (Vmm_core.Name.t -> Vmm_core.vm -> 'a -> 'a) ->
+  (Vmm_core.Name.t -> Vmm_core.Vm.t -> 'a -> 'a) ->
   (Vmm_core.Name.t -> Vmm_core.Policy.t -> 'a -> 'a) ->
   (Vmm_core.Name.t -> int -> bool -> 'a -> 'a) -> 'a -> 'a
 

src/vmm_unix.ml

@@ -107,7 +107,7 @@ let destroy_tap tapname =
   | x -> Error (`Msg ("unsupported operating system " ^ x))
 
 let prepare name vm =
-  (match vm.vmimage with
+  (match vm.Vm.vmimage with
    | `Hvt_amd64, blob -> Ok blob
    | `Hvt_amd64_compressed, blob ->
      begin match Vmm_compress.uncompress (Cstruct.to_string blob) with
@@ -128,7 +128,7 @@ let prepare name vm =
       acc >>= fun acc ->
       create_tap b >>= fun tap ->
       Ok (tap :: acc))
-    (Ok []) vm.network >>= fun taps ->
+    (Ok []) vm.Vm.network >>= fun taps ->
   Bos.OS.File.write (Name.image_file name) (Cstruct.to_string image) >>= fun () ->
   Ok (List.rev taps)
 
@@ -136,7 +136,7 @@ let shutdown name vm =
   (* same order as prepare! *)
   Bos.OS.File.delete (Name.image_file name) >>= fun () ->
   Bos.OS.File.delete (Name.fifo_file name) >>= fun () ->
-  List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps
+  List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.Vm.taps
 
 let cpuset cpu =
   Lazy.force (uname ()) >>= fun (sys, _) ->
@@ -157,10 +157,10 @@ let exec name vm taps block =
    | _, _ -> 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_file dev) ]
-  and argv = match vm.argv with None -> [] | Some xs -> xs
+  and argv = match vm.Vm.argv with None -> [] | Some xs -> xs
-  and mem = "--mem=" ^ string_of_int vm.requested_memory
+  and mem = "--mem=" ^ string_of_int vm.Vm.requested_memory
   in
-  cpuset vm.cpuid >>= fun cpuset ->
+  cpuset vm.Vm.cpuid >>= fun cpuset ->
   let cmd =
     Bos.Cmd.(of_list cpuset % p Fpath.(dbdir / "solo5-hvt" + bin) % mem %%
              of_list net %% of_list block %
@@ -178,14 +178,14 @@ let exec name vm taps block =
     let pid = create_process prog line stdout stdout in
     Logs.debug (fun m -> m "created process %d: %a" pid Bos.Cmd.pp cmd) ;
     (* this should get rid of the vmimage from vmmd's memory! *)
-    let config = { vm with vmimage = (fst vm.vmimage, Cstruct.create 0) } in
+    let config = Vm.{ vm with vmimage = (fst vm.vmimage, Cstruct.create 0) } in
-    Ok { config ; cmd ; pid ; taps ; stdout }
+    Ok Vm.{ config ; cmd ; pid ; taps ; stdout }
   with
     Unix.Unix_error (e, _, _) ->
     close_no_err stdout;
     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 destroy vm = Unix.kill vm.Vm.pid 15 (* 15 is SIGTERM *)
 
 let bytes_of_mb size =
   let res = size lsl 20 in

src/vmm_unix.mli

@@ -4,13 +4,13 @@ open Rresult
 
 open Vmm_core
 
-val prepare : Name.t -> vm_config -> (string list, [> R.msg ]) result
+val prepare : Name.t -> Vm.config -> (string list, [> R.msg ]) result
 
-val shutdown : Name.t -> vm -> (unit, [> R.msg ]) result
+val shutdown : Name.t -> Vm.t -> (unit, [> R.msg ]) result
 
-val exec : Name.t -> vm_config -> string list -> Name.t option -> (vm, [> R.msg ]) result
+val exec : Name.t -> Vm.config -> string list -> Name.t option -> (Vm.t, [> R.msg ]) result
 
-val destroy : vm -> unit
+val destroy : Vm.t -> unit
 
 val close_no_err : Unix.file_descr -> unit
 

src/vmm_vmmd.ml

@@ -64,7 +64,7 @@ let handle_create t reply name vm_config =
   (Vmm_resources.check_vm_policy t.resources name vm_config >>= function
     | false -> Error (`Msg "resource policies don't allow creation of this VM")
     | true -> Ok ()) >>= fun () ->
-  (match vm_config.block_device with
+  (match vm_config.Vm.block_device with
    | None -> Ok None
    | Some dev ->
      let block_device_name = Name.block_name name dev in
@@ -89,11 +89,11 @@ let handle_create t reply name vm_config =
           Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
           let tasks = String.Map.add (Name.to_string 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 t, out = log t name (`Vm_start (name, vm.Vm.pid, vm.Vm.taps, None)) in
           Ok (t, [ reply (`String "created VM") ; out ], name, vm)))
 
 let setup_stats t name vm =
-  let stat_out = `Stats_add (vm.pid, vm.taps) in
+  let stat_out = `Stats_add (vm.Vm.pid, vm.Vm.taps) in
   let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; name } in
   let t = { t with stats_counter = Int64.succ t.stats_counter } in
   t, `Stat (header, `Command (`Stats_cmd stat_out))
@@ -101,17 +101,17 @@ let setup_stats t name vm =
 let handle_shutdown t name vm r =
   (match Vmm_unix.shutdown name vm with
    | Ok () -> ()
-   | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ;
+   | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e Vm.pp vm)) ;
   let resources = match Vmm_resources.remove_vm t.resources name with
     | Error (`Msg e) ->
-      Logs.warn (fun m -> m "%s while removing vm %a from resources" e pp_vm vm) ;
+      Logs.warn (fun m -> m "%s while removing vm %a from resources" e Vm.pp vm) ;
       t.resources
     | Ok resources -> resources
   in
   let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; name } in
   let tasks = String.Map.remove (Name.to_string name) t.tasks in
   let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in
-  let t, logout = log t name (`Vm_stop (name, vm.pid, r))
+  let t, logout = log t name (`Vm_stop (name, vm.Vm.pid, r))
   in
   (t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ])
 
@@ -152,7 +152,7 @@ let handle_vm_cmd t reply id msg_to_err = function
     Logs.debug (fun m -> m "info %a" Name.pp id) ;
     let vms =
       Vmm_resources.fold t.resources id
-        (fun id vm vms -> (id, vm.config) :: vms)
+        (fun id vm vms -> (id, vm.Vm.config) :: vms)
         (fun _ _ vms-> vms)
         (fun _ _ _ vms -> vms)
         []

src/vmm_vmmd.mli

@@ -12,17 +12,17 @@ type service_out = [
 
 type out = [ service_out | `Data of Vmm_commands.wire ]
 
-val handle_shutdown : 'a t -> Vmm_core.Name.t -> Vmm_core.vm ->
+val handle_shutdown : 'a t -> Vmm_core.Name.t -> Vmm_core.Vm.t ->
   [ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * out list
 
 val handle_command : 'a t -> Vmm_commands.wire ->
   'a t * out list *
-  [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.Name.t * Vmm_core.vm, [> `Msg of string ]) result
+  [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.Name.t * Vmm_core.Vm.t, [> `Msg of string ]) result
   | `Loop
   | `End
   | `Wait of 'a * out
   | `Wait_and_create of 'a * ('a t -> 'a t * out list *
-                                      [ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.Name.t * Vmm_core.vm, [> Rresult.R.msg ]) result
+                                      [ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.Name.t * Vmm_core.Vm.t, [> Rresult.R.msg ]) result
                                       | `End ]) ]
 
-val setup_stats : 'a t -> Vmm_core.Name.t -> Vmm_core.vm -> 'a t * out
+val setup_stats : 'a t -> Vmm_core.Name.t -> Vmm_core.Vm.t -> 'a t * out