reynir/albatross
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

move Vm to submodule

Browse source
This commit is contained in:
Hannes Mehnert 2018-11-11 03:20:22 +01:00
parent 561ba5c5df
commit 2e7f2730a2
13 changed files with 133 additions and 135 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
app/vmm_cli.ml
View file

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

2
app/vmmd.ml
View file

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

6
src/vmm_asn.ml
View file

@ -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
(vm.cpuid, vm.requested_memory, vm.block_device, network, vm.vmimage, vm.argv)
let network = match vm.Vm.network with [] -> None | xs -> Some xs in
(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

12
src/vmm_commands.ml
View file

@ -48,15 +48,15 @@ let pp_log_cmd ppf = function
type vm_cmd = [
| `Vm_info
| `Vm_create of vm_config
| `Vm_force_create of vm_config
| `Vm_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_force_create vm_config -> Fmt.pf ppf "vm force 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" 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 * [

6
src/vmm_commands.mli
View file

@ -28,8 +28,8 @@ type log_cmd = [
type vm_cmd = [
| `Vm_info
| `Vm_create of vm_config
| `Vm_force_create of vm_config
| `Vm_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
]

47
src/vmm_core.ml
View file

@ -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,20 +194,28 @@ 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 ;
network : string list ;
vmimage : vmtype * Cstruct.t ;
argv : string list option ;
}
}
let pp_image ppf (typ, blob) =
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
@ -222,16 +223,16 @@ let pp_vm_config ppf (vm : vm_config) =
pp_image vm.vmimage
Fmt.(option ~none:(unit "no") (list ~sep:(unit " ") string)) vm.argv
let good_bridge idxs nets =
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 &&
good_bridge vm.network res.bridges
vm.requested_memory <= res.Policy.memory &&
good_bridge vm.network res.Policy.bridges
let check_policies vm res =
let check_policies vm res =
let rec climb = function
| super :: sub :: xs ->
if Policy.is_sub ~super ~sub then climb (sub :: xs)
@ -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 = {
config : vm_config ;
type t = {
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
let translate_tap vm tap =
match List.filter (fun (t, _) -> tap = t) (List.combine vm.taps vm.config.network) with
| [ (_, b) ] -> Some b
| _ -> None
end
module Stats = struct
type rusage = {

31
src/vmm_core.mli
View file

@ -62,38 +62,39 @@ module Policy : sig
val is_sub : super:t -> sub:t -> bool
end
type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ]
val pp_vmtype : vmtype Fmt.t
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;
network : string list;
vmimage : vmtype * Cstruct.t;
argv : string list option;
}
}
val pp_image : (vmtype * Cstruct.t) Fmt.t
val pp_image : (vmtype * Cstruct.t) Fmt.t
val pp_vm_config : vm_config Fmt.t
val good_bridge : string list -> 'a Astring.String.map -> bool
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
val check_policies :
config -> Policy.t list -> (unit, [> `Msg of string ]) Result.result
type vm = {
config : vm_config;
type t = {
config : config;
cmd : Bos.Cmd.t;
pid : int;
taps : string list;
stdout : Unix.file_descr;
}
}
val pp_vm : vm Fmt.t
val translate_tap : vm -> string -> string option
val pp : t Fmt.t
end
module Stats : sig
type rusage = {

20
src/vmm_resources.ml
View file

@ -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 &&
vm_matches_res p vm
res.used_memory + vm.Vm.requested_memory <= p.Policy.memory &&
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
if IS.mem cfg.cpuid p.cpuids && good_bridge cfg.network p.bridges
let cfg = vm.Vm.config in
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)

8
src/vmm_resources.mli
View file

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

18
src/vmm_unix.ml
View file

@ -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 mem = "--mem=" ^ string_of_int vm.requested_memory
and argv = match vm.Vm.argv with None -> [] | Some xs -> xs
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
Ok { config ; cmd ; pid ; taps ; stdout }
let config = Vm.{ vm with vmimage = (fst vm.vmimage, Cstruct.create 0) } in
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

8
src/vmm_unix.mli
View file

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

14
src/vmm_vmmd.ml
View file

@ -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)
[]

8
src/vmm_vmmd.mli
View file

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