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 = {
|
2018-10-22 21:20:00 +00:00
|
|
|
wire_version : Vmm_asn.version ;
|
2018-09-09 18:52:04 +00:00
|
|
|
console_counter : int64 ;
|
|
|
|
stats_counter : int64 ;
|
|
|
|
log_counter : int64 ;
|
2017-05-26 14:30:34 +00:00
|
|
|
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-10-22 21:20:00 +00:00
|
|
|
let init wire_version = {
|
|
|
|
wire_version ;
|
|
|
|
console_counter = 1L ;
|
|
|
|
stats_counter = 1L ;
|
|
|
|
log_counter = 1L ;
|
2018-09-09 18:52:04 +00:00
|
|
|
resources = Vmm_resources.empty ;
|
|
|
|
tasks = String.Map.empty ;
|
|
|
|
}
|
2017-05-26 14:30:34 +00:00
|
|
|
|
2018-10-22 21:20:00 +00:00
|
|
|
type service_out = [
|
|
|
|
| `Stat of Vmm_asn.wire
|
|
|
|
| `Log of Vmm_asn.wire
|
|
|
|
| `Cons of Vmm_asn.wire
|
|
|
|
]
|
|
|
|
|
|
|
|
type out = [ service_out | `Data of Vmm_asn.wire ]
|
|
|
|
|
|
|
|
let log t id event =
|
|
|
|
let data = `Log_data (Ptime_clock.now (), event) in
|
|
|
|
let header = Vmm_asn.{ version = t.wire_version ; sequence = t.log_counter ; id } in
|
|
|
|
let log_counter = Int64.succ t.log_counter in
|
|
|
|
Logs.debug (fun m -> m "LOG %a" Log.pp_event event) ;
|
2018-10-23 21:11:22 +00:00
|
|
|
({ t with log_counter }, `Log (header, `Data data))
|
2017-05-26 14:30:34 +00:00
|
|
|
|
2018-10-12 23:05:21 +00:00
|
|
|
let handle_create t hdr vm_config =
|
2018-10-22 22:54:05 +00:00
|
|
|
let name = hdr.Vmm_asn.id in
|
|
|
|
(match Vmm_resources.find_vm t.resources name with
|
2018-10-12 23:05:21 +00:00
|
|
|
| Some _ -> Error (`Msg "VM with same name is already running")
|
|
|
|
| None -> Ok ()) >>= fun () ->
|
|
|
|
Logs.debug (fun m -> m "now checking resource policies") ;
|
2018-10-22 22:54:05 +00:00
|
|
|
(if Vmm_resources.check_vm_policy t.resources name vm_config then
|
2018-10-12 23:05:21 +00:00
|
|
|
Ok ()
|
2018-01-16 00:10:22 +00:00
|
|
|
else
|
2018-10-12 23:05:21 +00:00
|
|
|
Error (`Msg "resource policies don't allow this")) >>= fun () ->
|
2017-05-26 14:30:34 +00:00
|
|
|
(* prepare VM: save VM image to disk, create fifo, ... *)
|
2018-10-22 22:54:05 +00:00
|
|
|
Vmm_unix.prepare name 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-10-22 23:36:44 +00:00
|
|
|
let cons_out =
|
|
|
|
let header = Vmm_asn.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in
|
|
|
|
(header, `Command (`Console_cmd `Console_add))
|
|
|
|
in
|
|
|
|
Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons cons_out ],
|
2018-09-09 18:52:04 +00:00
|
|
|
`Create (fun t task ->
|
|
|
|
(* actually execute the vm *)
|
2018-10-22 22:54:05 +00:00
|
|
|
Vmm_unix.exec name vm_config taps >>= fun vm ->
|
2018-09-09 18:52:04 +00:00
|
|
|
Logs.debug (fun m -> m "exec()ed vm") ;
|
2018-10-22 22:54:05 +00:00
|
|
|
Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
|
|
|
|
let tasks = String.Map.add (string_of_id name) task t.tasks in
|
2018-10-23 20:14:28 +00:00
|
|
|
let t = { t with resources ; tasks } in
|
2018-10-22 22:54:05 +00:00
|
|
|
let t, out = log t name (`VM_start (vm.pid, vm.taps, None)) in
|
2018-10-22 21:20:00 +00:00
|
|
|
let data = `Success (`String "created VM") in
|
2018-10-22 22:54:05 +00:00
|
|
|
Ok (t, [ `Data (hdr, data) ; out ], name, vm)))
|
2018-04-01 21:13:11 +00:00
|
|
|
|
2018-10-22 22:54:05 +00:00
|
|
|
let setup_stats t name vm =
|
2018-10-22 21:20:00 +00:00
|
|
|
let stat_out = `Stats_add (vm.pid, vm.taps) in
|
2018-10-22 22:54:05 +00:00
|
|
|
let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in
|
2018-09-09 18:52:04 +00:00
|
|
|
let t = { t with stats_counter = Int64.succ t.stats_counter } in
|
2018-10-22 21:20:00 +00:00
|
|
|
t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ]
|
2017-05-26 14:30:34 +00:00
|
|
|
|
2018-10-22 22:54:05 +00:00
|
|
|
let handle_shutdown t name vm r =
|
|
|
|
(match Vmm_unix.shutdown name 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)) ;
|
2018-10-22 22:54:05 +00:00
|
|
|
let resources = Vmm_resources.remove t.resources name 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
|
2018-10-23 20:14:28 +00:00
|
|
|
let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in
|
2018-10-22 22:54:05 +00:00
|
|
|
let t, logout = log t name (`VM_stop (vm.pid, r))
|
2018-09-09 18:52:04 +00:00
|
|
|
in
|
2018-10-23 21:11:22 +00:00
|
|
|
(t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ])
|
2018-09-09 18:52:04 +00:00
|
|
|
|
2018-10-22 21:20:00 +00:00
|
|
|
let handle_command t (header, payload) =
|
2018-09-09 18:52:04 +00:00
|
|
|
let msg_to_err = function
|
|
|
|
| Ok x -> x
|
|
|
|
| Error (`Msg msg) ->
|
|
|
|
Logs.debug (fun m -> m "error while processing command: %s" msg) ;
|
2018-10-22 21:20:00 +00:00
|
|
|
let out = `Failure msg in
|
|
|
|
(t, [ `Data (header, out) ], `End)
|
2018-09-09 18:52:04 +00:00
|
|
|
in
|
|
|
|
msg_to_err (
|
2018-10-22 21:20:00 +00:00
|
|
|
let id = header.Vmm_asn.id in
|
|
|
|
match payload with
|
2018-10-22 23:02:14 +00:00
|
|
|
| `Command (`Policy_cmd pc) ->
|
|
|
|
begin match pc with
|
|
|
|
| `Policy_remove ->
|
|
|
|
Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_asn.id) ;
|
|
|
|
let resources = Vmm_resources.remove t.resources id in
|
|
|
|
Ok ({ t with resources }, [ `Data (header, `Success (`String "removed policy")) ], `End)
|
|
|
|
| `Policy_add policy ->
|
|
|
|
Logs.debug (fun m -> m "insert policy %a" pp_id id) ;
|
|
|
|
Vmm_resources.insert_policy t.resources id policy >>= fun resources ->
|
|
|
|
Ok ({ t with resources }, [ `Data (header, `Success (`String "added policy")) ], `End)
|
|
|
|
| `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)
|
|
|
|
[]
|
|
|
|
in
|
|
|
|
match policies with
|
|
|
|
| [] ->
|
|
|
|
Logs.debug (fun m -> m "policies: couldn't find %a" pp_id id) ;
|
|
|
|
Error (`Msg "policy: not found")
|
|
|
|
| _ ->
|
|
|
|
Ok (t, [ `Data (header, `Success (`Policies policies)) ], `End)
|
|
|
|
end
|
2018-10-22 21:20:00 +00:00
|
|
|
end
|
2018-10-22 23:02:14 +00:00
|
|
|
| `Command (`Vm_cmd vc) ->
|
|
|
|
begin match vc with
|
|
|
|
| `Vm_info ->
|
2018-10-12 23:05:21 +00:00
|
|
|
Logs.debug (fun m -> m "info %a" pp_id id) ;
|
|
|
|
let vms =
|
|
|
|
Vmm_resources.fold t.resources id
|
2018-10-22 23:02:14 +00:00
|
|
|
(fun id vm vms -> (id, vm.config) :: vms)
|
2018-10-12 23:05:21 +00:00
|
|
|
(fun _ _ vms-> vms)
|
|
|
|
[]
|
|
|
|
in
|
2018-10-22 23:02:14 +00:00
|
|
|
begin match vms with
|
|
|
|
| [] ->
|
|
|
|
Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ;
|
|
|
|
Error (`Msg "info: not found")
|
|
|
|
| _ ->
|
|
|
|
Ok (t, [ `Data (header, `Success (`Vms vms)) ], `End)
|
|
|
|
end
|
|
|
|
| `Vm_create vm_config ->
|
|
|
|
handle_create t header vm_config
|
|
|
|
| `Vm_force_create vm_config ->
|
|
|
|
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 ->
|
|
|
|
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
|
|
|
|
| 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))
|
|
|
|
end
|
|
|
|
else
|
|
|
|
Error (`Msg "wouldn't match policy")
|
|
|
|
| `Vm_destroy ->
|
|
|
|
begin 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 s = [ `Data (header, `Success (`String "destroyed vm")) ] in
|
|
|
|
match String.Map.find_opt id_str t.tasks with
|
|
|
|
| None -> s, `End
|
|
|
|
| Some t -> [], `Wait (t, s)
|
|
|
|
in
|
2018-10-22 21:20:00 +00:00
|
|
|
let tasks = String.Map.remove id_str t.tasks in
|
2018-10-22 23:02:14 +00:00
|
|
|
Ok ({ t with tasks }, out, next)
|
|
|
|
| None -> Error (`Msg "destroy: not found")
|
|
|
|
end
|
2018-10-22 21:20:00 +00:00
|
|
|
end
|
2018-10-22 23:02:14 +00:00
|
|
|
| _ ->
|
|
|
|
Logs.err (fun m -> m "ignoring %a" Vmm_asn.pp_wire (header, payload)) ;
|
|
|
|
Error (`Msg "unknown command"))
|