diff --git a/src/stack-direct/tcpip_stack_direct.ml b/src/stack-direct/tcpip_stack_direct.ml index 111da71b6..e936413f6 100644 --- a/src/stack-direct/tcpip_stack_direct.ml +++ b/src/stack-direct/tcpip_stack_direct.ml @@ -129,7 +129,7 @@ module Make let t = { netif; ethif; arpv4; ipv4; icmpv4; tcpv4; udpv4; udpv4_listeners; tcpv4_listeners } in Log.info (fun f -> f "stack assembled: %a" pp t); - Lwt.ignore_result (listen t); + Lwt.async (fun () -> listen t); Lwt.return t let disconnect t = diff --git a/src/stack-unix/tcpip_stack_socket.ml b/src/stack-unix/tcpip_stack_socket.ml index 0e3c7821d..4e9351159 100644 --- a/src/stack-unix/tcpip_stack_socket.ml +++ b/src/stack-unix/tcpip_stack_socket.ml @@ -14,7 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt +open Lwt.Infix let src = Logs.Src.create "tcpip-stack-socket" ~doc:"Platform's native TCP/IP stack" module Log = (val Logs.src_log src : Logs.LOG) @@ -56,13 +56,13 @@ let ipv4 _ = None (* List of IP addresses to bind to *) let configure _t addrs = match addrs with - | [] -> return_unit - | [ip] when (Ipaddr.V4.compare Ipaddr.V4.any ip) = 0 -> return_unit + | [] -> Lwt.return_unit + | [ip] when (Ipaddr.V4.compare Ipaddr.V4.any ip) = 0 -> Lwt.return_unit | l -> let pp_iplist fmt l = Format.pp_print_list Ipaddr.V4.pp_hum fmt l in Log.warn (fun f -> f "Manager: sockets currently bind to all available IPs. IPs %a were specified, but this will be ignored" pp_iplist l); - return_unit + Lwt.return_unit let err_invalid_port p = Printf.sprintf "invalid port number (%d)" p @@ -71,28 +71,26 @@ let listen_udpv4 t ~port callback = raise (Invalid_argument (err_invalid_port port)) else (* FIXME: we should not ignore the result *) - ignore_result ( - Udpv4.get_udpv4_listening_fd t.udpv4 port - >>= fun fd -> + Lwt.async (fun () -> + Udpv4.get_udpv4_listening_fd t.udpv4 port >>= fun fd -> let buf = Cstruct.create 4096 in let rec loop () = - let continue () = - (* TODO cancellation *) - if true then loop () else return_unit in - Lwt_cstruct.recvfrom fd buf [] - >>= fun (len, sa) -> - let buf = Cstruct.sub buf 0 len in - begin match sa with - | Lwt_unix.ADDR_INET (addr, src_port) -> - let src = Ipaddr_unix.V4.of_inet_addr_exn addr in - let dst = Ipaddr.V4.any in (* TODO *) - callback ~src ~dst ~src_port buf - | _ -> return_unit - end >>= fun () -> - continue () + (* TODO cancellation *) + Lwt.catch (fun () -> + Lwt_cstruct.recvfrom fd buf [] >>= fun (len, sa) -> + let buf = Cstruct.sub buf 0 len in + (match sa with + | Lwt_unix.ADDR_INET (addr, src_port) -> + let src = Ipaddr_unix.V4.of_inet_addr_exn addr in + let dst = Ipaddr.V4.any in (* TODO *) + callback ~src ~dst ~src_port buf + | _ -> Lwt.return_unit)) + (fun exn -> + Log.warn (fun m -> m "exception %s in recvfrom" (Printexc.to_string exn)) ; + Lwt.return_unit) >>= fun () -> + loop () in - loop () - ) + loop ()) let listen_tcpv4 ?keepalive _t ~port callback = if port < 0 || port > 65535 then @@ -103,30 +101,30 @@ let listen_tcpv4 ?keepalive _t ~port callback = (* TODO: as elsewhere in the module, we bind all available addresses; it would be better not to do so if the user has requested it *) let interface = Ipaddr_unix.V4.to_inet_addr Ipaddr.V4.any in (* FIXME: we should not ignore the result *) - ignore_result ( - Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) - >>= fun () -> + Lwt.async (fun () -> + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) >>= fun () -> Lwt_unix.listen fd 10; + (* TODO cancellation *) let rec loop () = - let continue () = - (* TODO cancellation *) - if true then loop () else return_unit in - Lwt_unix.accept fd - >>= fun (afd, _) -> - ( match keepalive with - | None -> () - | Some { Mirage_protocols.Keepalive.after; interval; probes } -> - Tcp_socket_options.enable_keepalive ~fd:afd ~after ~interval ~probes ); - Lwt.async (fun () -> - Lwt.catch - (fun () -> callback afd) - (fun _ -> return_unit) - ); - return_unit - >>= fun () -> - continue () in - loop () - ) + Lwt.catch (fun () -> + Lwt_unix.accept fd >|= fun (afd, _) -> + (match keepalive with + | None -> () + | Some { Mirage_protocols.Keepalive.after; interval; probes } -> + Tcp_socket_options.enable_keepalive ~fd:afd ~after ~interval ~probes); + Lwt.async + (fun () -> + Lwt.catch + (fun () -> callback afd) + (fun exn -> + Log.warn (fun m -> m "error %s in callback" (Printexc.to_string exn)) ; + Lwt.return_unit))) + (fun exn -> + Log.warn (fun m -> m "error %s in accept" (Printexc.to_string exn)) ; + Lwt.return_unit) >>= fun () -> + loop () + in + loop ()) let listen _t = let t, _ = Lwt.task () in @@ -138,8 +136,7 @@ let connect ips udpv4 tcpv4 = let tcpv4_listeners = Hashtbl.create 7 in let t = { tcpv4; udpv4; udpv4_listeners; tcpv4_listeners } in Log.info (fun f -> f "Manager: configuring"); - configure t ips - >>= fun () -> - return t + configure t ips >|= fun () -> + t -let disconnect _ = return_unit +let disconnect _ = Lwt.return_unit diff --git a/src/tcp/segment.ml b/src/tcp/segment.ml index a02809dd9..20f509570 100644 --- a/src/tcp/segment.ml +++ b/src/tcp/segment.ml @@ -14,6 +14,8 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +[@@@ocaml.warning "-3"] + open Lwt.Infix let src = Logs.Src.create "segment" ~doc:"Mirage TCP Segment module" diff --git a/src/tcp/user_buffer.ml b/src/tcp/user_buffer.ml index 26b182aa9..0539c42d3 100644 --- a/src/tcp/user_buffer.ml +++ b/src/tcp/user_buffer.ml @@ -15,6 +15,8 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +[@@@ocaml.warning "-3"] + open Lwt.Infix let lwt_sequence_add_l s seq = diff --git a/test/test_checksums.ml b/test/test_checksums.ml index 6b2de2f44..11be4122a 100644 --- a/test/test_checksums.ml +++ b/test/test_checksums.ml @@ -62,7 +62,7 @@ let udp_ipv4_zero_checksum () = Udp_packet.Marshal.make_cstruct ~pseudoheader ~payload { src_port = 42; dst_port = 42 }; payload] in - let (ipv4_header', transport_packet) = unwrap_ipv4 packet in + let (_ipv4_header', transport_packet) = unwrap_ipv4 packet in Alcotest.(check bool) "UDP packets with zero checksums pass verification" true @@ verify_ipv4_udp ~ipv4_header ~transport_packet; diff --git a/test/test_deadlock.ml b/test/test_deadlock.ml index 64c8d8429..b9e09f764 100644 --- a/test/test_deadlock.ml +++ b/test/test_deadlock.ml @@ -61,12 +61,12 @@ struct type conn = M.NETIF.t - let get_stats t = + let get_stats _t = { Mirage_net.rx_pkts = 0l; rx_bytes = 0L; tx_pkts = 0l; tx_bytes = 0L; } - let reset_stats t = () + let reset_stats _t = () end let port = 10000 @@ -116,7 +116,7 @@ let test_digest netif1 netif2 = end ] in - TCPIP.listen_tcpv4 (TCPIP.tcpip client_stack) port + TCPIP.listen_tcpv4 (TCPIP.tcpip client_stack) ~port (fun flow -> Client_log.debug (fun f -> f "client got conn"); let rec consume () = @@ -128,7 +128,7 @@ let test_digest netif1 netif2 = TCPIP.TCPV4.write flow @@ Cstruct.of_string "thanks for all the fish" >>= fun _ -> TCPIP.TCPV4.close flow - | Ok (`Data data) -> + | Ok (`Data _data) -> (if Random.float 1.0 < 0.01 then Lwt_unix.sleep 0.01 else Lwt.return_unit) >>= fun () -> consume ()