diff --git a/_tags b/_tags index 4253201..26fe009 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ true : bin_annot, safe_string, principal, color(always) -true : warn(+A-44) +true : warn(+A-4-44-48) true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring duration cstruct) "src" : include diff --git a/app/vmm_console.ml b/app/vmm_console.ml index eba47b1..94e6e91 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -153,7 +153,7 @@ let jump _ file = Sys.(set_signal sigpipe Signal_ignore) ; Lwt_main.run (let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in - Lwt_unix.(Versioned.bind_2 s (ADDR_UNIX file)) >>= fun () -> + Lwt_unix.(bind s (ADDR_UNIX file)) >>= fun () -> Lwt_unix.listen s 1 ; let rec loop () = Lwt_unix.accept s >>= fun (cs, addr) -> diff --git a/app/vmm_log.ml b/app/vmm_log.ml index 4bc3af8..6e240a0 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -121,7 +121,7 @@ let jump _ file sock = Lwt_main.run (Lwt_unix.openfile file Lwt_unix.[O_APPEND;O_CREAT;O_WRONLY] 0o600 >>= fun fd -> let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in - Lwt_unix.(Versioned.bind_2 s (ADDR_UNIX sock)) >>= fun () -> + Lwt_unix.(bind s (ADDR_UNIX sock)) >>= fun () -> Lwt_unix.listen s 1 ; let ring = Vmm_ring.create () in let rec loop () = diff --git a/app/vmmd.ml b/app/vmmd.ml index f4cda54..39b1921 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -128,7 +128,7 @@ let server_socket port = let s = socket PF_INET SOCK_STREAM 0 in set_close_on_exec s ; setsockopt s SO_REUSEADDR true ; - Versioned.bind_2 s (ADDR_INET (Unix.inet_addr_any, port)) >>= fun () -> + bind s (ADDR_INET (Unix.inet_addr_any, port)) >>= fun () -> listen s 10 ; Lwt.return s diff --git a/opam b/opam index 3ace94e..1a9aa72 100644 --- a/opam +++ b/opam @@ -10,7 +10,7 @@ depends: [ "ocamlfind" {build} "ocamlbuild" {build} "topkg" {build} - "lwt" + "lwt" {>= "3.0.0"} "ipaddr" {>= "2.2.0"} "hex" "cstruct" diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index da067e0..8f38f34 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -199,14 +199,14 @@ let crl_of_cert cert = let vm_of_cert prefix cert = req "cpuid" cert Oid.cpuid int_of_cstruct >>= fun cpuid -> - req "memory" cert Oid.memory int_of_cstruct >>= fun memory -> + req "memory" cert Oid.memory int_of_cstruct >>= fun requested_memory -> opt cert Oid.block_device string_of_cstruct >>= fun block_device -> opt cert Oid.network strings_of_cstruct >>= fun network -> req "vmimage" cert Oid.vmimage image_of_cstruct >>= fun vmimage -> opt cert Oid.argv strings_of_cstruct >>= fun argv -> let vname = id cert in let network = match network with None -> [] | Some x -> x in - Ok { prefix ; vname ; cpuid ; memory ; block_device ; network ; vmimage ; argv } + Ok { prefix ; vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } let permissions_of_cert version cert = version_of_cert version cert >>= fun () -> diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index 7830e0a..8d2c88d 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -46,7 +46,7 @@ let rec close fd = try Unix.close fd with | Unix.Unix_error (Unix.EINTR, _, _) -> close fd -let close_no_err fd = try close fd with e -> () +let close_no_err fd = try close fd with _ -> () (* own code starts here (c) 2017 Hannes Mehnert, all rights reserved *) @@ -173,7 +173,7 @@ let exec dir vm tmpfile taps = | [_] -> Ok Fpath.(dir / "ukvm-bin.net") | _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin -> cpuset vm.cpuid >>= fun cpuset -> - let mem = "--mem=" ^ string_of_int vm.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 line = Bos.Cmd.to_list cmd in let prog = try List.hd line with Failure _ -> failwith err_empty_line in diff --git a/src/vmm_core.ml b/src/vmm_core.ml index fa17695..9bd2a53 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -147,7 +147,8 @@ let sub_bridges super sub = | Some (`External (nam, supf, supl, gw, nm)), `External (nam', subf, subl, gw', nm') -> String.compare nam nam' = 0 && nm = nm' && - Ipaddr.V4.compare supf subf <= 0 && Ipaddr.V4.compare supl subl >= 0 + Ipaddr.V4.compare supf subf <= 0 && Ipaddr.V4.compare supl subl >= 0 && + Ipaddr.V4.compare gw gw' = 0 | _ -> false) sub @@ -169,7 +170,7 @@ type vm_config = { prefix : id ; vname : string ; cpuid : int ; - memory : int ; + requested_memory : int ; block_device : string option ; network : string list ; vmimage : vmtype * Cstruct.t ; @@ -189,9 +190,9 @@ let pp_image ppf (typ, blob) = let l = Cstruct.len blob in Fmt.pf ppf "%a: %d bytes" pp_vmtype typ l -let pp_vm_config ppf vm = +let pp_vm_config ppf (vm : vm_config) = Fmt.pf ppf "%s cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a" - vm.vname vm.cpuid vm.memory + vm.vname vm.cpuid vm.requested_memory Fmt.(option ~none:(unit "no") string) vm.block_device Fmt.(list ~sep:(unit ", ") string) vm.network pp_image vm.vmimage @@ -203,7 +204,7 @@ let good_bridge idxs nets = let vm_matches_res (res : delegation) (vm : vm_config) = res.vms >= 1 && IS.mem vm.cpuid res.cpuids && - vm.memory <= res.memory && + vm.requested_memory <= res.memory && good_bridge vm.network res.bridges let check_policies vm res = @@ -232,7 +233,7 @@ let pp_vm ppf vm = Bos.Cmd.pp vm.cmd Fpath.pp vm.tmpfile let translate_tap vm tap = - match List.filter (fun (t, b) -> 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 | [ (_, b) ] -> Some b | _ -> None @@ -336,7 +337,7 @@ module Log = struct name : string ; } - let pp_hdr db ppf hdr = + let pp_hdr db ppf (hdr : hdr) = let name = translate_serial db hdr.name in Fmt.pf ppf "%a: %s" (Ptime.pp_human ~tz_offset_s:0 ()) hdr.ts name diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index a96de60..a403dff 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -27,7 +27,7 @@ type ('a, 'b) t = { client_version : Vmm_wire.version ; (* TODO: refine, maybe: bridges : (Macaddr.t String.Map.t * String.Set.t) String.Map.t ; *) - 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) *) resources : Vmm_resources.t ; crls : X509.CRL.c list ; @@ -59,7 +59,7 @@ let init dir cmp console_socket stats_socket log_socket = log_socket ; log_counter = 1 ; log_attached = String.Map.empty ; log_version = `WV0 ; log_requests = IM.empty ; client_version = `WV0 ; - bridges = String.Map.empty ; + used_bridges = String.Map.empty ; resources = Vmm_resources.empty ; crls } @@ -151,16 +151,16 @@ let handle_create t prefix chain cert force = Vmm_commands.exec t.dir vm_config tmpfile taps >>= fun vm -> Logs.debug (fun m -> m "exec()ed vm") ; Vmm_resources.insert t.resources full vm >>= fun resources -> - let bridges = + 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.bridges vm_config.network taps + t.used_bridges vm_config.network taps in - let t = { t with resources ; 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 tls_out = Vmm_wire.success ~msg:"VM started" 0 t.client_version in Ok (t, `Tls (s, tls_out) :: out, vm)) @@ -182,17 +182,17 @@ let handle_shutdown t vm r = Logs.warn (fun m -> m "%s while removing vm %a" e pp_vm vm) ; t.resources in - let bridges = + 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.remove ta old) b) - t.bridges vm.config.network vm.taps + t.used_bridges vm.config.network vm.taps 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 ; bridges } in + let t = { t with stats_counter = succ t.stats_counter ; resources ; used_bridges } in let t, outs = log t (Log.hdr vm.config.prefix vm.config.vname, `VM_stop (vm.pid, r)) in diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index 298d851..47135b2 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -6,23 +6,25 @@ open Rresult.R.Infix open Vmm_core type res_entry = { - vms : int ; - memory : int ; + running_vms : int ; + used_memory : int ; } let pp_res_entry ppf res = - Fmt.pf ppf "%d vms %d memory" res.vms res.memory + Fmt.pf ppf "%d vms %d memory" res.running_vms res.used_memory -let empty_res = { vms = 0 ; memory = 0 } +let empty_res = { running_vms = 0 ; used_memory = 0 } let check_resource (policy : delegation) (vm : vm_config) (res : res_entry) = - succ res.vms <= policy.vms && res.memory + vm.memory <= policy.memory + succ res.running_vms <= policy.vms && res.used_memory + vm.requested_memory <= policy.memory let add (vm : vm) (res : res_entry) = - { vms = succ res.vms ; memory = vm.config.memory + res.memory } + { running_vms = succ res.running_vms ; + used_memory = vm.config.requested_memory + res.used_memory } let rem (vm : vm) (res : res_entry) = - { vms = pred res.vms ; memory = res.memory - vm.config.memory } + { running_vms = pred res.running_vms ; + used_memory = res.used_memory - vm.config.requested_memory } type entry = | Leaf of vm diff --git a/stats/vmm_stats_lwt.ml b/stats/vmm_stats_lwt.ml index 6b66a46..1bcadac 100644 --- a/stats/vmm_stats_lwt.ml +++ b/stats/vmm_stats_lwt.ml @@ -52,7 +52,7 @@ let jump _ file interval = let interval = Duration.(to_f (of_sec interval)) in Lwt_main.run (let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in - Lwt_unix.(Versioned.bind_2 s (ADDR_UNIX file)) >>= fun () -> + Lwt_unix.(bind s (ADDR_UNIX file)) >>= fun () -> Lwt_unix.listen s 1 ; Lwt.async (timer interval) ; let rec loop () = diff --git a/stats/vmm_stats_once.ml b/stats/vmm_stats_once.ml index 629b20e..ff37245 100644 --- a/stats/vmm_stats_once.ml +++ b/stats/vmm_stats_once.ml @@ -45,8 +45,7 @@ let jump _ pids = in t := st ; let pids = fst (List.split pid_taps) in - Lwt_main.run (timer pids ()) ; - `Ok () + `Ok (Lwt_main.run (timer pids ())) let setup_log style_renderer level = Fmt_tty.setup_std_outputs ?style_renderer ();