style: require lwt 3.0.0, fix warnings, disable 4 (fragile pattern matching) and 48 (implicit elimination of optional argument)

_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
 

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) ->

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 () =

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
 

opam

@@ -10,7 +10,7 @@ depends: [
   "ocamlfind" {build}
   "ocamlbuild" {build}
   "topkg" {build}
-  "lwt"
+  "lwt" {>= "3.0.0"}
   "ipaddr" {>= "2.2.0"}
   "hex"
   "cstruct"

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 () ->

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

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
 

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

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

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 () =

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 ();