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

revise force-restart: now with wait for kill and resource cleanup before start

Browse source 
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
This commit is contained in:
Hannes Mehnert 2018-04-05 01:02:45 +02:00
parent a89b2925fd
commit 9696953cd7
6 changed files with 150 additions and 129 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

115
app/vmmd.ml
View file

@ -67,56 +67,71 @@ let handle ca state t =
| Ok (state', outs, next) -> | Ok (state', outs, next) ->
state := state' ; state := state' ;
process state outs >>= fun () -> process state outs >>= fun () ->
(match next with begin match next with
| `Create cont -> | `Create (task, next) ->
(match cont !state t with (match task with
| Ok (state', outs, vm) -> | None -> Lwt.return_unit
state := state' ; | Some (kill, wait) -> kill () ; wait) >>= fun () ->
s := { !s with vm_created = succ !s.vm_created } ; let await, wakeme = Lwt.wait () in
Lwt.async (fun () -> begin match next !state await with
Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> | Ok (state', outs, cont) ->
let state', outs = Vmm_engine.handle_shutdown !state vm r in state := state' ;
s := { !s with vm_destroyed = succ !s.vm_destroyed } ; process state outs >>= fun () ->
state := state' ; begin match cont !state t with
process state outs) ; | Ok (state', outs, vm) ->
process state outs >>= fun () -> state := state' ;
begin s := { !s with vm_created = succ !s.vm_created } ;
match Vmm_engine.setup_stats !state vm with Lwt.async (fun () ->
| Ok (state', outs) -> Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r ->
state := state' ; let state', outs = Vmm_engine.handle_shutdown !state vm r in
process state outs s := { !s with vm_destroyed = succ !s.vm_destroyed } ;
| Error (`Msg e) -> state := state' ;
Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ; process state outs >|= fun () ->
Lwt.return_unit Lwt.wakeup wakeme ()) ;
end process state outs >>= fun () ->
| Error (`Msg e) -> begin match Vmm_engine.setup_stats !state vm with
Logs.err (fun m -> m "error while cont %s" e) ; | Ok (state', outs) ->
let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in state := state' ;
process state [ `Tls (t, err) ]) >>= fun () -> process state outs
Tls_lwt.Unix.close (fst t) | Error (`Msg e) ->
| `Loop (prefix, perms) -> Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ;
let rec loop () = Lwt.return_unit
Vmm_tls.read_tls (fst t) >>= function end
| Error (`Msg msg) -> | Error (`Msg e) ->
Logs.err (fun m -> m "reading client %a error: %s" pp_sockaddr t msg) ; Logs.err (fun m -> m "error while create %s" e) ;
loop () let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in
| Error _ -> process state [ `Tls (t, err) ]
Logs.err (fun m -> m "disconnect from %a" pp_sockaddr t) ; end
let state', cons = Vmm_engine.handle_disconnect !state t in | Error (`Msg e) ->
state := state' ; Logs.err (fun m -> m "error while cont %s" e) ;
Lwt_list.iter_s (fun (s, data) -> write_raw s data) cons >>= fun () -> let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in
Tls_lwt.Unix.close (fst t) process state [ `Tls (t, err) ]
| Ok (hdr, buf) -> end >>= fun () ->
let state', out = Vmm_engine.handle_command !state t prefix perms hdr buf in Tls_lwt.Unix.close (fst t)
state := state' ; | `Loop (prefix, perms) ->
process state out >>= fun () -> let rec loop () =
loop () Vmm_tls.read_tls (fst t) >>= function
in | Error (`Msg msg) ->
loop () Logs.err (fun m -> m "reading client %a error: %s" pp_sockaddr t msg) ;
| `Close socks -> loop ()
Logs.debug (fun m -> m "closing session with %d active ones" (List.length socks)) ; | Error _ ->
Lwt_list.iter_s (fun (t, _) -> Tls_lwt.Unix.close t) socks >>= fun () -> Logs.err (fun m -> m "disconnect from %a" pp_sockaddr t) ;
Tls_lwt.Unix.close (fst t)) let state', cons = Vmm_engine.handle_disconnect !state t in
state := state' ;
Lwt_list.iter_s (fun (s, data) -> write_raw s data) cons >>= fun () ->
Tls_lwt.Unix.close (fst t)
| Ok (hdr, buf) ->
let state', out = Vmm_engine.handle_command !state t prefix perms hdr buf in
state := state' ;
process state out >>= fun () ->
loop ()
in
loop ()
| `Close socks ->
Logs.debug (fun m -> m "closing session with %d active ones" (List.length socks)) ;
Lwt_list.iter_s (fun (t, _) -> Tls_lwt.Unix.close t) socks >>= fun () ->
Tls_lwt.Unix.close (fst t)
end
| Error (`Msg e) -> | Error (`Msg e) ->
Logs.err (fun m -> m "VMM %a %s" pp_sockaddr t e) ; Logs.err (fun m -> m "VMM %a %s" pp_sockaddr t e) ;
let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in

36
src/vmm_commands.ml
View file

@ -57,16 +57,10 @@ let rec mkfifo name =
try Unix.mkfifo (Fpath.to_string name) 0o640 with try Unix.mkfifo (Fpath.to_string name) 0o640 with
| Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name | Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name
let image_fn = Fpath.add_ext "img" let image_file, fifo_file =
let fifo_fn = Fpath.add_ext "fifo" let tmp = Fpath.v (Filename.get_temp_dir_name ()) in
((fun vm -> Fpath.(tmp / (vm_id vm) + "img")),
let tmpfile vm = (fun vm -> Fpath.(tmp / (vm_id vm) + "fifo")))
let random =
let cs = Nocrypto.Rng.generate 8 in
match Hex.of_cstruct cs with `Hex str -> str
in
let baseid = filename vm in
Fpath.(v (Filename.get_temp_dir_name ()) / "albatross" + baseid + random)
let rec fifo_exists file = let rec fifo_exists file =
try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with
@ -122,7 +116,6 @@ let create_bridge bname =
| x -> Error (`Msg ("unsupported operating system " ^ x)) | x -> Error (`Msg ("unsupported operating system " ^ x))
let prepare vm = let prepare vm =
let tmpfile = tmpfile vm in
(match vm.vmimage with (match vm.vmimage with
| `Ukvm_amd64, blob -> Ok blob | `Ukvm_amd64, blob -> Ok blob
| `Ukvm_amd64_compressed, blob -> | `Ukvm_amd64_compressed, blob ->
@ -131,8 +124,8 @@ let prepare vm =
| Error () -> Error (`Msg "failed to uncompress") | Error () -> Error (`Msg "failed to uncompress")
end end
| `Ukvm_arm64, _ -> Error (`Msg "no amd64 ukvm image found")) >>= fun image -> | `Ukvm_arm64, _ -> Error (`Msg "no amd64 ukvm image found")) >>= fun image ->
Bos.OS.File.write (image_fn tmpfile) (Cstruct.to_string image) >>= fun () -> Bos.OS.File.write (image_file vm) (Cstruct.to_string image) >>= fun () ->
let fifo = fifo_fn tmpfile in let fifo = fifo_file vm in
(match fifo_exists fifo with (match fifo_exists fifo with
| Ok true -> Ok () | Ok true -> Ok ()
| Ok false -> Error (`Msg ("file " ^ Fpath.to_string fifo ^ " exists and is not a fifo")) | Ok false -> Error (`Msg ("file " ^ Fpath.to_string fifo ^ " exists and is not a fifo"))
@ -146,12 +139,12 @@ let prepare vm =
create_tap b >>= fun tap -> create_tap b >>= fun tap ->
Ok (tap :: acc)) Ok (tap :: acc))
(Ok []) vm.network >>= fun taps -> (Ok []) vm.network >>= fun taps ->
Ok (tmpfile, List.rev taps) Ok (List.rev taps)
let shutdown vm = let shutdown vm =
(* same order as prepare! *) (* same order as prepare! *)
Bos.OS.File.delete (image_fn vm.tmpfile) >>= fun () -> Bos.OS.File.delete (image_file vm.config) >>= fun () ->
Bos.OS.File.delete (fifo_fn vm.tmpfile) >>= fun () -> Bos.OS.File.delete (fifo_file vm.config) >>= fun () ->
List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps
let cpuset cpu = let cpuset cpu =
@ -164,7 +157,7 @@ let cpuset cpu =
Ok ([ "taskset" ; "-c" ; cpustring ]) Ok ([ "taskset" ; "-c" ; cpustring ])
| x -> Error (`Msg ("unsupported operating system " ^ x)) | x -> Error (`Msg ("unsupported operating system " ^ x))
let exec dir vm tmpfile taps = let exec dir vm taps =
(* TODO: --net-mac=xx *) (* TODO: --net-mac=xx *)
let net = List.map (fun t -> "--net=" ^ t) taps in let net = List.map (fun t -> "--net=" ^ t) taps in
let argv = match vm.argv with None -> [] | Some xs -> xs in let argv = match vm.argv with None -> [] | Some xs -> xs in
@ -174,11 +167,14 @@ let exec dir vm tmpfile taps =
| _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin -> | _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin ->
cpuset vm.cpuid >>= fun cpuset -> cpuset vm.cpuid >>= fun cpuset ->
let mem = "--mem=" ^ string_of_int vm.requested_memory in 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_fn tmpfile) %% of_list argv) in let cmd =
Bos.Cmd.(of_list cpuset % p bin % mem %% of_list net %
"--" % p (image_file vm) %% of_list argv)
in
let line = Bos.Cmd.to_list cmd in let line = Bos.Cmd.to_list cmd in
let prog = try List.hd line with Failure _ -> failwith err_empty_line in let prog = try List.hd line with Failure _ -> failwith err_empty_line in
let line = Array.of_list line in let line = Array.of_list line in
let fifo = fifo_fn tmpfile in let fifo = fifo_file vm in
Logs.debug (fun m -> m "write fd for fifo %a" Fpath.pp fifo); Logs.debug (fun m -> m "write fd for fifo %a" Fpath.pp fifo);
write_fd_for_file fifo >>= fun stdout -> write_fd_for_file fifo >>= fun stdout ->
Logs.debug (fun m -> m "opened file descriptor!"); Logs.debug (fun m -> m "opened file descriptor!");
@ -188,7 +184,7 @@ let exec dir vm tmpfile taps =
Logs.debug (fun m -> m "created process %d: %a" pid Bos.Cmd.pp cmd) ; Logs.debug (fun m -> m "created process %d: %a" pid Bos.Cmd.pp cmd) ;
(* this should get rid of the vmimage from vmmd's memory! *) (* this should get rid of the vmimage from vmmd's memory! *)
let config = { vm with vmimage = (fst vm.vmimage, Cstruct.create 0) } in let config = { vm with vmimage = (fst vm.vmimage, Cstruct.create 0) } in
Ok { config ; cmd ; pid ; taps ; stdout ; tmpfile } Ok { config ; cmd ; pid ; taps ; stdout }
with with
Unix.Unix_error (e, _, _) -> Unix.Unix_error (e, _, _) ->
close_no_err stdout; close_no_err stdout;

4
src/vmm_commands.mli
View file

@ -4,11 +4,11 @@ open Rresult
open Vmm_core open Vmm_core
val prepare : vm_config -> (Fpath.t * string list, [> R.msg ]) result val prepare : vm_config -> (string list, [> R.msg ]) result
val shutdown : vm -> (unit, [> R.msg ]) result val shutdown : vm -> (unit, [> R.msg ]) result
val exec : Fpath.t -> vm_config -> Fpath.t -> string list -> (vm, [> R.msg ]) result val exec : Fpath.t -> vm_config -> string list -> (vm, [> R.msg ]) result
val destroy : vm -> unit val destroy : vm -> unit

9
src/vmm_core.ml
View file

@ -178,7 +178,7 @@ type vm_config = {
let fullname vm = vm.prefix @ [ vm.vname ] let fullname vm = vm.prefix @ [ vm.vname ]
let filename vm = string_of_id (fullname vm) let vm_id vm = string_of_id (fullname vm)
(* used for block devices *) (* used for block devices *)
let location vm = match vm.prefix with let location vm = match vm.prefix with
@ -222,14 +222,13 @@ type vm = {
cmd : Bos.Cmd.t ; cmd : Bos.Cmd.t ;
pid : int ; pid : int ;
taps : string list ; taps : string list ;
stdout : Unix.file_descr ; (* ringbuffer thingy *) stdout : Unix.file_descr (* ringbuffer thingy *)
tmpfile : Fpath.t
} }
let pp_vm ppf vm = let pp_vm ppf vm =
Fmt.pf ppf "pid %d@ taps %a cmdline %a tmpfile %a" Fmt.pf ppf "pid %d@ taps %a cmdline %a"
vm.pid Fmt.(list ~sep:(unit ", ") string) vm.taps vm.pid Fmt.(list ~sep:(unit ", ") string) vm.taps
Bos.Cmd.pp vm.cmd Fpath.pp vm.tmpfile Bos.Cmd.pp vm.cmd
let translate_tap vm tap = let translate_tap vm tap =
match List.filter (fun (t, _) -> tap = t) (List.combine vm.taps vm.config.network) with match List.filter (fun (t, _) -> tap = t) (List.combine vm.taps vm.config.network) with

108
src/vmm_engine.ml
View file

@ -7,12 +7,12 @@ open Vmm_core
open Rresult open Rresult
open R.Infix open R.Infix
type ('a, 'b) t = { type ('a, 'b, 'c) t = {
dir : Fpath.t ; dir : Fpath.t ;
cmp : 'b -> 'b -> bool ; cmp : 'b -> 'b -> bool ;
console_socket : 'a ; console_socket : 'a ;
console_counter : int ; console_counter : int ;
console_requests : (('a, 'b) t -> ('a, 'b) t * [ `Raw of 'a * string | `Tls of 'b * string ] list) IM.t ; console_requests : (('a, 'b, 'c) t -> ('a, 'b, 'c) t * [ `Raw of 'a * string | `Tls of 'b * string ] list) IM.t ;
console_attached : 'b String.Map.t ; (* vm_name -> socket *) console_attached : 'b String.Map.t ; (* vm_name -> socket *)
console_version : Vmm_wire.version ; console_version : Vmm_wire.version ;
stats_socket : 'a option ; stats_socket : 'a option ;
@ -30,6 +30,7 @@ type ('a, 'b) t = {
used_bridges : String.Set.t String.Map.t ; used_bridges : String.Set.t String.Map.t ;
(* TODO: used block devices (since each may only be active once) *) (* TODO: used block devices (since each may only be active once) *)
resources : Vmm_resources.t ; resources : Vmm_resources.t ;
tasks : 'c String.Map.t ;
crls : X509.CRL.c list ; crls : X509.CRL.c list ;
} }
@ -61,6 +62,7 @@ let init dir cmp console_socket stats_socket log_socket =
client_version = `WV0 ; client_version = `WV0 ;
used_bridges = String.Map.empty ; used_bridges = String.Map.empty ;
resources = Vmm_resources.empty ; resources = Vmm_resources.empty ;
tasks = String.Map.empty ;
crls crls
} }
@ -109,46 +111,20 @@ let handle_disconnect state t =
in in
{ state with console_attached ; console_counter ; log_attached }, out { state with console_attached ; console_counter ; log_attached }, out
let handle_create t prefix chain cert force = let handle_create t vm_config policies =
(* convert certificate to vm_config *)
Vmm_asn.vm_of_cert prefix cert >>= fun vm_config ->
Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ;
(* check whether vm with same name is already running *)
let full = fullname vm_config in let full = fullname vm_config in
(* get names and static resources *) (if Vmm_resources.exists t.resources full then
List.fold_left (fun acc ca ->
acc >>= fun acc ->
Vmm_asn.delegation_of_cert asn_version ca >>= fun res ->
let name = id ca in
Ok ((name, res) :: acc))
(Ok []) chain >>= fun res ->
(* check static policies *)
Logs.debug (fun m -> m "now checking static policies") ;
check_policies vm_config (List.map snd res) >>= fun () ->
(* may retract currently running vm to evaluate force-create! *)
(if force then
match Vmm_resources.find_vm t.resources full with
| None -> Ok (t.resources, None)
| Some vm ->
Vmm_resources.remove t.resources full vm >>= fun r -> Ok (r, Some vm)
else if Vmm_resources.exists t.resources full then
Error (`Msg "VM with same name is already running") Error (`Msg "VM with same name is already running")
else else
Ok (t.resources, None)) >>= fun (resources, vm) -> Ok ()) >>= fun () ->
(* check dynamic usage *)
Logs.debug (fun m -> m "now checking dynamic policies") ; Logs.debug (fun m -> m "now checking dynamic policies") ;
Vmm_resources.check_dynamic resources vm_config res >>= fun () -> Vmm_resources.check_dynamic t.resources vm_config policies >>= fun () ->
(* need to kill *)
(match vm with
| Some vm -> Vmm_commands.destroy vm
| None -> ()) ;
(* prepare VM: save VM image to disk, create fifo, ... *) (* prepare VM: save VM image to disk, create fifo, ... *)
Vmm_commands.prepare vm_config >>= fun (tmpfile, taps) -> Vmm_commands.prepare vm_config >>= fun taps ->
Logs.debug (fun m -> m "prepared vm %a" Fpath.pp tmpfile) ; Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
Ok (Fpath.basename tmpfile, Ok (fun t s ->
fun t s ->
(* actually execute the vm *) (* actually execute the vm *)
Vmm_commands.exec t.dir vm_config tmpfile taps >>= fun vm -> Vmm_commands.exec t.dir vm_config taps >>= fun vm ->
Logs.debug (fun m -> m "exec()ed vm") ; Logs.debug (fun m -> m "exec()ed vm") ;
Vmm_resources.insert t.resources full vm >>= fun resources -> Vmm_resources.insert t.resources full vm >>= fun resources ->
let used_bridges = let used_bridges =
@ -161,7 +137,7 @@ let handle_create t prefix chain cert force =
t.used_bridges vm_config.network taps t.used_bridges vm_config.network taps
in in
let t = { t with resources ; used_bridges } in let t = { t with resources ; used_bridges } in
let t, out = log t (Log.hdr prefix vm_config.vname, `VM_start (vm.pid, vm.taps, None)) in let t, out = log t (Log.hdr vm_config.prefix vm_config.vname, `VM_start (vm.pid, vm.taps, None)) in
let tls_out = Vmm_wire.success ~msg:"VM started" 0 t.client_version in let tls_out = Vmm_wire.success ~msg:"VM started" 0 t.client_version in
Ok (t, `Tls (s, tls_out) :: out, vm)) Ok (t, `Tls (s, tls_out) :: out, vm))
@ -192,7 +168,8 @@ let handle_shutdown t vm r =
t.used_bridges vm.config.network vm.taps t.used_bridges vm.config.network vm.taps
in in
let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version vm.pid in let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version vm.pid in
let t = { t with stats_counter = succ t.stats_counter ; resources ; used_bridges } in let tasks = String.Map.remove (vm_id vm.config) t.tasks in
let t = { t with stats_counter = succ t.stats_counter ; resources ; used_bridges ; tasks } in
let t, outs = log t (Log.hdr vm.config.prefix vm.config.vname, let t, outs = log t (Log.hdr vm.config.prefix vm.config.vname,
`VM_stop (vm.pid, r)) `VM_stop (vm.pid, r))
in in
@ -299,12 +276,13 @@ let handle_single_revocation t prefix serial =
(* also revoke all active sessions!? *) (* also revoke all active sessions!? *)
(* TODO: maybe we need a vmm_resources like structure for sessions as well!? *) (* TODO: maybe we need a vmm_resources like structure for sessions as well!? *)
let log_attached, kill = let log_attached, kill =
match String.Map.find (string_of_id prefix) t.log_attached with let pid = string_of_id prefix in
match String.Map.find pid t.log_attached with
| None -> t.log_attached, [] | None -> t.log_attached, []
| Some xs -> | Some xs ->
(* those where snd v = serial: drop *) (* those where snd v = serial: drop *)
let drop, keep = List.partition (fun (_, s) -> String.equal s id) xs in let drop, keep = List.partition (fun (_, s) -> String.equal s id) xs in
String.Map.add (string_of_id prefix) keep t.log_attached, drop String.Map.add pid keep t.log_attached, drop
in in
(* two things: (* two things:
1 revoked LEAF certs need to go (k = prefix, snd v = serial) [see above] 1 revoked LEAF certs need to go (k = prefix, snd v = serial) [see above]
@ -389,12 +367,50 @@ let handle_initial t s addr chain ca =
let initial_out = `Tls (s, Vmm_wire.Client.log login_hdr login_ev t.client_version) in let initial_out = `Tls (s, Vmm_wire.Client.log login_hdr login_ev t.client_version) in
Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms -> Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms ->
(if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then (if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then
let force = List.mem `Force_create perms in (* convert certificate to vm_config *)
handle_create t prefix chain leaf force >>= fun (file, cont) -> Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config ->
let cons = Vmm_wire.Console.add t.console_counter t.console_version file in Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ;
Ok ({ t with console_counter = succ t.console_counter }, (* get names and static resources *)
[ `Raw (t.console_socket, cons) ], List.fold_left (fun acc ca ->
`Create cont) acc >>= fun acc ->
Vmm_asn.delegation_of_cert asn_version ca >>= fun res ->
let name = id ca in
Ok ((name, res) :: acc))
(Ok []) chain >>= fun policies ->
(* check static policies *)
Logs.debug (fun m -> m "now checking static policies") ;
check_policies vm_config (List.map snd policies) >>= fun () ->
let t, task =
let force = List.mem `Force_create perms in
if force then
let fid = vm_id vm_config in
match String.Map.find fid t.tasks with
| None -> t, None
| Some task ->
let kill () =
match Vmm_resources.find_vm t.resources (fullname vm_config) with
| None ->
Logs.err (fun m -> m "found a task, but no vm for %a (%s)"
pp_id (fullname vm_config) fid)
| Some vm ->
Logs.debug (fun m -> m "killing %a now" pp_vm vm) ;
Vmm_commands.destroy vm
in
let tasks = String.Map.remove fid t.tasks in
({ t with tasks }, Some (kill, task))
else
t, None
in
let next t sleeper =
handle_create t vm_config policies >>= fun cont ->
let id = vm_id vm_config in
let cons = Vmm_wire.Console.add t.console_counter t.console_version id in
let tasks = String.Map.add id sleeper t.tasks in
Ok ({ t with console_counter = succ t.console_counter ; tasks },
[ `Raw (t.console_socket, cons) ],
cont)
in
Ok (t, [], `Create (task, next))
else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then
handle_revocation t s leaf chain ca prefix handle_revocation t s leaf chain ca prefix
else else

7
src/vmm_resources.ml
View file

@ -112,12 +112,7 @@ let insert m name v =
let remove m name vm = let remove m name vm =
let rec del m = function let rec del m = function
| [] -> Error (`Msg "should not happen: empty labels in remove") | [] -> Error (`Msg "should not happen: empty labels in remove")
| [l] -> | [l] -> Ok (String.Map.remove l m)
(match String.Map.find l m with
| None -> Ok m
| Some (Leaf vm') when vm'.pid = vm.pid -> Ok (String.Map.remove l m)
| Some (Leaf _) -> Ok m
| Some (Subtree _) -> Ok (String.Map.remove l m)) (* TODO: not sure about this case *)
| l::ls -> match String.Map.find l m with | l::ls -> match String.Map.find l m with
| None -> Error (`Msg "should not happen: found nothing in remove while still had some labels") | None -> Error (`Msg "should not happen: found nothing in remove while still had some labels")
| Some (Subtree (r, m')) -> | Some (Subtree (r, m')) ->