2018-09-09 18:52:04 +00:00
|
|
|
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
|
2017-05-26 14:30:34 +00:00
|
|
|
|
|
|
|
open Astring
|
|
|
|
|
|
|
|
open Vmm_core
|
|
|
|
|
|
|
|
open Rresult
|
|
|
|
open R.Infix
|
|
|
|
|
2018-09-09 18:52:04 +00:00
|
|
|
type 'a t = {
|
|
|
|
console_counter : int64 ;
|
2017-05-26 14:30:34 +00:00
|
|
|
console_version : Vmm_wire.version ;
|
2018-09-09 18:52:04 +00:00
|
|
|
stats_counter : int64 ;
|
2017-05-26 14:30:34 +00:00
|
|
|
stats_version : Vmm_wire.version ;
|
2018-09-09 18:52:04 +00:00
|
|
|
log_counter : int64 ;
|
2017-05-26 14:30:34 +00:00
|
|
|
log_version : Vmm_wire.version ;
|
|
|
|
client_version : Vmm_wire.version ;
|
|
|
|
(* TODO: refine, maybe:
|
|
|
|
bridges : (Macaddr.t String.Map.t * String.Set.t) String.Map.t ; *)
|
2018-04-03 20:58:31 +00:00
|
|
|
used_bridges : String.Set.t String.Map.t ;
|
2017-05-26 14:30:34 +00:00
|
|
|
(* TODO: used block devices (since each may only be active once) *)
|
|
|
|
resources : Vmm_resources.t ;
|
2018-09-09 18:52:04 +00:00
|
|
|
tasks : 'a String.Map.t ;
|
2017-05-26 14:30:34 +00:00
|
|
|
}
|
|
|
|
|
2018-09-09 18:52:04 +00:00
|
|
|
let init () = {
|
|
|
|
console_counter = 1L ; console_version = `WV2 ;
|
|
|
|
stats_counter = 1L ; stats_version = `WV2 ;
|
|
|
|
log_counter = 1L ; log_version = `WV2 ;
|
|
|
|
client_version = `WV2 ;
|
|
|
|
used_bridges = String.Map.empty ;
|
|
|
|
resources = Vmm_resources.empty ;
|
|
|
|
tasks = String.Map.empty ;
|
|
|
|
}
|
2017-05-26 14:30:34 +00:00
|
|
|
|
|
|
|
let log state (hdr, event) =
|
2018-09-09 18:52:04 +00:00
|
|
|
let data = Vmm_wire.Log.log state.log_counter state.log_version hdr event in
|
|
|
|
let log_counter = Int64.succ state.log_counter in
|
2018-09-28 20:44:38 +00:00
|
|
|
Logs.debug (fun m -> m "LOG %a" Log.pp (hdr, event)) ;
|
2018-09-09 18:52:04 +00:00
|
|
|
({ state with log_counter }, `Log data)
|
2017-05-26 14:30:34 +00:00
|
|
|
|
2018-09-09 18:52:04 +00:00
|
|
|
let handle_create t hdr vm_config (* policies *) =
|
2017-05-26 14:30:34 +00:00
|
|
|
let full = fullname vm_config in
|
revise force-restart: now with wait for kill and resource cleanup before start
allows to cleanup various hacks, such as checking for pid in vmm_resources
or removing temporarily the allocated resources from the resource map in vmm_engine
semantics is now slightly different, but for sure enhanced.
- each VM has a Lwt.wait () task attached in Vmm_engine.t (tasks : 'c String.Map.t)
- normal create shouldn't be much different, apart from memoizing the sleeper
- after waitpid is done in vmmd, and vmm_engine.shutdown succeeded, Lwt.wakeup is called for the sleeper
- force create now:
- checks static policies
- looks for existing VM (and task), if present: kill and wait for task in vmmd
- continue with presence checking of vm name, dynamic policies, allocate resources (tap, img, fifo)
this means the whole randomness in filenames can be removed, and the
communication between vmm_console and vmm_client is working again (attach/detach
could not work since vmm_console knew only about "albatross.AAA.BBB.RANDOM",
whereas vmm_client insisted on "AAA.BBB"
resource overcommitment (and races in e.g. block device closing + opening) are
gone now, only if the old vm is cleanup up, resources for the new one are
allocated and it is executed
2018-04-04 23:02:45 +00:00
|
|
|
(if Vmm_resources.exists t.resources full then
|
2018-01-16 00:10:22 +00:00
|
|
|
Error (`Msg "VM with same name is already running")
|
|
|
|
else
|
revise force-restart: now with wait for kill and resource cleanup before start
allows to cleanup various hacks, such as checking for pid in vmm_resources
or removing temporarily the allocated resources from the resource map in vmm_engine
semantics is now slightly different, but for sure enhanced.
- each VM has a Lwt.wait () task attached in Vmm_engine.t (tasks : 'c String.Map.t)
- normal create shouldn't be much different, apart from memoizing the sleeper
- after waitpid is done in vmmd, and vmm_engine.shutdown succeeded, Lwt.wakeup is called for the sleeper
- force create now:
- checks static policies
- looks for existing VM (and task), if present: kill and wait for task in vmmd
- continue with presence checking of vm name, dynamic policies, allocate resources (tap, img, fifo)
this means the whole randomness in filenames can be removed, and the
communication between vmm_console and vmm_client is working again (attach/detach
could not work since vmm_console knew only about "albatross.AAA.BBB.RANDOM",
whereas vmm_client insisted on "AAA.BBB"
resource overcommitment (and races in e.g. block device closing + opening) are
gone now, only if the old vm is cleanup up, resources for the new one are
allocated and it is executed
2018-04-04 23:02:45 +00:00
|
|
|
Ok ()) >>= fun () ->
|
2018-09-09 18:52:04 +00:00
|
|
|
(* Logs.debug (fun m -> m "now checking dynamic policies") ;
|
|
|
|
Vmm_resources.check_dynamic t.resources vm_config policies >>= fun () -> *)
|
2017-05-26 14:30:34 +00:00
|
|
|
(* prepare VM: save VM image to disk, create fifo, ... *)
|
2018-07-07 21:14:42 +00:00
|
|
|
Vmm_unix.prepare vm_config >>= fun taps ->
|
revise force-restart: now with wait for kill and resource cleanup before start
allows to cleanup various hacks, such as checking for pid in vmm_resources
or removing temporarily the allocated resources from the resource map in vmm_engine
semantics is now slightly different, but for sure enhanced.
- each VM has a Lwt.wait () task attached in Vmm_engine.t (tasks : 'c String.Map.t)
- normal create shouldn't be much different, apart from memoizing the sleeper
- after waitpid is done in vmmd, and vmm_engine.shutdown succeeded, Lwt.wakeup is called for the sleeper
- force create now:
- checks static policies
- looks for existing VM (and task), if present: kill and wait for task in vmmd
- continue with presence checking of vm name, dynamic policies, allocate resources (tap, img, fifo)
this means the whole randomness in filenames can be removed, and the
communication between vmm_console and vmm_client is working again (attach/detach
could not work since vmm_console knew only about "albatross.AAA.BBB.RANDOM",
whereas vmm_client insisted on "AAA.BBB"
resource overcommitment (and races in e.g. block device closing + opening) are
gone now, only if the old vm is cleanup up, resources for the new one are
allocated and it is executed
2018-04-04 23:02:45 +00:00
|
|
|
Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
|
2018-09-09 18:52:04 +00:00
|
|
|
(* TODO should we pre-reserve sth in t? *)
|
|
|
|
let cons = Vmm_wire.Console.add t.console_counter t.console_version full in
|
|
|
|
Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons cons ],
|
|
|
|
`Create (fun t task ->
|
|
|
|
(* actually execute the vm *)
|
|
|
|
Vmm_unix.exec vm_config taps >>= fun vm ->
|
|
|
|
Logs.debug (fun m -> m "exec()ed vm") ;
|
|
|
|
Vmm_resources.insert t.resources full vm >>= fun resources ->
|
|
|
|
let tasks = String.Map.add (string_of_id full) task t.tasks in
|
|
|
|
let used_bridges =
|
|
|
|
List.fold_left2 (fun b br ta ->
|
|
|
|
let old = match String.Map.find br b with
|
|
|
|
| None -> String.Set.empty
|
|
|
|
| Some x -> x
|
|
|
|
in
|
|
|
|
String.Map.add br (String.Set.add ta old) b)
|
|
|
|
t.used_bridges vm_config.network taps
|
|
|
|
in
|
|
|
|
let t = { t with resources ; tasks ; used_bridges } in
|
|
|
|
let t, out = log t (Log.hdr vm_config.prefix vm_config.vname, `VM_start (vm.pid, vm.taps, None)) in
|
|
|
|
let data = Vmm_wire.success t.client_version hdr.Vmm_wire.id Vmm_wire.Vm.(op_to_int Create) in
|
|
|
|
Ok (t, [ `Data data ; out ], vm)))
|
2018-04-01 21:13:11 +00:00
|
|
|
|
|
|
|
let setup_stats t vm =
|
2018-09-09 18:52:04 +00:00
|
|
|
let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version (fullname vm.config) vm.pid vm.taps in
|
|
|
|
let t = { t with stats_counter = Int64.succ t.stats_counter } in
|
|
|
|
Ok (t, [ `Stat stat_out ])
|
2017-05-26 14:30:34 +00:00
|
|
|
|
|
|
|
let handle_shutdown t vm r =
|
2018-07-07 21:14:42 +00:00
|
|
|
(match Vmm_unix.shutdown vm with
|
2017-05-26 14:30:34 +00:00
|
|
|
| Ok () -> ()
|
2018-03-22 22:29:58 +00:00
|
|
|
| Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ;
|
2017-05-26 14:30:34 +00:00
|
|
|
let resources =
|
|
|
|
match Vmm_resources.remove t.resources (fullname vm.config) vm with
|
2018-03-22 22:29:58 +00:00
|
|
|
| Ok resources -> resources
|
2017-05-26 14:30:34 +00:00
|
|
|
| Error (`Msg e) ->
|
2018-03-22 22:29:58 +00:00
|
|
|
Logs.warn (fun m -> m "%s while removing vm %a" e pp_vm vm) ;
|
2017-05-26 14:30:34 +00:00
|
|
|
t.resources
|
|
|
|
in
|
2018-04-03 20:58:31 +00:00
|
|
|
let used_bridges =
|
2017-05-26 14:30:34 +00:00
|
|
|
List.fold_left2 (fun b br ta ->
|
|
|
|
let old = match String.Map.find br b with
|
|
|
|
| None -> String.Set.empty
|
|
|
|
| Some x -> x
|
|
|
|
in
|
|
|
|
String.Map.add br (String.Set.remove ta old) b)
|
2018-04-03 20:58:31 +00:00
|
|
|
t.used_bridges vm.config.network vm.taps
|
2017-05-26 14:30:34 +00:00
|
|
|
in
|
2018-09-09 18:52:04 +00:00
|
|
|
let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version (fullname vm.config) in
|
revise force-restart: now with wait for kill and resource cleanup before start
allows to cleanup various hacks, such as checking for pid in vmm_resources
or removing temporarily the allocated resources from the resource map in vmm_engine
semantics is now slightly different, but for sure enhanced.
- each VM has a Lwt.wait () task attached in Vmm_engine.t (tasks : 'c String.Map.t)
- normal create shouldn't be much different, apart from memoizing the sleeper
- after waitpid is done in vmmd, and vmm_engine.shutdown succeeded, Lwt.wakeup is called for the sleeper
- force create now:
- checks static policies
- looks for existing VM (and task), if present: kill and wait for task in vmmd
- continue with presence checking of vm name, dynamic policies, allocate resources (tap, img, fifo)
this means the whole randomness in filenames can be removed, and the
communication between vmm_console and vmm_client is working again (attach/detach
could not work since vmm_console knew only about "albatross.AAA.BBB.RANDOM",
whereas vmm_client insisted on "AAA.BBB"
resource overcommitment (and races in e.g. block device closing + opening) are
gone now, only if the old vm is cleanup up, resources for the new one are
allocated and it is executed
2018-04-04 23:02:45 +00:00
|
|
|
let tasks = String.Map.remove (vm_id vm.config) t.tasks in
|
2018-09-09 18:52:04 +00:00
|
|
|
let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; used_bridges ; tasks } in
|
|
|
|
let t, logout = log t (Log.hdr vm.config.prefix vm.config.vname,
|
|
|
|
`VM_stop (vm.pid, r))
|
|
|
|
in
|
|
|
|
(t, [ `Stat stat_out ; logout ])
|
|
|
|
|
|
|
|
let handle_command t hdr buf =
|
|
|
|
let msg_to_err = function
|
|
|
|
| Ok x -> x
|
|
|
|
| Error (`Msg msg) ->
|
|
|
|
Logs.debug (fun m -> m "error while processing command: %s" msg) ;
|
|
|
|
let out = Vmm_wire.fail ~msg t.client_version hdr.Vmm_wire.id in
|
|
|
|
(t, [ `Data out ], `End)
|
|
|
|
in
|
|
|
|
msg_to_err (
|
|
|
|
if Vmm_wire.is_reply hdr then begin
|
|
|
|
Logs.warn (fun m -> m "ignoring reply") ;
|
|
|
|
Ok (t, [], `End)
|
|
|
|
end else if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then
|
2017-05-26 14:30:34 +00:00
|
|
|
Error (`Msg "unknown client version")
|
2018-09-09 18:52:04 +00:00
|
|
|
else Vmm_wire.decode_strings buf >>= fun (id, _off) ->
|
|
|
|
match Vmm_wire.Vm.int_to_op hdr.Vmm_wire.tag with
|
2017-05-26 14:30:34 +00:00
|
|
|
| None -> Error (`Msg "unknown command")
|
2018-09-20 21:19:55 +00:00
|
|
|
| Some Vmm_wire.Vm.Info ->
|
2018-09-09 18:52:04 +00:00
|
|
|
Logs.debug (fun m -> m "info %a" pp_id id) ;
|
|
|
|
begin match Vmm_resources.find t.resources id with
|
|
|
|
| None ->
|
|
|
|
Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ;
|
|
|
|
Error (`Msg "info: not found")
|
|
|
|
| Some x ->
|
|
|
|
let data =
|
|
|
|
Vmm_resources.fold (fun acc vm -> vm :: acc) [] x
|
2017-05-26 14:30:34 +00:00
|
|
|
in
|
2018-09-09 18:52:04 +00:00
|
|
|
let out = Vmm_wire.Vm.info_reply hdr.Vmm_wire.id t.client_version data in
|
|
|
|
Ok (t, [ `Data out ], `End)
|
2017-05-26 14:30:34 +00:00
|
|
|
end
|
2018-09-20 21:19:55 +00:00
|
|
|
| Some Vmm_wire.Vm.Create ->
|
2018-09-09 18:52:04 +00:00
|
|
|
Vmm_wire.Vm.decode_vm_config buf >>= fun vm_config ->
|
|
|
|
handle_create t hdr vm_config
|
2018-09-20 21:19:55 +00:00
|
|
|
| Some Vmm_wire.Vm.Destroy ->
|
2018-09-09 18:52:04 +00:00
|
|
|
match Vmm_resources.find_vm t.resources id with
|
|
|
|
| Some vm ->
|
|
|
|
Vmm_unix.destroy vm ;
|
|
|
|
let id_str = string_of_id id in
|
|
|
|
let out, next =
|
|
|
|
let success = Vmm_wire.success t.client_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in
|
|
|
|
let s = [ `Data success ] in
|
|
|
|
match String.Map.find_opt id_str t.tasks with
|
|
|
|
| None -> s, `End
|
|
|
|
| Some t -> [], `Wait (t, s)
|
|
|
|
in
|
|
|
|
let tasks = String.Map.remove id_str t.tasks in
|
|
|
|
Ok ({ t with tasks }, out, next)
|
|
|
|
| None -> Error (`Msg "destroy: not found"))
|