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-23 22:03:36 +00:00
|
|
|
wire_version : Vmm_commands.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 = [
|
2018-10-23 22:03:36 +00:00
|
|
|
| `Stat of Vmm_commands.wire
|
|
|
|
| `Log of Vmm_commands.wire
|
|
|
|
| `Cons of Vmm_commands.wire
|
2018-10-22 21:20:00 +00:00
|
|
|
]
|
|
|
|
|
2018-10-23 22:03:36 +00:00
|
|
|
type out = [ service_out | `Data of Vmm_commands.wire ]
|
2018-10-22 21:20:00 +00:00
|
|
|
|
|
|
|
let log t id event =
|
2018-10-23 22:03:36 +00:00
|
|
|
let data = (Ptime_clock.now (), event) in
|
|
|
|
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.log_counter ; id } in
|
2018-10-22 21:20:00 +00:00
|
|
|
let log_counter = Int64.succ t.log_counter in
|
2018-10-23 22:03:36 +00:00
|
|
|
Logs.debug (fun m -> m "log %a" Log.pp data) ;
|
|
|
|
({ t with log_counter }, `Log (header, `Data (`Log_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-23 22:03:36 +00:00
|
|
|
let name = hdr.Vmm_commands.id in
|
2018-10-22 22:54:05 +00:00
|
|
|
(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-29 16:14:51 +00:00
|
|
|
(Vmm_resources.check_vm_policy t.resources name vm_config >>= function
|
|
|
|
| false -> Error (`Msg "resource policies don't allow this")
|
|
|
|
| true -> Ok ()) >>= 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 =
|
2018-10-23 22:03:36 +00:00
|
|
|
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in
|
2018-10-22 23:36:44 +00:00
|
|
|
(header, `Command (`Console_cmd `Console_add))
|
|
|
|
in
|
2018-10-25 23:11:41 +00:00
|
|
|
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-23 22:03:36 +00:00
|
|
|
let t, out = log t name (`Vm_start (name, 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-23 22:03:36 +00:00
|
|
|
let header = Vmm_commands.{ 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-25 23:11:41 +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-28 18:50:48 +00:00
|
|
|
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) ;
|
|
|
|
t.resources
|
|
|
|
| Ok resources -> resources
|
|
|
|
in
|
2018-10-23 22:03:36 +00:00
|
|
|
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in
|
2018-10-22 22:54:05 +00:00
|
|
|
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-23 22:03:36 +00:00
|
|
|
let t, logout = log t name (`Vm_stop (name, 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) ->
|
2018-11-02 23:04:47 +00:00
|
|
|
Logs.err (fun m -> m "error while processing command: %s" msg) ;
|
2018-10-25 23:11:41 +00:00
|
|
|
(t, [ `Data (header, `Failure msg) ], `End)
|
2018-09-09 18:52:04 +00:00
|
|
|
in
|
2018-10-25 23:11:41 +00:00
|
|
|
let reply x = `Data (header, `Success x) in
|
2018-09-09 18:52:04 +00:00
|
|
|
msg_to_err (
|
2018-10-23 22:03:36 +00:00
|
|
|
let id = header.Vmm_commands.id in
|
2018-10-22 21:20:00 +00:00
|
|
|
match payload with
|
2018-10-22 23:02:14 +00:00
|
|
|
| `Command (`Policy_cmd pc) ->
|
|
|
|
begin match pc with
|
|
|
|
| `Policy_remove ->
|
2018-10-23 22:03:36 +00:00
|
|
|
Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_commands.id) ;
|
2018-10-28 18:50:48 +00:00
|
|
|
Vmm_resources.remove_policy t.resources id >>= fun resources ->
|
2018-10-25 23:11:41 +00:00
|
|
|
Ok ({ t with resources }, [ reply (`String "removed policy") ], `End)
|
2018-10-22 23:02:14 +00:00
|
|
|
| `Policy_add policy ->
|
|
|
|
Logs.debug (fun m -> m "insert policy %a" pp_id id) ;
|
2018-10-28 18:41:06 +00:00
|
|
|
let same_policy = match Vmm_resources.find_policy t.resources id with
|
|
|
|
| None -> false
|
|
|
|
| Some p' -> eq_policy policy p'
|
|
|
|
in
|
|
|
|
if same_policy then
|
2018-11-01 00:23:45 +00:00
|
|
|
Ok (t, [ reply (`String "no modification of policy") ], `Loop)
|
2018-10-28 18:41:06 +00:00
|
|
|
else
|
|
|
|
Vmm_resources.insert_policy t.resources id policy >>= fun resources ->
|
2018-10-31 21:40:09 +00:00
|
|
|
Ok ({ t with resources }, [ reply (`String "added policy") ], `Loop)
|
2018-10-22 23:02:14 +00:00
|
|
|
| `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")
|
|
|
|
| _ ->
|
2018-10-25 23:11:41 +00:00
|
|
|
Ok (t, [ reply (`Policies policies) ], `End)
|
2018-10-22 23:02:14 +00:00
|
|
|
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")
|
|
|
|
| _ ->
|
2018-10-25 23:11:41 +00:00
|
|
|
Ok (t, [ reply (`Vms vms) ], `End)
|
2018-10-22 23:02:14 +00:00
|
|
|
end
|
|
|
|
| `Vm_create vm_config ->
|
|
|
|
handle_create t header vm_config
|
|
|
|
| `Vm_force_create vm_config ->
|
2018-10-29 16:14:51 +00:00
|
|
|
begin
|
|
|
|
let resources =
|
|
|
|
match Vmm_resources.remove_vm t.resources id with
|
|
|
|
| Error _ -> t.resources
|
|
|
|
| Ok r -> r
|
|
|
|
in
|
|
|
|
Vmm_resources.check_vm_policy resources id vm_config >>= function
|
|
|
|
| false -> Error (`Msg "wouldn't match policy")
|
|
|
|
| true -> match Vmm_resources.find_vm t.resources id with
|
2018-10-22 23:02:14 +00:00
|
|
|
| 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))
|
2018-10-29 16:14:51 +00:00
|
|
|
end
|
2018-10-22 23:02:14 +00:00
|
|
|
| `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 =
|
2018-10-25 23:11:41 +00:00
|
|
|
let s = reply (`String "destroyed vm") in
|
2018-10-22 23:02:14 +00:00
|
|
|
match String.Map.find_opt id_str t.tasks with
|
2018-10-25 23:11:41 +00:00
|
|
|
| None -> [ s ], `End
|
2018-10-22 23:02:14 +00:00
|
|
|
| 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
|
|
|
| _ ->
|
2018-10-23 22:03:36 +00:00
|
|
|
Logs.err (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, payload)) ;
|
2018-10-22 23:02:14 +00:00
|
|
|
Error (`Msg "unknown command"))
|