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-11-10 00:02:07 +00:00
|
|
|
let init wire_version =
|
|
|
|
let t = {
|
|
|
|
wire_version ;
|
|
|
|
console_counter = 1L ;
|
|
|
|
stats_counter = 1L ;
|
|
|
|
log_counter = 1L ;
|
|
|
|
resources = Vmm_resources.empty ;
|
|
|
|
tasks = String.Map.empty ;
|
|
|
|
} in
|
|
|
|
match Vmm_unix.find_block_devices () with
|
|
|
|
| Error (`Msg msg) ->
|
|
|
|
Logs.warn (fun m -> m "couldn't find block devices %s" msg) ;
|
|
|
|
t
|
|
|
|
| Ok devs ->
|
|
|
|
let resources =
|
|
|
|
List.fold_left (fun r (id, size) ->
|
|
|
|
match Vmm_resources.insert_block r id size with
|
|
|
|
| Error (`Msg msg) ->
|
2018-11-11 00:21:12 +00:00
|
|
|
Logs.err (fun m -> m "couldn't insert block device %a (%dM): %s" Name.pp id size msg) ;
|
2018-11-10 00:02:07 +00:00
|
|
|
r
|
|
|
|
| Ok r -> r)
|
|
|
|
t.resources devs
|
|
|
|
in
|
|
|
|
{ t with resources }
|
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
|
|
|
|
2018-11-11 00:21:12 +00:00
|
|
|
let log t name event =
|
2018-10-23 22:03:36 +00:00
|
|
|
let data = (Ptime_clock.now (), event) in
|
2018-11-11 00:21:12 +00:00
|
|
|
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.log_counter ; name } 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-11-10 00:02:07 +00:00
|
|
|
let handle_create t reply name vm_config =
|
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
|
2018-11-10 00:02:07 +00:00
|
|
|
| false -> Error (`Msg "resource policies don't allow creation of this VM")
|
2018-10-29 16:14:51 +00:00
|
|
|
| true -> Ok ()) >>= fun () ->
|
2018-11-10 00:02:07 +00:00
|
|
|
(match vm_config.block_device with
|
|
|
|
| None -> Ok None
|
|
|
|
| Some dev ->
|
2018-11-11 00:21:12 +00:00
|
|
|
let block_device_name = Name.block_name name dev in
|
|
|
|
Logs.debug (fun m -> m "looking for block device %a" Name.pp block_device_name) ;
|
2018-11-10 00:02:07 +00:00
|
|
|
match Vmm_resources.find_block t.resources block_device_name with
|
|
|
|
| Some (_, false) -> Ok (Some block_device_name)
|
|
|
|
| Some (_, true) -> Error (`Msg "block device is busy")
|
|
|
|
| None -> Error (`Msg "cannot find block device") ) >>= fun block_device ->
|
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-11-11 00:21:12 +00:00
|
|
|
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.console_counter ; 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-11-10 00:02:07 +00:00
|
|
|
Vmm_unix.exec name vm_config taps block_device >>= 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 ->
|
2018-11-11 00:21:12 +00:00
|
|
|
let tasks = String.Map.add (Name.to_string 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-11-10 00:02:07 +00:00
|
|
|
Ok (t, [ reply (`String "created VM") ; 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-11-11 00:21:12 +00:00
|
|
|
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; 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-11-11 00:21:12 +00:00
|
|
|
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
|
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-11-10 00:02:07 +00:00
|
|
|
let handle_policy_cmd t reply id = function
|
|
|
|
| `Policy_remove ->
|
2018-11-11 00:21:12 +00:00
|
|
|
Logs.debug (fun m -> m "remove policy %a" Name.pp id) ;
|
2018-11-10 00:02:07 +00:00
|
|
|
Vmm_resources.remove_policy t.resources id >>= fun resources ->
|
|
|
|
Ok ({ t with resources }, [ reply (`String "removed policy") ], `End)
|
|
|
|
| `Policy_add policy ->
|
2018-11-11 00:21:12 +00:00
|
|
|
Logs.debug (fun m -> m "insert policy %a" Name.pp id) ;
|
2018-11-10 00:02:07 +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
|
|
|
|
Ok (t, [ reply (`String "no modification of policy") ], `Loop)
|
|
|
|
else
|
|
|
|
Vmm_resources.insert_policy t.resources id policy >>= fun resources ->
|
|
|
|
Ok ({ t with resources }, [ reply (`String "added policy") ], `Loop)
|
|
|
|
| `Policy_info ->
|
2018-11-11 00:21:12 +00:00
|
|
|
Logs.debug (fun m -> m "policy %a" Name.pp id) ;
|
2018-11-10 00:02:07 +00:00
|
|
|
let policies =
|
|
|
|
Vmm_resources.fold t.resources id
|
|
|
|
(fun _ _ policies -> policies)
|
|
|
|
(fun prefix policy policies-> (prefix, policy) :: policies)
|
|
|
|
(fun _ _ _ policies -> policies)
|
|
|
|
[]
|
|
|
|
in
|
|
|
|
match policies with
|
|
|
|
| [] ->
|
2018-11-11 00:21:12 +00:00
|
|
|
Logs.debug (fun m -> m "policies: couldn't find %a" Name.pp id) ;
|
2018-11-10 00:02:07 +00:00
|
|
|
Error (`Msg "policy: not found")
|
|
|
|
| _ ->
|
|
|
|
Ok (t, [ reply (`Policies policies) ], `End)
|
|
|
|
|
|
|
|
let handle_vm_cmd t reply id msg_to_err = function
|
|
|
|
| `Vm_info ->
|
2018-11-11 00:21:12 +00:00
|
|
|
Logs.debug (fun m -> m "info %a" Name.pp id) ;
|
2018-11-10 00:02:07 +00:00
|
|
|
let vms =
|
|
|
|
Vmm_resources.fold t.resources id
|
|
|
|
(fun id vm vms -> (id, vm.config) :: vms)
|
|
|
|
(fun _ _ vms-> vms)
|
|
|
|
(fun _ _ _ vms -> vms)
|
|
|
|
[]
|
|
|
|
in
|
|
|
|
begin match vms with
|
|
|
|
| [] ->
|
2018-11-11 00:21:12 +00:00
|
|
|
Logs.debug (fun m -> m "info: couldn't find %a" Name.pp id) ;
|
2018-11-10 00:02:07 +00:00
|
|
|
Error (`Msg "info: not found")
|
|
|
|
| _ ->
|
|
|
|
Ok (t, [ reply (`Vms vms) ], `End)
|
|
|
|
end
|
|
|
|
| `Vm_create vm_config -> handle_create t reply id vm_config
|
|
|
|
| `Vm_force_create vm_config ->
|
|
|
|
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
|
|
|
|
| None -> handle_create t reply id vm_config
|
|
|
|
| Some vm ->
|
|
|
|
Vmm_unix.destroy vm ;
|
2018-11-11 00:21:12 +00:00
|
|
|
let id_str = Name.to_string id in
|
2018-11-10 00:02:07 +00:00
|
|
|
match String.Map.find_opt id_str t.tasks with
|
|
|
|
| None -> handle_create t reply id 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 reply id vm_config))
|
|
|
|
end
|
|
|
|
| `Vm_destroy ->
|
|
|
|
match Vmm_resources.find_vm t.resources id with
|
|
|
|
| Some vm ->
|
|
|
|
Vmm_unix.destroy vm ;
|
2018-11-11 00:21:12 +00:00
|
|
|
let id_str = Name.to_string id in
|
2018-11-10 00:02:07 +00:00
|
|
|
let out, next =
|
|
|
|
let s = reply (`String "destroyed vm") 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")
|
|
|
|
|
|
|
|
let handle_block_cmd t reply id = function
|
|
|
|
| `Block_remove ->
|
2018-11-11 00:21:12 +00:00
|
|
|
Logs.debug (fun m -> m "removing block %a" Name.pp id) ;
|
2018-11-10 00:02:07 +00:00
|
|
|
begin match Vmm_resources.find_block t.resources id with
|
|
|
|
| None -> Error (`Msg "remove block: not found")
|
|
|
|
| Some (_, true) -> Error (`Msg "remove block: is in use")
|
|
|
|
| Some (_, false) ->
|
|
|
|
Vmm_unix.destroy_block id >>= fun () ->
|
|
|
|
Vmm_resources.remove_block t.resources id >>= fun resources ->
|
|
|
|
Ok ({ t with resources }, [ reply (`String "removed block") ], `End)
|
|
|
|
end
|
|
|
|
| `Block_add size ->
|
|
|
|
begin
|
2018-11-11 00:21:12 +00:00
|
|
|
Logs.debug (fun m -> m "insert block %a: %dMB" Name.pp id size) ;
|
2018-11-10 00:02:07 +00:00
|
|
|
match Vmm_resources.find_block t.resources id with
|
|
|
|
| Some _ -> Error (`Msg "block device with same name already exists")
|
|
|
|
| None ->
|
|
|
|
Vmm_resources.check_block_policy t.resources id size >>= function
|
|
|
|
| false -> Error (`Msg "adding block device would violate policy")
|
|
|
|
| true ->
|
|
|
|
Vmm_unix.create_block id size >>= fun () ->
|
|
|
|
Vmm_resources.insert_block t.resources id size >>= fun resources ->
|
|
|
|
Ok ({ t with resources }, [ reply (`String "added block device") ], `Loop)
|
|
|
|
end
|
|
|
|
| `Block_info ->
|
2018-11-11 00:21:12 +00:00
|
|
|
Logs.debug (fun m -> m "block %a" Name.pp id) ;
|
2018-11-10 00:02:07 +00:00
|
|
|
let blocks =
|
|
|
|
Vmm_resources.fold t.resources id
|
|
|
|
(fun _ _ blocks -> blocks)
|
|
|
|
(fun _ _ blocks-> blocks)
|
|
|
|
(fun prefix size active blocks -> (prefix, size, active) :: blocks)
|
|
|
|
[]
|
|
|
|
in
|
|
|
|
match blocks with
|
|
|
|
| [] ->
|
2018-11-11 00:21:12 +00:00
|
|
|
Logs.debug (fun m -> m "block: couldn't find %a" Name.pp id) ;
|
2018-11-10 00:02:07 +00:00
|
|
|
Error (`Msg "block: not found")
|
|
|
|
| _ ->
|
|
|
|
Ok (t, [ reply (`Blocks blocks) ], `End)
|
|
|
|
|
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-11-10 00:02:07 +00:00
|
|
|
and reply x = `Data (header, `Success x)
|
2018-11-11 00:21:12 +00:00
|
|
|
and id = header.Vmm_commands.name
|
2018-09-09 18:52:04 +00:00
|
|
|
in
|
|
|
|
msg_to_err (
|
2018-10-22 21:20:00 +00:00
|
|
|
match payload with
|
2018-11-10 00:02:07 +00:00
|
|
|
| `Command (`Policy_cmd pc) -> handle_policy_cmd t reply id pc
|
|
|
|
| `Command (`Vm_cmd vc) -> handle_vm_cmd t reply id msg_to_err vc
|
|
|
|
| `Command (`Block_cmd bc) -> handle_block_cmd t reply id bc
|
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"))
|