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

get rid of vm_config.vname

Browse source
This commit is contained in:
Hannes Mehnert 2018-10-23 00:54:05 +02:00
parent 183d1c9e58
commit c399501a18
12 changed files with 53 additions and 79 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
app/vmmc.ml
View file

@ -94,10 +94,7 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc
(* TODO we could do the compression btw *)
and vmimage = `Hvt_amd64, Cstruct.of_string image'
in
let vm_config = {
vname = name ; cpuid ; requested_memory ; block_device ; network ;
vmimage ; argv
} in
let vm_config = { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in
let cmd =
if force then
`Vm_force_create vm_config

6
app/vmmd.ml
View file

@ -47,18 +47,18 @@ let create c_fd process cont =
| Error (`Msg msg) ->
Logs.err (fun m -> m "create continuation failed %s" msg) ;
Lwt.return_unit
| Ok (state'', out, vm) ->
| Ok (state'', out, name, vm) ->
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 ->
let state', out' = Vmm_engine.handle_shutdown !state vm r in
let state', out' = Vmm_engine.handle_shutdown !state name vm r in
s := { !s with vm_destroyed = succ !s.vm_destroyed } ;
state := state' ;
process out' >|= fun () ->
Lwt.wakeup wakeme ()) ;
process out >>= fun () ->
let state', out = Vmm_engine.setup_stats !state vm in
let state', out = Vmm_engine.setup_stats !state name vm in
state := state' ;
process out (* TODO: need to read from stats socket! *)

5
src/vmm_asn.ml
View file

@ -248,9 +248,8 @@ let vm_of_cert prefix cert =
opt cert Oid.network strings_of_cstruct >>= fun network ->
req "vmimage" cert Oid.vmimage image_of_cstruct >>= fun vmimage ->
opt cert Oid.argv strings_of_cstruct >>= fun argv ->
let vname = prefix @ [ id cert ] in
let network = match network with None -> [] | Some x -> x in
Ok { vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
Ok { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
let command_of_cert version cert =
version_of_cert version cert >>= fun () ->
@ -508,7 +507,7 @@ let pp_vm_cmd ppf = function
let vm_config =
let f (cpuid, requested_memory, block_device, network, vmimage, argv) =
let network = match network with None -> [] | Some xs -> xs in
{ vname = [] ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
{ 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)

1
src/vmm_asn.mli
View file

@ -233,4 +233,3 @@ type log_entry = header * Ptime.t * Log.event
val log_entry_to_cstruct : log_entry -> Cstruct.t
val log_entry_of_cstruct : Cstruct.t -> (log_entry, [> `Msg of string ]) result

10
src/vmm_core.ml
View file

@ -160,7 +160,6 @@ let is_sub ~super ~sub =
sub_bridges super.bridges sub.bridges && sub_block super.block sub.block
type vm_config = {
vname : id ;
cpuid : int ;
requested_memory : int ;
block_device : string option ;
@ -169,18 +168,13 @@ type vm_config = {
argv : string list option ;
}
(* used for block devices *)
let location vm = match vm.vname with
| tld::rest -> tld, String.concat ~sep:"." rest
| [] -> invalid_arg "dunno how this happened"
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) =
Fmt.pf ppf "%a cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a"
pp_id vm.vname vm.cpuid vm.requested_memory
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
Fmt.(list ~sep:(unit ", ") string) vm.network
pp_image vm.vmimage

2
src/vmm_core.mli
View file

@ -204,7 +204,6 @@ val sub_block : 'a option -> 'a option -> bool
val sub_cpu : IS.t -> IS.t -> bool
val is_sub : super:policy -> sub:policy -> bool
type vm_config = {
vname : id;
cpuid : int;
requested_memory : int;
block_device : string option;
@ -212,7 +211,6 @@ type vm_config = {
vmimage : vmtype * Cstruct.t;
argv : string list option;
}
val location : vm_config -> string * string
val pp_image :
Format.formatter ->
[< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] * Cstruct.t -> unit

40
src/vmm_engine.ml
View file

@ -47,28 +47,28 @@ let log t id event =
let handle_create t hdr vm_config =
(* TODO fix (remove field?) *)
let vm_config = { vm_config with vname = hdr.Vmm_asn.id } in
(match Vmm_resources.find_vm t.resources vm_config.vname with
let name = hdr.Vmm_asn.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") ;
(if Vmm_resources.check_vm_policy t.resources vm_config then
(if Vmm_resources.check_vm_policy t.resources name vm_config then
Ok ()
else
Error (`Msg "resource policies don't allow this")) >>= fun () ->
(* prepare VM: save VM image to disk, create fifo, ... *)
Vmm_unix.prepare vm_config >>= fun taps ->
Vmm_unix.prepare name vm_config >>= fun taps ->
Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
(* TODO should we pre-reserve sth in t? *)
let cons = `Console_add in
let header = Vmm_asn.{ version = t.wire_version ; sequence = t.console_counter ; id = vm_config.vname } in
let header = Vmm_asn.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in
Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons (header, `Command (`Console_cmd cons)) ],
`Create (fun t task ->
(* actually execute the vm *)
Vmm_unix.exec vm_config taps >>= fun vm ->
Vmm_unix.exec name vm_config taps >>= fun vm ->
Logs.debug (fun m -> m "exec()ed vm") ;
Vmm_resources.insert_vm t.resources vm >>= fun resources ->
let tasks = String.Map.add (string_of_id vm_config.vname) task t.tasks in
Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
let tasks = String.Map.add (string_of_id name) task t.tasks in
let used_bridges =
List.fold_left2 (fun b br ta ->
let old = match String.Map.find br b with
@ -79,21 +79,21 @@ let handle_create t hdr vm_config =
t.used_bridges vm_config.network taps
in
let t = { t with resources ; tasks ; used_bridges } in
let t, out = log t vm_config.vname (`VM_start (vm.pid, vm.taps, None)) in
let t, out = log t name (`VM_start (vm.pid, vm.taps, None)) in
let data = `Success (`String "created VM") in
Ok (t, [ `Data (hdr, data) ; out ], vm)))
Ok (t, [ `Data (hdr, data) ; out ], name, vm)))
let setup_stats t vm =
let setup_stats t name vm =
let stat_out = `Stats_add (vm.pid, vm.taps) in
let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = vm.config.vname } in
let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in
let t = { t with stats_counter = Int64.succ t.stats_counter } in
t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ]
let handle_shutdown t vm r =
(match Vmm_unix.shutdown vm with
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)) ;
let resources = Vmm_resources.remove t.resources vm.config.vname in
let resources = Vmm_resources.remove t.resources name in
let used_bridges =
List.fold_left2 (fun b br ta ->
let old = match String.Map.find br b with
@ -104,10 +104,10 @@ let handle_shutdown t vm r =
t.used_bridges vm.config.network vm.taps
in
let stat_out = `Stats_remove in
let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = vm.config.vname } in
let tasks = String.Map.remove (string_of_id vm.config.vname) t.tasks in
let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in
let tasks = String.Map.remove (string_of_id name) t.tasks in
let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; used_bridges ; tasks } in
let t, logout = log t vm.config.vname (`VM_stop (vm.pid, r))
let t, logout = log t name (`VM_stop (vm.pid, r))
in
(t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ; logout ])
@ -172,8 +172,8 @@ let handle_command t (header, payload) =
| `Command (`Vm_cmd (`Vm_create vm_config)) ->
handle_create t header vm_config
| `Command (`Vm_cmd (`Vm_force_create vm_config)) ->
let resources = Vmm_resources.remove t.resources vm_config.vname in
if Vmm_resources.check_vm_policy resources vm_config then
let resources = Vmm_resources.remove t.resources id in
if Vmm_resources.check_vm_policy resources id vm_config then
begin match Vmm_resources.find_vm t.resources id with
| None -> handle_create t header vm_config
| Some vm ->

8
src/vmm_engine.mli
View file

@ -11,16 +11,16 @@ type service_out = [
type out = [ service_out | `Data of Vmm_asn.wire ]
val handle_shutdown : 'a t -> Vmm_core.vm ->
val handle_shutdown : 'a t -> Vmm_core.id -> Vmm_core.vm ->
[ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * out list
val handle_command : 'a t -> Vmm_asn.wire ->
'a t * out list *
[ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.vm, [> Rresult.R.msg ]) result
[ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.id * Vmm_core.vm, [> Rresult.R.msg ]) result
| `End
| `Wait of 'a * out list
| `Wait_and_create of 'a * ('a t -> 'a t * out list *
[ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.vm, [> Rresult.R.msg ]) result
[ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.id * Vmm_core.vm, [> Rresult.R.msg ]) result
| `End ]) ]
val setup_stats : 'a t -> Vmm_core.vm -> 'a t * out list
val setup_stats : 'a t -> Vmm_core.id -> Vmm_core.vm -> 'a t * out list

10
src/vmm_resources.ml
View file

@ -50,17 +50,17 @@ let find_vm t name = match Vmm_trie.find name t with
| Some (Vm vm) -> Some vm
| _ -> None
let check_vm_policy t vm =
let dom = domain vm.vname in
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 -> true
| Some (Vm _) -> assert false
| Some (Policy p) -> check_resource p vm res
let insert_vm t vm =
if check_vm_policy t vm.config then
match Vmm_trie.insert vm.config.vname (Vm vm) t with
let insert_vm t name vm =
if check_vm_policy t name vm.config then
match Vmm_trie.insert name (Vm vm) t with
| t', None -> Ok t'
| _, Some _ -> Error (`Msg "vm already exists")
else

4
src/vmm_resources.mli
View file

@ -22,11 +22,11 @@ val find_vm : t -> Vmm_core.id -> Vmm_core.vm option
(** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be
allowed under the current policies. *)
val check_vm_policy : t -> Vmm_core.vm_config -> bool
val check_vm_policy : t -> Vmm_core.id -> Vmm_core.vm_config -> bool
(** [insert_vm t vm] inserts [vm] under [id] in [t], and returns the new [t] or
an error. *)
val insert_vm : t -> Vmm_core.vm -> (t, [> `Msg of string]) result
val insert_vm : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
(** [insert_policy t id policy] inserts [policy] under [id] in [t], and returns
the new [t] or an error. *)

33
src/vmm_unix.ml
View file

@ -58,8 +58,8 @@ let rec mkfifo name =
| Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name
let image_file, fifo_file =
((fun vm -> Fpath.(tmpdir / (string_of_id vm.vname) + "img")),
(fun vm -> Fpath.(tmpdir / "fifo" / (string_of_id vm.vname))))
((fun name -> Fpath.(tmpdir / (string_of_id name) + "img")),
(fun name -> Fpath.(tmpdir / "fifo" / (string_of_id name))))
let rec fifo_exists file =
try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with
@ -103,18 +103,7 @@ let destroy_tap tapname =
Bos.OS.Cmd.run Bos.Cmd.(v "ip" % "tuntap" % "del" % "dev" % tapname % "mode" % "tap")
| x -> Error (`Msg ("unsupported operating system " ^ x))
let create_bridge bname =
Lazy.force (uname ()) >>= fun (sys, _) ->
match sys with
| x when x = "FreeBSD" ->
let cmd = Bos.Cmd.(v "ifconfig" % "bridge" % "create") in
Bos.OS.Cmd.run_out cmd |> Bos.OS.Cmd.out_string >>= fun (name, _) ->
Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % name % "name" % bname)
| x when x = "Linux" ->
Bos.OS.Cmd.run Bos.Cmd.(v "brctl" % "addbr" % bname)
| x -> Error (`Msg ("unsupported operating system " ^ x))
let prepare vm =
let prepare name vm =
(match vm.vmimage with
| `Hvt_amd64, blob -> Ok blob
| `Hvt_amd64_compressed, blob ->
@ -123,7 +112,7 @@ let prepare vm =
| Error () -> Error (`Msg "failed to uncompress")
end
| `Hvt_arm64, _ -> Error (`Msg "no amd64 hvt image found")) >>= fun image ->
let fifo = fifo_file vm in
let fifo = fifo_file name in
(match fifo_exists fifo with
| Ok true -> Ok ()
| Ok false -> Error (`Msg ("file " ^ Fpath.to_string fifo ^ " exists and is not a fifo"))
@ -137,13 +126,13 @@ let prepare vm =
create_tap b >>= fun tap ->
Ok (tap :: acc))
(Ok []) vm.network >>= fun taps ->
Bos.OS.File.write (image_file vm) (Cstruct.to_string image) >>= fun () ->
Bos.OS.File.write (image_file name) (Cstruct.to_string image) >>= fun () ->
Ok (List.rev taps)
let shutdown vm =
let shutdown name vm =
(* same order as prepare! *)
Bos.OS.File.delete (image_file vm.config) >>= fun () ->
Bos.OS.File.delete (fifo_file vm.config) >>= fun () ->
Bos.OS.File.delete (image_file name) >>= fun () ->
Bos.OS.File.delete (fifo_file name) >>= fun () ->
List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps
let cpuset cpu =
@ -156,7 +145,7 @@ let cpuset cpu =
Ok ([ "taskset" ; "-c" ; cpustring ])
| x -> Error (`Msg ("unsupported operating system " ^ x))
let exec vm taps =
let exec name vm taps =
(* TODO: --net-mac=xx *)
let net = List.map (fun t -> "--net=" ^ t) taps in
let argv = match vm.argv with None -> [] | Some xs -> xs in
@ -168,12 +157,12 @@ let exec vm taps =
let mem = "--mem=" ^ string_of_int vm.requested_memory in
let cmd =
Bos.Cmd.(of_list cpuset % p bin % mem %% of_list net %
"--" % p (image_file vm) %% of_list argv)
"--" % p (image_file name) %% of_list argv)
in
let line = Bos.Cmd.to_list cmd in
let prog = try List.hd line with Failure _ -> failwith err_empty_line in
let line = Array.of_list line in
let fifo = fifo_file vm in
let fifo = fifo_file name in
Logs.debug (fun m -> m "write fd for fifo %a" Fpath.pp fifo);
write_fd_for_file fifo >>= fun stdout ->
Logs.debug (fun m -> m "opened file descriptor!");

8
src/vmm_unix.mli
View file

@ -4,16 +4,14 @@ open Rresult
open Vmm_core
val prepare : vm_config -> (string list, [> R.msg ]) result
val prepare : id -> vm_config -> (string list, [> R.msg ]) result
val shutdown : vm -> (unit, [> R.msg ]) result
val shutdown : id -> vm -> (unit, [> R.msg ]) result
val exec : vm_config -> string list -> (vm, [> R.msg ]) result
val exec : id -> vm_config -> string list -> (vm, [> R.msg ]) result
val destroy : vm -> unit
val close_no_err : Unix.file_descr -> unit
val create_tap : string -> (string, [> R.msg ]) result
val create_bridge : string -> (unit, [> R.msg ]) result