Fix warnings, selectively re-enable -warn-error

opam

@@ -33,7 +33,7 @@ depends: [
   "result"
   "tar-format" {= "0.6.1"}
   "ipaddr"
-  "lwt" { < "3.0.0" }
+  "lwt" { >= "2.7.0" }
   "uwt" { >= "0.0.4" }
   "tcpip" { >= "2.8.0" & < "3.0.0" }
   "pcap-format"

repo/darwin/packages/local/slirp.local/opam

@@ -8,7 +8,7 @@ depends: [
   "result"
   "tar-format" {= "0.6.1"}
   "ipaddr"
-  "lwt" { < "3.0.0" }
+  "lwt" { >= "2.7.0" }
   "uwt" {>= "0.0.4"}
   "tcpip" { = "999" }
   "pcap-format"

src/bin/connect.ml

@@ -76,7 +76,6 @@ module Make_hvsock(Host: Sig.HOST) = struct
       let flow = F.connect fd in
       Lwt.return { idx; flow }
 
-  let getclientname _ = failwith "Hyper-V socket implementation lacks getsockname"
   let read_into t = F.read_into t.flow
   let read t = F.read t.flow
   let write t = F.write t.flow

src/bin/jbuild

@@ -5,4 +5,5 @@
      datakit-server.fs9p win-eventlog asl fd-send-recv
    ))
    (preprocess  no_preprocessing)
+   (flags (:standard -warn-error "+1..49-3" -w "A-4-41-42-44"))
 ))

src/bin/main.ml

@@ -19,7 +19,7 @@ module Log = (val Logs.src_log src : Logs.LOG)
 let _ =
   Printexc.register_printer (function
     | Unix.Unix_error(e, _, _) -> Some (Unix.error_message e)
-    | e -> None
+    | _ -> None
   )
 
 let log_exception_continue description f =
@@ -30,8 +30,6 @@ let log_exception_continue description f =
        Lwt.return ()
     )
 
-let default d = function None -> d | Some x -> x
-
 let ethernet_serviceid = "30D48B34-7D27-4B0B-AAAF-BBBED334DD59"
 let ports_serviceid = "0B95756A-9985-48AD-9470-78E060895BE7"
 
@@ -194,7 +192,7 @@ let start_port_forwarding port_control_url max_connections vsock_path =
     );
     Lwt.return_unit
 
-let main_t socket_url port_control_url introspection_url diagnostics_url max_connections vsock_path db_path db_branch dns hosts pcap host_names debug =
+let main_t socket_url port_control_url introspection_url diagnostics_url max_connections vsock_path db_path db_branch dns hosts host_names debug =
   (* Write to stdout if expicitly requested [debug = true] or if the environment
      variable DEBUG is set *)
   let env_debug = try ignore @@ Unix.getenv "DEBUG"; true with Not_found -> false in
@@ -262,17 +260,15 @@ let main_t socket_url port_control_url introspection_url diagnostics_url max_con
   let host_names = List.map Dns.Name.of_string @@ Astring.String.cuts ~sep:"," host_names in
 
   let hardcoded_configuration =
-    let never, _ = Lwt.task () in
-    let pcap = match pcap with None -> None | Some filename -> Some (filename, None) in
     let server_macaddr = Slirp.default_server_macaddr in
     let peer_ip = Ipaddr.V4.of_string_exn "192.168.65.2" in
     let local_ip = Ipaddr.V4.of_string_exn "192.168.65.1" in
     let client_uuids : Slirp.uuid_table = {
-        mutex = Lwt_mutex.create ();
+        Slirp.mutex = Lwt_mutex.create ();
         table = Hashtbl.create 50;
     } in
     let global_arp_table : Slirp.arp_table = {
-        mutex = Lwt_mutex.create ();
+        Slirp.mutex = Lwt_mutex.create ();
         table = [(local_ip, server_macaddr)];
     } in
     {
@@ -353,16 +349,16 @@ let main_t socket_url port_control_url introspection_url diagnostics_url max_con
       | None -> () );
     Lwt.return_unit
 
-let main socket_url port_control_url introspection_url diagnostics_url max_connections vsock_path db_path db_branch dns hosts pcap host_names debug =
+let main socket_url port_control_url introspection_url diagnostics_url max_connections vsock_path db_path db_branch dns hosts host_names debug =
   Host.Main.run
-    (main_t socket_url port_control_url introspection_url diagnostics_url max_connections vsock_path db_path db_branch dns hosts pcap host_names debug)
+    (main_t socket_url port_control_url introspection_url diagnostics_url max_connections vsock_path db_path db_branch dns hosts host_names debug)
 end
 
-let main socket port_control introspection_url diagnostics_url max_connections vsock_path db_path db_branch dns hosts pcap host_names select debug =
+let main socket port_control introspection_url diagnostics_url max_connections vsock_path db_path db_branch dns hosts host_names select debug =
   let module Use_lwt_unix = Main(Host_lwt_unix) in
   let module Use_uwt = Main(Host_uwt) in
   (if select then Use_lwt_unix.main else Use_uwt.main)
-    socket port_control introspection_url diagnostics_url max_connections vsock_path db_path db_branch dns hosts pcap host_names debug
+    socket port_control introspection_url diagnostics_url max_connections vsock_path db_path db_branch dns hosts host_names debug
 
 open Cmdliner
 
@@ -465,13 +461,6 @@ let hosts =
   in
   Arg.(value & opt string Hosts.default_etc_hosts_path doc)
 
-let pcap=
-  let doc =
-    Arg.info ~doc:
-      "Filename to write packet capture data to" ["pcap"]
-  in
-  Arg.(value & opt (some string) None doc)
-
 let host_names =
   let doc =
     Arg.info ~doc:
@@ -495,7 +484,7 @@ let command =
      `P "Terminates TCP/IP and UDP/IP connections from a client and proxy the\
          flows via userspace sockets"]
   in
-  Term.(pure main $ socket $ port_control_path $ introspection_path $ diagnostics_path $ max_connections $ vsock_path $ db_path $ db_branch $ dns $ hosts $ pcap $ host_names $ select $ debug),
+  Term.(pure main $ socket $ port_control_path $ introspection_path $ diagnostics_path $ max_connections $ vsock_path $ db_path $ db_branch $ dns $ hosts  $ host_names $ select $ debug),
   Term.info (Filename.basename Sys.argv.(0)) ~version:Depends.version ~doc ~man
 
 let () =

src/hostnet/capture.ml

@@ -175,7 +175,7 @@ module Make(Input: Sig.VMNET) = struct
   let record t bufs =
     try
       Hashtbl.iter
-        (fun name rule ->
+        (fun _ rule ->
           match Frame.parse bufs with
           | Result.Ok f -> if rule.predicate f then push rule bufs
           | Result.Error (`Msg m) -> failwith m
@@ -232,9 +232,9 @@ module Make(Input: Sig.VMNET) = struct
   let stop_capture _ =
     failwith "Capture.stop_capture unimplemented"
 
-  let get_client_uuid t =
+  let get_client_uuid _ =
     failwith "Capture.get_client_uuid unimplemented"
 
-  let get_client_macaddr t =
+  let get_client_macaddr _ =
     failwith "Capture.get_client_macaddr unimplemented"
 end

src/hostnet/cstructs.ml

@@ -33,7 +33,7 @@ let sub t off len =
   (* trim the length *)
   let rec trim acc ts remaining = match remaining, ts with
     | 0, _ -> List.rev acc
-    | n, [] -> err "invalid bounds in Cstructs.sub %a off=%d len=%d" pp_t t off len
+    | _, [] -> err "invalid bounds in Cstructs.sub %a off=%d len=%d" pp_t t off len
     | n, t :: ts ->
       let to_take = min (Cstruct.len t) n in
       (* either t is consumed and we only need ts, or t has data remaining in which

src/hostnet/dhcp.ml

@@ -30,7 +30,7 @@ module Make(Netif: V1_LWT.NETWORK) = struct
     | hd::tl -> List.fold_left (fun acc x -> if compare acc x > 0 then acc else x) hd tl
 
   (* given some MACs and IPs, construct a usable DHCP configuration *)
-  let make ~client_macaddr ~server_macaddr ~peer_ip ~highest_peer_ip ~local_ip ~extra_dns_ip
+  let make ~server_macaddr ~peer_ip ~highest_peer_ip ~local_ip ~extra_dns_ip
     ~get_domain_search ~get_domain_name netif =
     let open Dhcp_server.Config in
     (* FIXME: We need a DHCP range to make the DHCP server happy, even though we

src/hostnet/dhcp.mli

@@ -4,7 +4,7 @@
 module Make(Netif: V1_LWT.NETWORK): sig
   type t
 
-  val make: client_macaddr:Macaddr.t -> server_macaddr:Macaddr.t
+  val make: server_macaddr:Macaddr.t
     -> peer_ip: Ipaddr.V4.t -> highest_peer_ip: Ipaddr.V4.t option -> local_ip:Ipaddr.V4.t
     -> extra_dns_ip:Ipaddr.V4.t list -> get_domain_search:(unit -> string list)
     -> get_domain_name:(unit -> string)

src/hostnet/error.ml

@@ -1,14 +1,3 @@
-open Lwt.Infix
-
 type 'a t = ('a, [ `Msg of string ]) Hostnet_lwt_result.t
 
-module FromFlowError(Flow: V1_LWT.FLOW) = struct
-  let (>>=) m f = m >>= function
-    | `Eof -> Lwt.return (Result.Error (`Msg "Unexpected end of file"))
-    | `Error e -> Lwt.return (Result.Error (`Msg (Flow.error_message e)))
-    | `Ok x -> f x
-end
-
-let errorf fmt = Printf.ksprintf (fun s -> Lwt.return (Result.Error (`Msg s))) fmt
-
 module Infix = Hostnet_lwt_result.Infix

src/hostnet/filter.ml

@@ -107,10 +107,10 @@ module Make(Input: Sig.VMNET) = struct
   let of_fd ~client_macaddr_of_uuid:_ ~server_macaddr:_ ~mtu:_ =
     failwith "Filter.of_fd unimplemented"
 
-  let get_client_uuid t =
+  let get_client_uuid _ =
     failwith "Filter.get_client_uuid unimplemented"
 
-  let get_client_macaddr t =
+  let get_client_macaddr _ =
     failwith "Filter.get_client_macaddr unimplemented"
 
   let start_capture _ ?size_limit:_ _ =

src/hostnet/forward.ml

@@ -31,26 +31,14 @@ module Result = struct
 end
 
 module Int16 = struct
-  module M = struct
-    type t = int
-    let compare (a: t) (b: t) = Pervasives.compare a b
-  end
-  include M
-  module Map = Map.Make(M)
-  module Set = Set.Make(M)
+  type t = int
 end
 
 module Port = struct
-  module M = struct
-    type t = [
-      | `Tcp of Ipaddr.t * Int16.t
-      | `Udp of Ipaddr.t * Int16.t
-    ]
-    let compare = compare
-  end
-  include M
-  module Map = Map.Make(M)
-  module Set = Set.Make(M)
+  type t = [
+    | `Tcp of Ipaddr.t * Int16.t
+    | `Udp of Ipaddr.t * Int16.t
+  ]
 
   let to_string = function
     | `Tcp (addr, port) -> Printf.sprintf "tcp:%s:%d" (Ipaddr.to_string addr) port
@@ -85,8 +73,6 @@ type key = Port.t
 
 let get_key t = t.local
 
-module Map = Port.Map
-
 type context = string
 
 let to_string t = Printf.sprintf "%s:%s" (Port.to_string t.local) (Port.to_string t.remote_port)

src/hostnet/host_lwt_unix.ml

@@ -37,7 +37,7 @@ exception Too_many_connections
 let connection_table = Hashtbl.create 511
 let connections () =
   let xs = Hashtbl.fold (fun _ c acc -> c :: acc) connection_table [] in
-  Vfs.File.ro_of_string @@ String.concat "\n" xs
+  Vfs.File.ro_of_string (String.concat "\n" xs)
 let register_connection_no_limit description =
   let idx = next_connection_idx () in
   Hashtbl.replace connection_table idx description;
@@ -87,7 +87,8 @@ let unix_bind_one ?(description="") pf ty ip port =
   Lwt.catch
     (fun () ->
       Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true;
-      Lwt_unix.bind fd addr;
+      Lwt_unix.Versioned.bind_2 fd addr
+      >>= fun () ->
       Lwt.return (idx, fd)
     ) (fun e ->
       Lwt_unix.close fd
@@ -168,7 +169,8 @@ module Datagram = struct
         | Ipaddr.V6 _ -> Lwt_unix.PF_INET6, Unix.inet6_addr_any in
       let fd = Lwt_unix.socket pf Lwt_unix.SOCK_DGRAM 0 in
       (* Win32 requires all sockets to be bound however macOS and Linux don't *)
-      (try Lwt_unix.bind fd (Lwt_unix.ADDR_INET(addr, 0)) with _ -> ());
+      Lwt.catch (fun () -> Lwt_unix.Versioned.bind_2 fd (Lwt_unix.ADDR_INET(addr, 0))) (fun _ -> Lwt.return_unit)
+      >>= fun () ->
       let sockaddr = sockaddr_of_address address in
       Lwt.return (Result.Ok (of_fd ~idx ~description ?read_buffer_size sockaddr address fd))
 
@@ -629,7 +631,8 @@ module Stream = struct
         let s = Lwt_unix.socket Lwt_unix.PF_UNIX Lwt_unix.SOCK_STREAM 0 in
         Lwt.catch
           (fun () ->
-            Lwt_unix.bind s (Lwt_unix.ADDR_UNIX path);
+            Lwt_unix.Versioned.bind_2 s (Lwt_unix.ADDR_UNIX path)
+            >>= fun () ->
             Lwt.return (make ~path [ idx, s ])
           ) (fun e ->
             Lwt_unix.close s

src/hostnet/host_uwt.ml

@@ -71,7 +71,7 @@ module Sockets = struct
   let connection_table = Hashtbl.create 511
   let connections () =
     let xs = Hashtbl.fold (fun _ c acc -> c :: acc) connection_table [] in
-    Vfs.File.ro_of_string @@ String.concat "\n" xs
+    Vfs.File.ro_of_string (String.concat "\n" xs)
   let register_connection_no_limit description =
     let idx = next_connection_idx () in
     Hashtbl.replace connection_table idx description;

src/hostnet/hostnet_dns.ml

@@ -31,7 +31,7 @@ module Policy(Files: Sig.FILES) = struct
   let config_of_ips ips =
     let open Dns_forward.Config in
     let servers = Server.Set.of_list (
-      List.map (fun (ip, port) ->
+      List.map (fun (ip, _) ->
         { Server.address = { Address.ip; port = 53 }; zones = Domain.Set.empty;
         timeout_ms = Some 2000; order = 0 }
       ) ips) in
@@ -162,11 +162,11 @@ module Make(Ip: V1_LWT.IPV4) (Udp:V1_LWT.UDPV4) (Tcp:V1_LWT.TCPV4) (Socket: Sig.
   let set_recorder r = recorder := Some r
 
   let destroy = function
-    | { resolver = Upstream { dns_tcp_resolver; dns_udp_resolver } } ->
+    | { resolver = Upstream { dns_tcp_resolver; dns_udp_resolver; _ }; _ } ->
       Dns_tcp_resolver.destroy dns_tcp_resolver
       >>= fun () ->
       Dns_udp_resolver.destroy dns_udp_resolver
-    | { resolver = Host } ->
+    | { resolver = Host; _ } ->
       Lwt.return_unit
 
   let record_udp ~source_ip ~source_port ~dest_ip ~dest_port bufs =
@@ -212,12 +212,6 @@ module Make(Ip: V1_LWT.IPV4) (Udp:V1_LWT.UDPV4) (Tcp:V1_LWT.TCPV4) (Socket: Sig.
     | None ->
       () (* nowhere to log packet *)
 
-  let try_host_resolver question =
-    D.resolve question
-    >>= function
-    | [] -> Lwt.return None
-    | x -> Lwt.return (Some x)
-
   let create ~local_address ~host_names =
     let local_ip = local_address.Dns_forward.Config.Address.ip in
     Log.info (fun f -> f "DNS names %s will map to local IP %s" (String.concat ", " @@ List.map Dns.Name.to_string host_names) (Ipaddr.to_string local_ip));
@@ -247,6 +241,7 @@ module Make(Ip: V1_LWT.IPV4) (Udp:V1_LWT.UDPV4) (Tcp:V1_LWT.TCPV4) (Socket: Sig.
       Lwt.return { local_ip; host_names; resolver = Host }
 
   let answer t is_tcp buffer =
+    let open Dns.Packet in
     let len = Cstruct.len buffer in
     let buf = Dns.Buf.of_cstruct buffer in
     match Dns.Protocol.Server.parse (Dns.Buf.sub buf 0 len) with
@@ -303,7 +298,7 @@ module Make(Ip: V1_LWT.IPV4) (Udp:V1_LWT.UDPV4) (Tcp:V1_LWT.TCPV4) (Socket: Sig.
     | None -> Printf.sprintf "Unparsable DNS packet length %d" len
     | Some request -> Dns.Packet.to_string request
 
-  let handle_udp ~t ~udp ~src ~dst ~src_port buf =
+  let handle_udp ~t ~udp ~src ~dst:_ ~src_port buf =
     answer t false buf
     >>= function
     | Result.Error (`Msg m) ->
@@ -314,7 +309,7 @@ module Make(Ip: V1_LWT.IPV4) (Udp:V1_LWT.UDPV4) (Tcp:V1_LWT.TCPV4) (Socket: Sig.
 
   let handle_tcp ~t =
     (* FIXME: need to record the upstream request *)
-    let listeners port =
+    let listeners _ =
       Log.debug (fun f -> f "DNS TCP handshake complete");
       Some (fun flow ->
         let packets = Dns_tcp_framing.connect flow in

src/hostnet/hosts.ml

@@ -24,7 +24,7 @@ let of_string txt =
         if line = "" then acc else begin
           let line = match String.cut ~sep:"#" line with
             | None -> line
-            | Some (important, comment) -> important in
+            | Some (important, _) -> important in
           let whitespace = function
             | ' ' | '\n' | '\011' | '\012' | '\r' | '\t' -> true
             | _ -> false in

src/hostnet/jbuild

@@ -11,4 +11,5 @@
    ))
    (c_names (stubs_utils))
    (wrapped false)
+   (flags (:standard -warn-error "+1..49-3" -w "A-4-41-42-44"))
 ))

src/hostnet/mux.ml

@@ -67,7 +67,7 @@ module Make(Netif: V1_LWT.NETWORK) = struct
         (fun ip t acc ->
           Printf.sprintf "%s last_active_time = %.1f" (Ipaddr.V4.to_string ip) t.last_active_time :: acc
         ) t.rules [] in
-    Vfs.File.ro_of_string @@ String.concat "\n" xs
+    Vfs.File.ro_of_string (String.concat "\n" xs)
 
   let remove t rule =
     Log.debug (fun f -> f "removing switch port for %s" (Ipaddr.V4.to_string rule));
@@ -77,7 +77,7 @@ module Make(Netif: V1_LWT.NETWORK) = struct
     (* Does the packet match any of our rules? *)
     let open Frame in
     match parse [ buf ] with
-    | Ok (Ethernet { payload = Ipv4 { dst } }) ->
+    | Ok (Ethernet { payload = Ipv4 { dst; _ }; _ }) ->
       if RuleMap.mem dst t.rules then begin
         let port = RuleMap.find dst t.rules in
         port.last_active_time <- Unix.gettimeofday ();