style: require lwt 3.0.0, fix warnings, disable 4 (fragile pattern matching) and 48 (implicit elimination of optional argument)
This commit is contained in:
parent
54179f55fc
commit
7a4661b2e1
2
_tags
2
_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
|
||||
|
||||
|
|
|
@ -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) ->
|
||||
|
|
|
@ -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 () =
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
2
opam
2
opam
|
@ -10,7 +10,7 @@ depends: [
|
|||
"ocamlfind" {build}
|
||||
"ocamlbuild" {build}
|
||||
"topkg" {build}
|
||||
"lwt"
|
||||
"lwt" {>= "3.0.0"}
|
||||
"ipaddr" {>= "2.2.0"}
|
||||
"hex"
|
||||
"cstruct"
|
||||
|
|
|
@ -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 () ->
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 () =
|
||||
|
|
|
@ -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 ();
|
||||
|
|
Loading…
Reference in a new issue