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:
Hannes Mehnert 2018-04-03 22:58:31 +02:00
parent 54179f55fc
commit 7a4661b2e1
12 changed files with 36 additions and 34 deletions

2
_tags
View file

@ -1,5 +1,5 @@
true : bin_annot, safe_string, principal, color(always) 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) true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring duration cstruct)
"src" : include "src" : include

View file

@ -153,7 +153,7 @@ let jump _ file =
Sys.(set_signal sigpipe Signal_ignore) ; Sys.(set_signal sigpipe Signal_ignore) ;
Lwt_main.run Lwt_main.run
(let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in (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_unix.listen s 1 ;
let rec loop () = let rec loop () =
Lwt_unix.accept s >>= fun (cs, addr) -> Lwt_unix.accept s >>= fun (cs, addr) ->

View file

@ -121,7 +121,7 @@ let jump _ file sock =
Lwt_main.run Lwt_main.run
(Lwt_unix.openfile file Lwt_unix.[O_APPEND;O_CREAT;O_WRONLY] 0o600 >>= fun fd -> (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 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 ; Lwt_unix.listen s 1 ;
let ring = Vmm_ring.create () in let ring = Vmm_ring.create () in
let rec loop () = let rec loop () =

View file

@ -128,7 +128,7 @@ let server_socket port =
let s = socket PF_INET SOCK_STREAM 0 in let s = socket PF_INET SOCK_STREAM 0 in
set_close_on_exec s ; set_close_on_exec s ;
setsockopt s SO_REUSEADDR true ; 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 ; listen s 10 ;
Lwt.return s Lwt.return s

2
opam
View file

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

View file

@ -199,14 +199,14 @@ let crl_of_cert cert =
let vm_of_cert prefix cert = let vm_of_cert prefix cert =
req "cpuid" cert Oid.cpuid int_of_cstruct >>= fun cpuid -> 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.block_device string_of_cstruct >>= fun block_device ->
opt cert Oid.network strings_of_cstruct >>= fun network -> opt cert Oid.network strings_of_cstruct >>= fun network ->
req "vmimage" cert Oid.vmimage image_of_cstruct >>= fun vmimage -> req "vmimage" cert Oid.vmimage image_of_cstruct >>= fun vmimage ->
opt cert Oid.argv strings_of_cstruct >>= fun argv -> opt cert Oid.argv strings_of_cstruct >>= fun argv ->
let vname = id cert in let vname = id cert in
let network = match network with None -> [] | Some x -> x 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 = let permissions_of_cert version cert =
version_of_cert version cert >>= fun () -> version_of_cert version cert >>= fun () ->

View file

@ -46,7 +46,7 @@ let rec close fd =
try Unix.close fd with try Unix.close fd with
| Unix.Unix_error (Unix.EINTR, _, _) -> close fd | 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 (* own code starts here
(c) 2017 Hannes Mehnert, all rights reserved *) (c) 2017 Hannes Mehnert, all rights reserved *)
@ -173,7 +173,7 @@ let exec dir vm tmpfile taps =
| [_] -> Ok Fpath.(dir / "ukvm-bin.net") | [_] -> Ok Fpath.(dir / "ukvm-bin.net")
| _ -> 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.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_fn tmpfile) %% 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

View file

@ -147,7 +147,8 @@ let sub_bridges super sub =
| Some (`External (nam, supf, supl, gw, nm)), | Some (`External (nam, supf, supl, gw, nm)),
`External (nam', subf, subl, gw', nm') -> `External (nam', subf, subl, gw', nm') ->
String.compare nam nam' = 0 && nm = 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) | _ -> false)
sub sub
@ -169,7 +170,7 @@ type vm_config = {
prefix : id ; prefix : id ;
vname : string ; vname : string ;
cpuid : int ; cpuid : int ;
memory : int ; requested_memory : int ;
block_device : string option ; block_device : string option ;
network : string list ; network : string list ;
vmimage : vmtype * Cstruct.t ; vmimage : vmtype * Cstruct.t ;
@ -189,9 +190,9 @@ let pp_image ppf (typ, blob) =
let l = Cstruct.len blob in let l = Cstruct.len blob in
Fmt.pf ppf "%a: %d bytes" pp_vmtype typ l 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" 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.(option ~none:(unit "no") string) vm.block_device
Fmt.(list ~sep:(unit ", ") string) vm.network Fmt.(list ~sep:(unit ", ") string) vm.network
pp_image vm.vmimage pp_image vm.vmimage
@ -203,7 +204,7 @@ let good_bridge idxs nets =
let vm_matches_res (res : delegation) (vm : vm_config) = let vm_matches_res (res : delegation) (vm : vm_config) =
res.vms >= 1 && IS.mem vm.cpuid res.cpuids && res.vms >= 1 && IS.mem vm.cpuid res.cpuids &&
vm.memory <= res.memory && vm.requested_memory <= res.memory &&
good_bridge vm.network res.bridges good_bridge vm.network res.bridges
let check_policies vm res = let check_policies vm res =
@ -232,7 +233,7 @@ let pp_vm ppf vm =
Bos.Cmd.pp vm.cmd Fpath.pp vm.tmpfile Bos.Cmd.pp vm.cmd Fpath.pp vm.tmpfile
let translate_tap vm tap = 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 | [ (_, b) ] -> Some b
| _ -> None | _ -> None
@ -336,7 +337,7 @@ module Log = struct
name : string ; name : string ;
} }
let pp_hdr db ppf hdr = let pp_hdr db ppf (hdr : hdr) =
let name = translate_serial db hdr.name in let name = translate_serial db hdr.name in
Fmt.pf ppf "%a: %s" (Ptime.pp_human ~tz_offset_s:0 ()) hdr.ts name Fmt.pf ppf "%a: %s" (Ptime.pp_human ~tz_offset_s:0 ()) hdr.ts name

View file

@ -27,7 +27,7 @@ type ('a, 'b) t = {
client_version : Vmm_wire.version ; client_version : Vmm_wire.version ;
(* TODO: refine, maybe: (* TODO: refine, maybe:
bridges : (Macaddr.t String.Map.t * String.Set.t) String.Map.t ; *) 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) *) (* TODO: used block devices (since each may only be active once) *)
resources : Vmm_resources.t ; resources : Vmm_resources.t ;
crls : X509.CRL.c list ; 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_socket ; log_counter = 1 ; log_attached = String.Map.empty ;
log_version = `WV0 ; log_requests = IM.empty ; log_version = `WV0 ; log_requests = IM.empty ;
client_version = `WV0 ; client_version = `WV0 ;
bridges = String.Map.empty ; used_bridges = String.Map.empty ;
resources = Vmm_resources.empty ; resources = Vmm_resources.empty ;
crls crls
} }
@ -151,16 +151,16 @@ let handle_create t prefix chain cert force =
Vmm_commands.exec t.dir vm_config tmpfile taps >>= fun vm -> Vmm_commands.exec t.dir vm_config tmpfile 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 bridges = let used_bridges =
List.fold_left2 (fun b br ta -> List.fold_left2 (fun b br ta ->
let old = match String.Map.find br b with let old = match String.Map.find br b with
| None -> String.Set.empty | None -> String.Set.empty
| Some x -> x | Some x -> x
in in
String.Map.add br (String.Set.add ta old) b) String.Map.add br (String.Set.add ta old) b)
t.bridges vm_config.network taps t.used_bridges vm_config.network taps
in 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 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 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))
@ -182,17 +182,17 @@ let handle_shutdown t vm r =
Logs.warn (fun m -> m "%s while removing vm %a" e pp_vm vm) ; Logs.warn (fun m -> m "%s while removing vm %a" e pp_vm vm) ;
t.resources t.resources
in in
let bridges = let used_bridges =
List.fold_left2 (fun b br ta -> List.fold_left2 (fun b br ta ->
let old = match String.Map.find br b with let old = match String.Map.find br b with
| None -> String.Set.empty | None -> String.Set.empty
| Some x -> x | Some x -> x
in in
String.Map.add br (String.Set.remove ta old) b) 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 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 ; 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, 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

View file

@ -6,23 +6,25 @@ open Rresult.R.Infix
open Vmm_core open Vmm_core
type res_entry = { type res_entry = {
vms : int ; running_vms : int ;
memory : int ; used_memory : int ;
} }
let pp_res_entry ppf res = 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) = 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) = 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) = 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 = type entry =
| Leaf of vm | Leaf of vm

View file

@ -52,7 +52,7 @@ let jump _ file interval =
let interval = Duration.(to_f (of_sec interval)) in let interval = Duration.(to_f (of_sec interval)) in
Lwt_main.run Lwt_main.run
(let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in (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_unix.listen s 1 ;
Lwt.async (timer interval) ; Lwt.async (timer interval) ;
let rec loop () = let rec loop () =

View file

@ -45,8 +45,7 @@ let jump _ pids =
in in
t := st ; t := st ;
let pids = fst (List.split pid_taps) in let pids = fst (List.split pid_taps) in
Lwt_main.run (timer pids ()) ; `Ok (Lwt_main.run (timer pids ()))
`Ok ()
let setup_log style_renderer level = let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer (); Fmt_tty.setup_std_outputs ?style_renderer ();