From 8d550ddfb9d2721a5a6cb4e643814a48bd86ec64 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 11 Sep 2020 16:56:23 +0200 Subject: [PATCH 01/18] move Tcpip_stack_socket to Tcpip_stack_socket.V4 provide Tcpip_stack_socket.V6 implementing Mirage_stack.V6 --- src/stack-unix/dune | 4 +- src/stack-unix/ipv4_socket.ml | 2 +- src/stack-unix/ipv6_socket.ml | 19 +- src/stack-unix/tcpip_stack_socket.ml | 310 +++++++++++++++++--------- src/stack-unix/tcpip_stack_socket.mli | 20 +- src/stack-unix/udpv6_socket.ml | 22 +- test/test_socket.ml | 2 +- 7 files changed, 241 insertions(+), 138 deletions(-) diff --git a/src/stack-unix/dune b/src/stack-unix/dune index a3b111376..f66622994 100644 --- a/src/stack-unix/dune +++ b/src/stack-unix/dune @@ -67,5 +67,5 @@ (instrumentation (backend bisect_ppx)) (libraries lwt.unix cstruct-lwt ipaddr.unix logs tcpip.tcpv4-socket - tcpip.udpv4-socket tcpip.ipv4 tcpip.ipv6 tcpip.icmpv4 mirage-protocols - mirage-stack)) + tcpip.udpv4-socket tcpip.ipv4 tcpip.tcpv6-socket tcpip.udpv6-socket + tcpip.ipv6 tcpip.icmpv4 mirage-protocols mirage-stack)) diff --git a/src/stack-unix/ipv4_socket.ml b/src/stack-unix/ipv4_socket.ml index 06616fd79..77e387f69 100644 --- a/src/stack-unix/ipv4_socket.ml +++ b/src/stack-unix/ipv4_socket.ml @@ -34,6 +34,6 @@ let connect _ = return_unit let input _ ~tcp:_ ~udp:_ ~default:_ _ = return_unit let write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ = fail (Failure "Not implemented") -let get_ip _ = [Ipaddr.V4.of_string_exn "0.0.0.0"] +let get_ip _ = [Ipaddr.V4.any] let src _ ~dst:_ = raise (Failure "Not implemented") let pseudoheader _ ?src:_ _ _ _ = raise (Failure "Not implemented") diff --git a/src/stack-unix/ipv6_socket.ml b/src/stack-unix/ipv6_socket.ml index ea8b00b40..4300ca7b4 100644 --- a/src/stack-unix/ipv6_socket.ml +++ b/src/stack-unix/ipv6_socket.ml @@ -17,15 +17,16 @@ open Lwt -type id = string -type ip = unit type t = unit type +'a io = 'a Lwt.t -type error = [ `Unimplemented | `Unknown of string ] +type error = Mirage_protocols.Ip.error type ipaddr = Ipaddr.V6.t type buffer = Cstruct.t type callback = src:ipaddr -> dst:ipaddr -> buffer -> unit io +let pp_error = Mirage_protocols.Ip.pp_error +let pp_ipaddr = Ipaddr.V6.pp + let mtu _ = 1500 - Ipv6_wire.sizeof_ipv6 let id _ = () @@ -33,14 +34,8 @@ let disconnect () = return_unit let connect () = return_unit let input _ ~tcp:_ ~udp:_ ~default:_ _ = return_unit -let allocate_frame _ ~dst:_ ~proto:_ = raise (Failure "Not implemented") -let write _ _ _ = fail (Failure "Not implemented") -let writev _ _ _ = fail (Failure "Not implemented") - -let get_ip _ = Ipaddr.V6.of_string_exn "::" -let set_ip _ _ = fail (Failure "Not implemented") -let get_ip_gateways _ = raise (Failure "Not implemented") -let set_ip_gateways _ _ = fail (Failure "Not implemented") +let write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ = fail (Failure "Not implemented") -let checksum _ _ = raise (Failure "Not implemented") +let get_ip _ = [Ipaddr.V6.unspecified] let src _ ~dst:_ = raise (Failure "Not implemented") +let pseudoheader _ ?src:_ _ _ _ = raise (Failure "Not implemented") diff --git a/src/stack-unix/tcpip_stack_socket.ml b/src/stack-unix/tcpip_stack_socket.ml index 94b909e79..8707c2f6c 100644 --- a/src/stack-unix/tcpip_stack_socket.ml +++ b/src/stack-unix/tcpip_stack_socket.ml @@ -19,112 +19,204 @@ 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) -type socket_ipv4_input = unit Lwt.t - -module type UDPV4_SOCKET = Mirage_protocols.UDP - with type ipinput = socket_ipv4_input - -module type TCPV4_SOCKET = Mirage_protocols.TCP - with type ipinput = socket_ipv4_input - -module Tcpv4 = Tcpv4_socket -module Udpv4 = Udpv4_socket - -module TCPV4 = Tcpv4_socket -module UDPV4 = Udpv4_socket -module IPV4 = Ipv4_socket - -type t = { - udpv4 : Udpv4.t; - tcpv4 : Tcpv4.t; -} - -let udpv4 { udpv4; _ } = udpv4 -let tcpv4 { tcpv4; _ } = tcpv4 -let ipv4 _ = None - -(* List of IP addresses to bind to *) -let configure _t addrs = - match addrs with - | [] -> 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 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); - Lwt.return_unit - -let err_invalid_port p = Printf.sprintf "invalid port number (%d)" p - -let listen_udpv4 t ~port callback = - if port < 0 || port > 65535 then - raise (Invalid_argument (err_invalid_port port)) - else - (* FIXME: we should not ignore the result *) - Lwt.async (fun () -> - Udpv4.get_udpv4_listening_fd t.udpv4 port >>= fun fd -> - let buf = Cstruct.create 4096 in - let rec loop () = - (* 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 ()) - -let listen_tcpv4 ?keepalive _t ~port callback = - if port < 0 || port > 65535 then - raise (Invalid_argument (err_invalid_port port)) - else - let fd = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in - Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; - (* 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 *) - Lwt.async (fun () -> - Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) >>= fun () -> - Lwt_unix.listen fd 10; - (* TODO cancellation *) - let rec 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 - t (* TODO cancellation *) - -let connect ips udpv4 tcpv4 = - Log.info (fun f -> f "Manager: connect"); - let t = { tcpv4; udpv4 } in - Log.info (fun f -> f "Manager: configuring"); - configure t ips >|= fun () -> - t - -let disconnect _ = Lwt.return_unit +module V4 = struct + module TCPV4 = Tcpv4_socket + module UDPV4 = Udpv4_socket + module IPV4 = Ipv4_socket + + type t = { + udpv4 : UDPV4.t; + tcpv4 : TCPV4.t; + } + + let udpv4 { udpv4; _ } = udpv4 + let tcpv4 { tcpv4; _ } = tcpv4 + let ipv4 _ = None + + (* List of IP addresses to bind to *) + let configure _t addrs = + match addrs with + | [] -> 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 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); + Lwt.return_unit + + let err_invalid_port p = Printf.sprintf "invalid port number (%d)" p + + let listen_udpv4 t ~port callback = + if port < 0 || port > 65535 then + raise (Invalid_argument (err_invalid_port port)) + else + (* FIXME: we should not ignore the result *) + Lwt.async (fun () -> + UDPV4.get_udpv4_listening_fd t.udpv4 port >>= fun fd -> + let buf = Cstruct.create 4096 in + let rec loop () = + (* 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 ()) + + let listen_tcpv4 ?keepalive _t ~port callback = + if port < 0 || port > 65535 then + raise (Invalid_argument (err_invalid_port port)) + else + let fd = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in + Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; + (* 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 *) + Lwt.async (fun () -> + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) >>= fun () -> + Lwt_unix.listen fd 10; + (* TODO cancellation *) + let rec 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 + t (* TODO cancellation *) + + let connect ips udpv4 tcpv4 = + Log.info (fun f -> f "Manager: connect"); + let t = { tcpv4; udpv4 } in + Log.info (fun f -> f "Manager: configuring"); + configure t ips >|= fun () -> + t + + let disconnect _ = Lwt.return_unit +end + +module V6 = struct + module TCP = Tcpv6_socket + module UDP = Udpv6_socket + module IP = Ipv6_socket + + type t = { + udp : UDP.t; + tcp : TCP.t; + } + + let udp { udp; _ } = udp + let tcp { tcp; _ } = tcp + let ip _ = () + + let err_invalid_port p = Printf.sprintf "invalid port number (%d)" p + + let listen_udp t ~port callback = + if port < 0 || port > 65535 then + raise (Invalid_argument (err_invalid_port port)) + else + (* FIXME: we should not ignore the result *) + Lwt.async (fun () -> + UDP.get_udpv6_listening_fd t.udp port >>= fun fd -> + let buf = Cstruct.create 4096 in + let rec loop () = + (* 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.V6.of_inet_addr_exn addr in + let dst = Ipaddr.V6.unspecified 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 ()) + + let listen_tcp ?keepalive _t ~port callback = + if port < 0 || port > 65535 then + raise (Invalid_argument (err_invalid_port port)) + else + let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in + Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; + (* 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.V6.to_inet_addr Ipaddr.V6.unspecified in + (* FIXME: we should not ignore the result *) + Lwt.async (fun () -> + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) >>= fun () -> + Lwt_unix.listen fd 10; + (* TODO cancellation *) + let rec 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 + t (* TODO cancellation *) + + (* List of IP addresses to bind to *) + let configure _t addrs = + match addrs with + | [] -> Lwt.return_unit + | [ip] when (Ipaddr.V6.compare Ipaddr.V6.unspecified ip) = 0 -> Lwt.return_unit + | l -> + let pp_iplist fmt l = Format.pp_print_list Ipaddr.V6.pp 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); + Lwt.return_unit + + let connect ips udp tcp = + Log.info (fun f -> f "Manager: connect"); + let t = { tcp; udp } in + Log.info (fun f -> f "Manager: configuring"); + configure t ips >|= fun () -> + t + + let disconnect _ = Lwt.return_unit +end diff --git a/src/stack-unix/tcpip_stack_socket.mli b/src/stack-unix/tcpip_stack_socket.mli index 23968e956..260f219cb 100644 --- a/src/stack-unix/tcpip_stack_socket.mli +++ b/src/stack-unix/tcpip_stack_socket.mli @@ -14,8 +14,18 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -include Mirage_stack.V4 - with module UDPV4 = Udpv4_socket - and module TCPV4 = Tcpv4_socket - and module IPV4 = Ipv4_socket -val connect : Ipaddr.V4.t list -> Udpv4_socket.t -> Tcpv4_socket.t -> t Lwt.t +module V4 : sig + include Mirage_stack.V4 + with module UDPV4 = Udpv4_socket + and module TCPV4 = Tcpv4_socket + and module IPV4 = Ipv4_socket + val connect : Ipaddr.V4.t list -> Udpv4_socket.t -> Tcpv4_socket.t -> t Lwt.t +end + +module V6 : sig + include Mirage_stack.V6 + with module UDP = Udpv6_socket + and module TCP = Tcpv6_socket + and module IP = Ipv6_socket + val connect : Ipaddr.V6.t list -> Udpv6_socket.t -> Tcpv6_socket.t -> t Lwt.t +end diff --git a/src/stack-unix/udpv6_socket.ml b/src/stack-unix/udpv6_socket.ml index 23d0a8f14..922f31f30 100644 --- a/src/stack-unix/udpv6_socket.ml +++ b/src/stack-unix/udpv6_socket.ml @@ -41,9 +41,10 @@ let get_udpv6_listening_fd {listen_fds;interface} port = Lwt.return fd (** IO operation errors *) -type error = [ - | `Unknown of string (** an undiagnosed error *) -] +type error = [`Sendto_failed] + +let pp_error ppf = function + | `Sendto_failed -> Fmt.pf ppf "sendto failed to write any bytes" let connect (id:ip) = let t = @@ -67,12 +68,17 @@ let id { interface; _ } = let t, _ = Lwt.task () in t -let write ?source_port ~dest_ip ~dest_port t buf = +let write ?src_port ?ttl:_ttl ~dst ~dst_port t buf = let open Lwt_unix in - ( match source_port with + let rec write_to_fd fd buf = + Lwt_cstruct.sendto fd buf [] (ADDR_INET ((Ipaddr_unix.V6.to_inet_addr dst), dst_port)) + >>= function + | n when n = Cstruct.len buf -> Lwt.return @@ Ok () + | 0 -> Lwt.return @@ Error `Sendto_failed + | n -> write_to_fd fd (Cstruct.sub buf n (Cstruct.len buf - n)) (* keep trying *) + in + ( match src_port with | None -> get_udpv6_listening_fd t 0 | Some port -> get_udpv6_listening_fd t port ) >>= fun fd -> - Lwt_cstruct.sendto fd buf [] (ADDR_INET ((Ipaddr_unix.V6.to_inet_addr dest_ip), dest_port)) - >>= fun _ -> - return_unit + write_to_fd fd buf diff --git a/test/test_socket.ml b/test/test_socket.ml index af517694c..4b2c10e35 100644 --- a/test/test_socket.ml +++ b/test/test_socket.ml @@ -1,6 +1,6 @@ open Lwt.Infix -module Stack = Tcpip_stack_socket +module Stack = Tcpip_stack_socket.V4 module Time = Vnetif_common.Time type stack_stack = { From 191654db6499a16092a6ed335721c959103e41ec Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 11 Sep 2020 17:05:40 +0200 Subject: [PATCH 02/18] stack-socket: minimize diff -u udpv* ; diff -u tcpv*ml --- src/stack-unix/tcpv4_socket.ml | 12 ++++++------ src/stack-unix/tcpv6_socket.ml | 10 +++++----- src/stack-unix/udpv6_socket.ml | 17 +++++++---------- 3 files changed, 18 insertions(+), 21 deletions(-) diff --git a/src/stack-unix/tcpv4_socket.ml b/src/stack-unix/tcpv4_socket.ml index 9f150c9e1..f1a0ae7fa 100644 --- a/src/stack-unix/tcpv4_socket.ml +++ b/src/stack-unix/tcpv4_socket.ml @@ -14,7 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt +open Lwt.Infix type ipaddr = Ipaddr.V4.t type flow = Lwt_unix.file_descr @@ -26,13 +26,13 @@ type t = { include Tcp_socket -let connect id = +let connect addr = let t = - match id with + match addr with | None -> { interface=None } | Some ip -> { interface=Some (Ipaddr_unix.V4.to_inet_addr ip) } in - return t + Lwt.return t let dst fd = match Lwt_unix.getpeername fd with @@ -54,7 +54,7 @@ let create_connection ?keepalive _t (dst,dst_port) = | None -> () | Some { Mirage_protocols.Keepalive.after; interval; probes } -> Tcp_socket_options.enable_keepalive ~fd ~after ~interval ~probes ); - return (Ok fd)) + Lwt.return (Ok fd)) (fun exn -> Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >>= fun () -> - return (Error (`Exn exn))) + Lwt.return (Error (`Exn exn))) diff --git a/src/stack-unix/tcpv6_socket.ml b/src/stack-unix/tcpv6_socket.ml index 45f40c440..498e591fd 100644 --- a/src/stack-unix/tcpv6_socket.ml +++ b/src/stack-unix/tcpv6_socket.ml @@ -25,6 +25,8 @@ type t = { interface: Unix.inet_addr option; (* source ip to bind to *) } +include Tcp_socket + let connect addr = let t = match addr with @@ -50,12 +52,10 @@ let create_connection ?keepalive _t (dst,dst_port) = (Lwt_unix.ADDR_INET ((Ipaddr_unix.V6.to_inet_addr dst), dst_port)) >>= fun () -> ( match keepalive with - | None -> () - | Some { Mirage_protocols.Keepalive.after; interval; probes } -> - Tcp_socket_options.enable_keepalive ~fd ~after ~interval ~probes ); + | None -> () + | Some { Mirage_protocols.Keepalive.after; interval; probes } -> + Tcp_socket_options.enable_keepalive ~fd ~after ~interval ~probes ); Lwt.return (Ok fd)) (fun exn -> Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >>= fun () -> Lwt.return (Error (`Exn exn))) - -include Tcp_socket diff --git a/src/stack-unix/udpv6_socket.ml b/src/stack-unix/udpv6_socket.ml index 922f31f30..5b392c925 100644 --- a/src/stack-unix/udpv6_socket.ml +++ b/src/stack-unix/udpv6_socket.ml @@ -15,15 +15,13 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt +open Lwt.Infix -type buffer = Cstruct.t type ipaddr = Ipaddr.V6.t type flow = Lwt_unix.file_descr -type +'a io = 'a Lwt.t type ip = Ipaddr.V6.t option (* source ip and port *) type ipinput = unit Lwt.t -type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> buffer -> unit io +type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t type t = { interface: Unix.inet_addr; (* source ip to bind to *) @@ -35,12 +33,12 @@ let get_udpv6_listening_fd {listen_fds;interface} port = Lwt.return @@ Hashtbl.find listen_fds (interface,port) with Not_found -> let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in - Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface,port)) + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) >>= fun () -> - Hashtbl.add listen_fds (interface,port) fd; + Hashtbl.add listen_fds (interface, port) fd; Lwt.return fd -(** IO operation errors *) + type error = [`Sendto_failed] let pp_error ppf = function @@ -54,10 +52,9 @@ let connect (id:ip) = | None -> Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified | Some ip -> Ipaddr_unix.V6.to_inet_addr ip in { interface; listen_fds } - in return t + in Lwt.return t -let disconnect _ = - return_unit +let disconnect _ = Lwt.return_unit let id { interface; _ } = Some (Ipaddr_unix.V6.of_inet_addr_exn interface) From ca8fa428c37fa7539da38c8507db029f2813bf1b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 13 Sep 2020 13:24:22 +0200 Subject: [PATCH 03/18] TCP: specify src ip on IP.write --- src/tcp/wire.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tcp/wire.ml b/src/tcp/wire.ml index 83ffcf4f1..56072914b 100644 --- a/src/tcp/wire.ml +++ b/src/tcp/wire.ml @@ -44,7 +44,7 @@ module Make (Ip:Mirage_protocols.IP) = struct Fmt.pf ppf "remote %a,%d to local %a, %d" Ip.pp_ipaddr t.dst t.dst_port Ip.pp_ipaddr t.src t.src_port - let xmit ~ip { src_port; dst_port; dst; _ } ?(rst=false) ?(syn=false) + let xmit ~ip { src_port; dst_port; src; dst } ?(rst=false) ?(syn=false) ?(fin=false) ?(psh=false) ~rx_ack ~seq ~window ~options payload = @@ -62,7 +62,7 @@ module Make (Ip:Mirage_protocols.IP) = struct (* Make a TCP/IP header frame *) let tcp_size = Tcp_wire.sizeof_tcp + Options.lenv options + Cstruct.len payload in let fill_buffer buf = - let pseudoheader = Ip.pseudoheader ip dst `TCP tcp_size in + let pseudoheader = Ip.pseudoheader ip ~src dst `TCP tcp_size in match Tcp_packet.Marshal.into_cstruct header buf ~pseudoheader ~payload with | Error s -> Log.err (fun l -> l "Error writing TCP packet header: %s" s) ; @@ -75,7 +75,7 @@ module Make (Ip:Mirage_protocols.IP) = struct (Cstruct.len payload + if syn then 1 else 0) ; tcp_size in - Ip.write ip ~fragment:false dst `TCP ~size:tcp_size fill_buffer [] >|= function + Ip.write ip ~fragment:false ~src dst `TCP ~size:tcp_size fill_buffer [] >|= function | Ok () -> Ok () (* swallow errors so normal recovery mechanisms can be used *) (* For errors which aren't transient, or are too long-lived for TCP to recover From 2cdb4a0667d6733f3b9df6aea73d1ddbae776544 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 13 Sep 2020 13:34:28 +0200 Subject: [PATCH 04/18] IPv6: use src if specified --- src/ipv6/ipv6.ml | 4 ++-- src/ipv6/ndpv6.ml | 4 ++-- src/ipv6/ndpv6.mli | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/ipv6/ipv6.ml b/src/ipv6/ipv6.ml index c0b90ef11..1dd025bb0 100644 --- a/src/ipv6/ipv6.ml +++ b/src/ipv6/ipv6.ml @@ -63,7 +63,7 @@ module Make (N : Mirage_net.S) let mtu t = E.mtu t.ethif - Ipv6_wire.sizeof_ipv6 - let write t ?fragment:_ ?ttl:_ ?src:_ dst proto ?(size = 0) headerf bufs = + let write t ?fragment:_ ?ttl:_ ?src dst proto ?(size = 0) headerf bufs = let now = C.elapsed_ns () in (* TODO fragmentation! *) let payload = Cstruct.concat bufs in @@ -77,7 +77,7 @@ module Make (N : Mirage_net.S) Cstruct.blit payload 0 buf h_len (Cstruct.len payload); h_len + Cstruct.len payload in - let ctx, outs = Ndpv6.send ~now t.ctx dst proto size' fillf in + let ctx, outs = Ndpv6.send ~now t.ctx ?src dst proto size' fillf in t.ctx <- ctx; let fail_any progress data = let squeal = function diff --git a/src/ipv6/ndpv6.ml b/src/ipv6/ndpv6.ml index d136e8a84..4ff1790fe 100644 --- a/src/ipv6/ndpv6.ml +++ b/src/ipv6/ndpv6.ml @@ -1104,8 +1104,8 @@ and send' ~now ctx dst size fillf = let ctx = {ctx with packet_queue} in process_actions ~now ctx actions -let send ~now ctx dst proto size fillf = - let src = AddressList.select_source ctx.address_list ~dst in +let send ~now ctx ?src dst proto size fillf = + let src = match src with None -> AddressList.select_source ctx.address_list ~dst | Some s -> s in let siz, fill = Allocate.hdr ~hlim:ctx.cur_hop_limit ~src ~dst ~proto ~size fillf in send' ~now ctx dst siz fill diff --git a/src/ipv6/ndpv6.mli b/src/ipv6/ndpv6.mli index 717da577b..df2907ea1 100644 --- a/src/ipv6/ndpv6.mli +++ b/src/ipv6/ndpv6.mli @@ -55,9 +55,9 @@ val handle : now:time -> random:(int -> Cstruct.t) -> context -> buffer -> packets to be sent and [evs] is a list of packets to be passed to the higher layers (udp, tcp, etc) for further processing. *) -val send : now:time -> context -> ipaddr -> Mirage_protocols.Ip.proto -> +val send : now:time -> context -> ?src:ipaddr -> ipaddr -> Mirage_protocols.Ip.proto -> int -> (buffer -> buffer -> int) -> context * (Macaddr.t * int * (buffer -> int)) list -(** [send ~now ctx ip proto size fillf] starts route resolution and assembles an +(** [send ~now ctx ?src dst proto size fillf] starts route resolution and assembles an ipv6 packet of [size] for sending with header and body passed to [fillf]. It returns a pair [ctx', dst_size_fills] where [ctx'] is the updated context and [dst, size, fillf] is a list of packets to be sent, specified From 954cb0089fcc75d68211ed2925d3e4517fca9fde Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 13 Sep 2020 15:29:34 +0200 Subject: [PATCH 05/18] udp: extend write with ?src parameter this has been changed in mirage-protocols 5.0.0 to allow dual stack --- src/stack-unix/udpv4_socket.ml | 2 +- src/stack-unix/udpv6_socket.ml | 2 +- src/udp/udp.ml | 10 +++++----- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/stack-unix/udpv4_socket.ml b/src/stack-unix/udpv4_socket.ml index 6c9dfbc42..fd468a971 100644 --- a/src/stack-unix/udpv4_socket.ml +++ b/src/stack-unix/udpv4_socket.ml @@ -64,7 +64,7 @@ let id { interface; _ } = let t, _ = Lwt.task () in t -let write ?src_port ?ttl:_ttl ~dst ~dst_port t buf = +let write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf = let open Lwt_unix in let rec write_to_fd fd buf = Lwt_cstruct.sendto fd buf [] (ADDR_INET ((Ipaddr_unix.V4.to_inet_addr dst), dst_port)) diff --git a/src/stack-unix/udpv6_socket.ml b/src/stack-unix/udpv6_socket.ml index 5b392c925..9b0d179b4 100644 --- a/src/stack-unix/udpv6_socket.ml +++ b/src/stack-unix/udpv6_socket.ml @@ -65,7 +65,7 @@ let id { interface; _ } = let t, _ = Lwt.task () in t -let write ?src_port ?ttl:_ttl ~dst ~dst_port t buf = +let write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf = let open Lwt_unix in let rec write_to_fd fd buf = Lwt_cstruct.sendto fd buf [] (ADDR_INET ((Ipaddr_unix.V6.to_inet_addr dst), dst_port)) diff --git a/src/udp/udp.ml b/src/udp/udp.ml index 1d4c12977..ce4a52ca3 100644 --- a/src/udp/udp.ml +++ b/src/udp/udp.ml @@ -49,7 +49,7 @@ module Make(Ip: Mirage_protocols.IP)(Random:Mirage_random.S) = struct | Some fn -> fn ~src ~dst ~src_port payload - let writev ?src_port ?ttl ~dst ~dst_port t bufs = + let writev ?src ?src_port ?ttl ~dst ~dst_port t bufs = let src_port = match src_port with | None -> Randomconv.int ~bound:65535 (fun x -> Random.generate x) | Some p -> p @@ -57,7 +57,7 @@ module Make(Ip: Mirage_protocols.IP)(Random:Mirage_random.S) = struct let fill_hdr buf = let payload_size = Cstruct.lenv bufs in let ph = - Ip.pseudoheader t.ip dst `UDP (payload_size + Udp_wire.sizeof_udp) + Ip.pseudoheader t.ip ?src dst `UDP (payload_size + Udp_wire.sizeof_udp) in let udp_header = Udp_packet.({ src_port; dst_port; }) in match Udp_packet.Marshal.into_cstruct udp_header buf ~pseudoheader:ph ~payload:(Cstruct.concat bufs) with @@ -66,7 +66,7 @@ module Make(Ip: Mirage_protocols.IP)(Random:Mirage_random.S) = struct Logs.err (fun m -> m "error while assembling udp header: %s, ignoring" msg); 8 in - Ip.write t.ip dst ?ttl `UDP ~size:8 fill_hdr bufs >|= function + Ip.write t.ip ?src dst ?ttl `UDP ~size:8 fill_hdr bufs >|= function | Ok () -> Ok () | Error e -> Log.err (fun f -> f "IP module couldn't send UDP packet to %a: %a" @@ -74,8 +74,8 @@ module Make(Ip: Mirage_protocols.IP)(Random:Mirage_random.S) = struct (* we're supposed to make our best effort, and we did *) Ok () - let write ?src_port ?ttl ~dst ~dst_port t buf = - writev ?src_port ?ttl ~dst ~dst_port t [buf] + let write ?src ?src_port ?ttl ~dst ~dst_port t buf = + writev ?src ?src_port ?ttl ~dst ~dst_port t [buf] let connect ip = Log.info (fun f -> f "UDP interface connected on %a" (Fmt.list Ip.pp_ipaddr) @@ Ip.get_ip ip); From 06ecdca6cee921cbf7fa0fd0c83f8bf8e79e4d6f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 13 Sep 2020 16:41:07 +0200 Subject: [PATCH 06/18] dual direct stack --- src/stack-direct/tcpip_stack_direct.ml | 223 ++++++++++++++++++++++++ src/stack-direct/tcpip_stack_direct.mli | 41 ++++- 2 files changed, 263 insertions(+), 1 deletion(-) diff --git a/src/stack-direct/tcpip_stack_direct.ml b/src/stack-direct/tcpip_stack_direct.ml index ce3b13d34..afc7546ae 100644 --- a/src/stack-direct/tcpip_stack_direct.ml +++ b/src/stack-direct/tcpip_stack_direct.ml @@ -256,3 +256,226 @@ module MakeV6 end +type direct_ipv4v6_input = src:Ipaddr.t -> dst:Ipaddr.t -> Cstruct.t -> unit Lwt.t + +module type UDPV4V6_DIRECT = Mirage_protocols.UDP + with type ipaddr = Ipaddr.t + and type ipinput = direct_ipv4v6_input + +module type TCPV4V6_DIRECT = Mirage_protocols.TCP + with type ipaddr = Ipaddr.t + and type ipinput = direct_ipv4v6_input + +module IPV4V6 (Ipv4 : Mirage_protocols.IPV4) (Ipv6 : Mirage_protocols.IPV6) = struct + + type ipaddr = Ipaddr.t + type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t + + let pp_ipaddr = Ipaddr.pp + + type error = [ Mirage_protocols.Ip.error | `Ipv4 of Ipv4.error | `Ipv6 of Ipv6.error | `Msg of string ] + + let pp_error ppf = function + | #Mirage_protocols.Ip.error as e -> Mirage_protocols.Ip.pp_error ppf e + | `Ipv4 e -> Ipv4.pp_error ppf e + | `Ipv6 e -> Ipv6.pp_error ppf e + | `Msg m -> Fmt.string ppf m + + type t = { ipv4 : Ipv4.t ; ipv6 : Ipv6.t } + + let connect ipv4 ipv6 = Lwt.return { ipv4 ; ipv6 } + + let disconnect _ = Lwt.return_unit + + let input t ~tcp ~udp ~default = + let tcp4 ~src ~dst payload = tcp ~src:(Ipaddr.V4 src) ~dst:(Ipaddr.V4 dst) payload + and tcp6 ~src ~dst payload = tcp ~src:(Ipaddr.V6 src) ~dst:(Ipaddr.V6 dst) payload + and udp4 ~src ~dst payload = udp ~src:(Ipaddr.V4 src) ~dst:(Ipaddr.V4 dst) payload + and udp6 ~src ~dst payload = udp ~src:(Ipaddr.V6 src) ~dst:(Ipaddr.V6 dst) payload + and default4 ~proto ~src ~dst payload = default ~proto ~src:(Ipaddr.V4 src) ~dst:(Ipaddr.V4 dst) payload + and default6 ~proto ~src ~dst payload = default ~proto ~src:(Ipaddr.V6 src) ~dst:(Ipaddr.V6 dst) payload + in + fun buf -> + if Cstruct.len buf >= 1 then + let v = Cstruct.get_uint8 buf 0 lsr 4 in + if v = 4 then + Ipv4.input t.ipv4 ~tcp:tcp4 ~udp:udp4 ~default:default4 buf + else if v = 6 then + Ipv6.input t.ipv6 ~tcp:tcp6 ~udp:udp6 ~default:default6 buf + else + Lwt.return_unit + else + Lwt.return_unit + + let write t ?fragment ?ttl ?src dst proto ?size headerf bufs = + match dst with + | Ipaddr.V4 dst -> + begin + match + match src with + | None -> Ok None + | Some (Ipaddr.V4 src) -> Ok (Some src) + | _ -> Error (`Msg "source must be V4 if dst is V4") + with + | Error e -> Lwt.return (Error e) + | Ok src -> + Ipv4.write t.ipv4 ?fragment ?ttl ?src dst proto ?size headerf bufs >|= function + | Ok () -> Ok () + | Error e -> Error (`Ipv4 e) + end + | Ipaddr.V6 dst -> + begin + match + match src with + | None -> Ok None + | Some (Ipaddr.V6 src) -> Ok (Some src) + | _ -> Error (`Msg "source must be V6 if dst is V6") + with + | Error e -> Lwt.return (Error e) + | Ok src -> + Ipv6.write t.ipv6 ?fragment ?ttl ?src dst proto ?size headerf bufs >|= function + | Ok () -> Ok () + | Error e -> Error (`Ipv6 e) + end + + let pseudoheader t ?src dst proto len = + match dst with + | Ipaddr.V4 dst -> + let src = + match src with + | None -> None + | Some (Ipaddr.V4 src) -> Some src + | _ -> None (* TODO *) + in + Ipv4.pseudoheader t.ipv4 ?src dst proto len + | Ipaddr.V6 dst -> + let src = + match src with + | None -> None + | Some (Ipaddr.V6 src) -> Some src + | _ -> None (* TODO *) + in + Ipv6.pseudoheader t.ipv6 ?src dst proto len + + let src t ~dst = + match dst with + | Ipaddr.V4 dst -> Ipaddr.V4 (Ipv4.src t.ipv4 ~dst) + | Ipaddr.V6 dst -> Ipaddr.V6 (Ipv6.src t.ipv6 ~dst) + + let get_ip t = + List.map (fun ip -> Ipaddr.V4 ip) (Ipv4.get_ip t.ipv4) @ + List.map (fun ip -> Ipaddr.V6 ip) (Ipv6.get_ip t.ipv6) + + let mtu t = + (* TODO incorrect for IPv4 *) + Ipv6.mtu t.ipv6 +end + +module MakeV4V6 + (Time : Mirage_time.S) + (Random : Mirage_random.S) + (Netif : Mirage_net.S) + (Ethernet : Mirage_protocols.ETHERNET) + (Arpv4 : Mirage_protocols.ARP) + (Ip : Mirage_protocols.IP with type ipaddr = Ipaddr.t) + (Icmpv4 : Mirage_protocols.ICMP with type ipaddr = Ipaddr.V4.t) + (Udp : UDPV4V6_DIRECT) + (Tcp : TCPV4V6_DIRECT) = struct + + module UDP = Udp + module TCP = Tcp + module IP = Ip + + type t = { + netif : Netif.t; + ethif : Ethernet.t; + arpv4 : Arpv4.t; + icmpv4 : Icmpv4.t; + ip : IP.t; + udp : Udp.t; + tcp : Tcp.t; + udp_listeners: (int, Udp.callback) Hashtbl.t; + tcp_listeners: (int, Tcp.listener) Hashtbl.t; + mutable task : unit Lwt.t option; + } + + let pp fmt t = + Format.fprintf fmt "mac=%a,ip=%a" Macaddr.pp (Ethernet.mac t.ethif) + (Fmt.list Ipaddr.pp) (IP.get_ip t.ip) + + let tcp { tcp; _ } = tcp + let udp { udp; _ } = udp + let ip { ip; _ } = ip + + let err_invalid_port p = Printf.sprintf "invalid port number (%d)" p + + let listen_udp t ~port callback = + if port < 0 || port > 65535 + then raise (Invalid_argument (err_invalid_port port)) + else Hashtbl.replace t.udp_listeners port callback + + let listen_tcp ?keepalive t ~port process = + if port < 0 || port > 65535 + then raise (Invalid_argument (err_invalid_port port)) + else Hashtbl.replace t.tcp_listeners port { Tcp.process; keepalive } + + let udp_listeners t ~dst_port = + try Some (Hashtbl.find t.udp_listeners dst_port) + with Not_found -> None + + let tcp_listeners t dst_port = + try Some (Hashtbl.find t.tcp_listeners dst_port) + with Not_found -> None + + let listen t = + Lwt.catch (fun () -> + Log.debug (fun f -> f "Establishing or updating listener for stack %a" pp t); + let tcp = Tcp.input t.tcp ~listeners:(tcp_listeners t) + and udp = Udp.input t.udp ~listeners:(udp_listeners t) + and default ~proto ~src ~dst buf = + match proto, src, dst with + | 1, Ipaddr.V4 src, Ipaddr.V4 dst -> Icmpv4.input t.icmpv4 ~src ~dst buf + | _ -> Lwt.return_unit + in + let ethif_listener = Ethernet.input + ~arpv4:(Arpv4.input t.arpv4) + ~ipv4:(IP.input ~tcp ~udp ~default t.ip) + ~ipv6:(IP.input ~tcp ~udp ~default t.ip) + t.ethif + in + Netif.listen t.netif ~header_size:Ethernet_wire.sizeof_ethernet ethif_listener + >>= function + | Error e -> + Log.warn (fun p -> p "%a" Netif.pp_error e) ; + (* XXX: error should be passed to the caller *) + Lwt.return_unit + | Ok _res -> + let nstat = Netif.get_stats_counters t.netif in + let open Mirage_net in + Log.info (fun f -> + f "listening loop of interface %s terminated regularly:@ %Lu bytes \ + (%lu packets) received, %Lu bytes (%lu packets) sent@ " + (Macaddr.to_string (Netif.mac t.netif)) + nstat.rx_bytes nstat.rx_pkts + nstat.tx_bytes nstat.tx_pkts) ; + Lwt.return_unit) + (function + | Lwt.Canceled -> + Log.info (fun f -> f "listen of %a cancelled" pp t); + Lwt.return_unit + | e -> Lwt.fail e) + + let connect netif ethif arpv4 ip icmpv4 udp tcp = + let udp_listeners = Hashtbl.create 7 in + let tcp_listeners = Hashtbl.create 7 in + let t = { netif; ethif; arpv4; ip; icmpv4; tcp; udp; + udp_listeners; tcp_listeners; task = None } in + Log.info (fun f -> f "stack assembled: %a" pp t); + Lwt.async (fun () -> let task = listen t in t.task <- Some task; task); + Lwt.return t + + let disconnect t = + Log.info (fun f -> f "disconnect called: %a" pp t); + (match t.task with None -> () | Some task -> Lwt.cancel task); + Lwt.return_unit +end diff --git a/src/stack-direct/tcpip_stack_direct.mli b/src/stack-direct/tcpip_stack_direct.mli index 3d3698292..e7a5a7dc1 100644 --- a/src/stack-direct/tcpip_stack_direct.mli +++ b/src/stack-direct/tcpip_stack_direct.mli @@ -74,7 +74,46 @@ module MakeV6 val connect : Netif.t -> Ethernet.t -> Ipv6.t -> Udpv6.t -> Tcpv6.t -> t Lwt.t (** [connect] assembles the arguments into a network stack, then calls `listen` on the assembled stack before returning it to the caller. The - initial `listen` functions to ensure that the lower-level layers are + initial `listen` functions to ensure that the lower-level layers are + functioning, so that if the user wishes to establish outbound connections, + they will be able to do so. *) +end + +type direct_ipv4v6_input = src:Ipaddr.t -> dst:Ipaddr.t -> Cstruct.t -> unit Lwt.t + +module type UDPV4V6_DIRECT = Mirage_protocols.UDP + with type ipaddr = Ipaddr.t + and type ipinput = direct_ipv4v6_input + +module type TCPV4V6_DIRECT = Mirage_protocols.TCP + with type ipaddr = Ipaddr.t + and type ipinput = direct_ipv4v6_input + +module IPV4V6 (Ipv4 : Mirage_protocols.IPV4) (Ipv6 : Mirage_protocols.IPV6) : sig + include Mirage_protocols.IP with type ipaddr = Ipaddr.t + + val connect : Ipv4.t -> Ipv6.t -> t Lwt.t +end + +module MakeV4V6 + (Time : Mirage_time.S) + (Random : Mirage_random.S) + (Netif : Mirage_net.S) + (Ethernet : Mirage_protocols.ETHERNET) + (Arpv4 : Mirage_protocols.ARP) + (Ip : Mirage_protocols.IP with type ipaddr = Ipaddr.t) + (Icmpv4 : Mirage_protocols.ICMP with type ipaddr = Ipaddr.V4.t) + (Udp : UDPV4V6_DIRECT) + (Tcp : TCPV4V6_DIRECT) : sig + include Mirage_stack.V4V6 + with module IP = Ip + and module TCP = Tcp + and module UDP = Udp + + val connect : Netif.t -> Ethernet.t -> Arpv4.t -> Ip.t -> Icmpv4.t -> Udp.t -> Tcp.t -> t Lwt.t + (** [connect] assembles the arguments into a network stack, then calls + `listen` on the assembled stack before returning it to the caller. The + initial `listen` functions to ensure that the lower-level layers are functioning, so that if the user wishes to establish outbound connections, they will be able to do so. *) end From e72dddc334aab4412f822371139bb2eeb1af1180 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 30 Sep 2020 11:44:57 +0200 Subject: [PATCH 07/18] Add a dual IPv4 IPv6 socket stack (by using setsockopt IPV6_ONLY false) also set the same socket option to true in IPv6 only socket stack --- src/icmp/icmpv4.ml | 6 +- src/stack-unix/dune | 24 +++++- src/stack-unix/icmpv4_socket.ml | 2 +- src/stack-unix/ipv4v6_socket.ml | 39 ++++++++++ src/stack-unix/tcpip_stack_socket.ml | 102 ++++++++++++++++++++++++++ src/stack-unix/tcpip_stack_socket.mli | 8 ++ src/stack-unix/tcpv4_socket.ml | 2 +- src/stack-unix/tcpv4v6_socket.ml | 58 +++++++++++++++ src/stack-unix/tcpv4v6_socket.mli | 25 +++++++ src/stack-unix/tcpv6_socket.ml | 3 +- src/stack-unix/udpv4v6_socket.ml | 82 +++++++++++++++++++++ src/stack-unix/udpv6_socket.ml | 1 + 12 files changed, 344 insertions(+), 8 deletions(-) create mode 100644 src/stack-unix/ipv4v6_socket.ml create mode 100644 src/stack-unix/tcpv4v6_socket.ml create mode 100644 src/stack-unix/tcpv4v6_socket.mli create mode 100644 src/stack-unix/udpv4v6_socket.ml diff --git a/src/icmp/icmpv4.ml b/src/icmp/icmpv4.ml index c62c42074..85df51bb4 100644 --- a/src/icmp/icmpv4.ml +++ b/src/icmp/icmpv4.ml @@ -21,14 +21,14 @@ module Make(IP : Mirage_protocols.IP with type ipaddr = Ipaddr.V4.t) = struct let disconnect _ = Lwt.return_unit - let writev t ~dst ?ttl bufs = - IP.write t.ip dst ?ttl `ICMP (fun _ -> 0) bufs >|= function + let writev t ?src ~dst ?ttl bufs = + IP.write t.ip ?src dst ?ttl `ICMP (fun _ -> 0) bufs >|= function | Ok () -> Ok () | Error e -> Log.warn (fun f -> f "Error sending IP packet: %a" IP.pp_error e); Error (`Ip e) - let write t ~dst ?ttl buf = writev t ~dst ?ttl [buf] + let write t ?src ~dst ?ttl buf = writev t ?src ~dst ?ttl [buf] let input t ~src ~dst:_ buf = let open Icmpv4_packet in diff --git a/src/stack-unix/dune b/src/stack-unix/dune index f66622994..035eadb9a 100644 --- a/src/stack-unix/dune +++ b/src/stack-unix/dune @@ -26,6 +26,15 @@ (backend bisect_ppx)) (libraries lwt.unix ipaddr.unix cstruct-lwt fmt mirage-protocols)) +(library + (name udpv4v6_socket) + (public_name tcpip.udpv4v6-socket) + (modules udpv4v6_socket) + (wrapped false) + (instrumentation + (backend bisect_ppx)) + (libraries lwt.unix ipaddr.unix cstruct-lwt fmt mirage-protocols)) + (library (name tcp_socket_options) (public_name tcpip.tcp_socket_options) @@ -59,13 +68,24 @@ (libraries lwt.unix ipaddr.unix cstruct-lwt fmt mirage-protocols tcpv4_socket tcp_socket_options)) +(library + (name tcpv4v6_socket) + (public_name tcpip.tcpv4v6-socket) + (modules tcpv4v6_socket) + (wrapped false) + (instrumentation + (backend bisect_ppx)) + (libraries lwt.unix ipaddr.unix cstruct-lwt fmt mirage-protocols + tcpv4_socket tcp_socket_options)) + (library (name tcpip_stack_socket) (public_name tcpip.stack-socket) - (modules tcpip_stack_socket ipv4_socket ipv6_socket) + (modules tcpip_stack_socket ipv4_socket ipv6_socket ipv4v6_socket) (wrapped false) (instrumentation (backend bisect_ppx)) (libraries lwt.unix cstruct-lwt ipaddr.unix logs tcpip.tcpv4-socket tcpip.udpv4-socket tcpip.ipv4 tcpip.tcpv6-socket tcpip.udpv6-socket - tcpip.ipv6 tcpip.icmpv4 mirage-protocols mirage-stack)) + tcpip.ipv6 tcpip.tcpv4v6-socket tcpip.udpv4v6-socket tcpip.icmpv4 + mirage-protocols mirage-stack)) diff --git a/src/stack-unix/icmpv4_socket.ml b/src/stack-unix/icmpv4_socket.ml index f71d5c7be..405e0b21f 100644 --- a/src/stack-unix/icmpv4_socket.ml +++ b/src/stack-unix/icmpv4_socket.ml @@ -42,7 +42,7 @@ let recvfrom' fd buf flags = Lwt.return (n, sockaddr) end else Lwt_cstruct.recvfrom fd buf flags -let write _t ~dst ?ttl:_ttl buf = +let write _t ?src:_ ~dst ?ttl:_ttl buf = let open Lwt_unix in let flags = [] in let ipproto_icmp = 1 in (* according to BSD /etc/protocols *) diff --git a/src/stack-unix/ipv4v6_socket.ml b/src/stack-unix/ipv4v6_socket.ml new file mode 100644 index 000000000..5606dbe9f --- /dev/null +++ b/src/stack-unix/ipv4v6_socket.ml @@ -0,0 +1,39 @@ +(* + * Copyright (c) 2014 Anil Madhavapeddy + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt + +type t = unit +type +'a io = 'a Lwt.t +type error = Mirage_protocols.Ip.error +type ipaddr = Ipaddr.t +type buffer = Cstruct.t +type callback = src:ipaddr -> dst:ipaddr -> buffer -> unit io + +let pp_error = Mirage_protocols.Ip.pp_error +let pp_ipaddr = Ipaddr.pp + +let mtu _ = 1500 - Ipv6_wire.sizeof_ipv6 + +let disconnect _ = return_unit +let connect _ = return_unit + +let input _ ~tcp:_ ~udp:_ ~default:_ _ = return_unit +let write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ = fail (Failure "Not implemented") + +let get_ip _ = [Ipaddr.V6 Ipaddr.V6.unspecified] +let src _ ~dst:_ = raise (Failure "Not implemented") +let pseudoheader _ ?src:_ _ _ _ = raise (Failure "Not implemented") diff --git a/src/stack-unix/tcpip_stack_socket.ml b/src/stack-unix/tcpip_stack_socket.ml index 8707c2f6c..fe20d6ae8 100644 --- a/src/stack-unix/tcpip_stack_socket.ml +++ b/src/stack-unix/tcpip_stack_socket.ml @@ -168,6 +168,7 @@ module V6 = struct else let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; + Lwt_unix.(setsockopt fd IPV6_ONLY true); (* 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.V6.to_inet_addr Ipaddr.V6.unspecified in (* FIXME: we should not ignore the result *) @@ -220,3 +221,104 @@ module V6 = struct let disconnect _ = Lwt.return_unit end + +module V4V6 = struct + module TCP = Tcpv4v6_socket + module UDP = Udpv4v6_socket + module IP = Ipv4v6_socket + + type t = { + udp : UDP.t; + tcp : TCP.t; + } + + let udp { udp; _ } = udp + let tcp { tcp; _ } = tcp + let ip _ = () + + let err_invalid_port p = Printf.sprintf "invalid port number (%d)" p + + let listen_udp t ~port callback = + if port < 0 || port > 65535 then + raise (Invalid_argument (err_invalid_port port)) + else + (* FIXME: we should not ignore the result *) + Lwt.async (fun () -> + UDP.get_udpv4v6_listening_fd t.udp port >>= fun fd -> + let buf = Cstruct.create 4096 in + let rec loop () = + (* 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.of_inet_addr addr in + let dst = Ipaddr.(V6 V6.unspecified) 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 ()) + + let listen_tcp ?keepalive _t ~port callback = + if port < 0 || port > 65535 then + raise (Invalid_argument (err_invalid_port port)) + else + let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in + Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; + Lwt_unix.(setsockopt fd IPV6_ONLY false); + (* 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.V6.to_inet_addr Ipaddr.V6.unspecified in + (* FIXME: we should not ignore the result *) + Lwt.async (fun () -> + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) >>= fun () -> + Lwt_unix.listen fd 10; + (* TODO cancellation *) + let rec 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 + t (* TODO cancellation *) + + (* List of IP addresses to bind to *) + let configure _t addrs = + match addrs with + | [] -> Lwt.return_unit + | l -> + let pp_iplist fmt l = Format.pp_print_list Ipaddr.pp 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); + Lwt.return_unit + + let connect ips udp tcp = + Log.info (fun f -> f "Manager: connect"); + let t = { tcp; udp } in + Log.info (fun f -> f "Manager: configuring"); + configure t ips >|= fun () -> + t + + let disconnect _ = Lwt.return_unit +end diff --git a/src/stack-unix/tcpip_stack_socket.mli b/src/stack-unix/tcpip_stack_socket.mli index 260f219cb..5be5c351f 100644 --- a/src/stack-unix/tcpip_stack_socket.mli +++ b/src/stack-unix/tcpip_stack_socket.mli @@ -29,3 +29,11 @@ module V6 : sig and module IP = Ipv6_socket val connect : Ipaddr.V6.t list -> Udpv6_socket.t -> Tcpv6_socket.t -> t Lwt.t end + +module V4V6 : sig + include Mirage_stack.V4V6 + with module UDP = Udpv4v6_socket + and module TCP = Tcpv4v6_socket + and module IP = Ipv4v6_socket + val connect : Ipaddr.t list -> Udpv4v6_socket.t -> Tcpv4v6_socket.t -> t Lwt.t +end diff --git a/src/stack-unix/tcpv4_socket.ml b/src/stack-unix/tcpv4_socket.ml index f1a0ae7fa..b13836aa2 100644 --- a/src/stack-unix/tcpv4_socket.ml +++ b/src/stack-unix/tcpv4_socket.ml @@ -45,7 +45,7 @@ let dst fd = end let create_connection ?keepalive _t (dst,dst_port) = - let fd = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in + let fd = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in Lwt.catch (fun () -> Lwt_unix.connect fd (Lwt_unix.ADDR_INET ((Ipaddr_unix.V4.to_inet_addr dst), dst_port)) diff --git a/src/stack-unix/tcpv4v6_socket.ml b/src/stack-unix/tcpv4v6_socket.ml new file mode 100644 index 000000000..5c1e91841 --- /dev/null +++ b/src/stack-unix/tcpv4v6_socket.ml @@ -0,0 +1,58 @@ +(* + * Copyright (c) 2014 Anil Madhavapeddy + * Copyright (c) 2014 Nicolas Ojeda Bar + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt.Infix + +type ipaddr = Ipaddr.t +type flow = Lwt_unix.file_descr +type ipinput = unit Lwt.t + +type t = { + interface: Unix.inet_addr option; (* source ip to bind to *) +} + +include Tcp_socket + +let connect addr = + let t = + match addr with + | None -> { interface=None } + | Some ip -> { interface=Some (Ipaddr_unix.to_inet_addr ip) } + in + Lwt.return t + +let dst fd = + match Lwt_unix.getpeername fd with + | Unix.ADDR_UNIX _ -> + raise (Failure "unexpected: got a unix instead of tcp sock") + | Unix.ADDR_INET (ia,port) -> Ipaddr_unix.of_inet_addr ia,port + +let create_connection ?keepalive _t (dst,dst_port) = + let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in + Lwt_unix.(setsockopt fd IPV6_ONLY false); + Lwt.catch (fun () -> + Lwt_unix.connect fd + (Lwt_unix.ADDR_INET ((Ipaddr_unix.to_inet_addr dst), dst_port)) + >>= fun () -> + ( match keepalive with + | None -> () + | Some { Mirage_protocols.Keepalive.after; interval; probes } -> + Tcp_socket_options.enable_keepalive ~fd ~after ~interval ~probes ); + Lwt.return (Ok fd)) + (fun exn -> + Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >>= fun () -> + Lwt.return (Error (`Exn exn))) diff --git a/src/stack-unix/tcpv4v6_socket.mli b/src/stack-unix/tcpv4v6_socket.mli new file mode 100644 index 000000000..dfbc6647d --- /dev/null +++ b/src/stack-unix/tcpv4v6_socket.mli @@ -0,0 +1,25 @@ +(* + * Copyright (c) 2014 Anil Madhavapeddy + * Copyright (c) 2014 Nicolas Ojeda Bar + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Mirage_protocols.TCP + with type ipaddr = Ipaddr.t + and type ipinput = unit Lwt.t + and type flow = Lwt_unix.file_descr + and type error = [ Mirage_protocols.Tcp.error | `Exn of exn ] + and type write_error = [ Mirage_protocols.Tcp.write_error | `Exn of exn ] + +val connect : Ipaddr.t option -> t Lwt.t diff --git a/src/stack-unix/tcpv6_socket.ml b/src/stack-unix/tcpv6_socket.ml index 498e591fd..d01514453 100644 --- a/src/stack-unix/tcpv6_socket.ml +++ b/src/stack-unix/tcpv6_socket.ml @@ -46,7 +46,8 @@ let dst fd = end let create_connection ?keepalive _t (dst,dst_port) = - let fd = Lwt_unix.socket Lwt_unix.PF_INET6 Lwt_unix.SOCK_STREAM 0 in + let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in + Lwt_unix.(setsockopt fd IPV6_ONLY true); Lwt.catch (fun () -> Lwt_unix.connect fd (Lwt_unix.ADDR_INET ((Ipaddr_unix.V6.to_inet_addr dst), dst_port)) diff --git a/src/stack-unix/udpv4v6_socket.ml b/src/stack-unix/udpv4v6_socket.ml new file mode 100644 index 000000000..440088f5e --- /dev/null +++ b/src/stack-unix/udpv4v6_socket.ml @@ -0,0 +1,82 @@ +(* + * Copyright (c) 2014 Anil Madhavapeddy + * Copyright (c) 2014 Nicolas Ojeda Bar + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt.Infix + +type ipaddr = Ipaddr.t +type flow = Lwt_unix.file_descr +type ip = Ipaddr.t option (* source ip and port *) +type ipinput = unit Lwt.t +type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t + +type t = { + interface: Unix.inet_addr; (* source ip to bind to *) + listen_fds: ((Unix.inet_addr * int),Lwt_unix.file_descr) Hashtbl.t; (* UDPv6 fds bound to a particular source ip/port *) +} + +let get_udpv4v6_listening_fd {listen_fds;interface} port = + try + Lwt.return @@ Hashtbl.find listen_fds (interface,port) + with Not_found -> + let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in + Lwt_unix.(setsockopt fd IPV6_ONLY false); + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) + >>= fun () -> + Hashtbl.add listen_fds (interface, port) fd; + Lwt.return fd + + +type error = [`Sendto_failed] + +let pp_error ppf = function + | `Sendto_failed -> Fmt.pf ppf "sendto failed to write any bytes" + +let connect (id:ip) = + let t = + let listen_fds = Hashtbl.create 7 in + let interface = + match id with + | None -> Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified + | Some ip -> Ipaddr_unix.to_inet_addr ip + in { interface; listen_fds } + in Lwt.return t + +let disconnect _ = Lwt.return_unit + +let id { interface; _ } = + Some (Ipaddr_unix.V6.of_inet_addr_exn interface) + +(* FIXME: how does this work at all ?? *) + let input ~listeners:_ _ = + (* TODO terminate when signalled by disconnect *) + let t, _ = Lwt.task () in + t + +let write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf = + let open Lwt_unix in + let rec write_to_fd fd buf = + Lwt_cstruct.sendto fd buf [] (ADDR_INET ((Ipaddr_unix.to_inet_addr dst), dst_port)) + >>= function + | n when n = Cstruct.len buf -> Lwt.return @@ Ok () + | 0 -> Lwt.return @@ Error `Sendto_failed + | n -> write_to_fd fd (Cstruct.sub buf n (Cstruct.len buf - n)) (* keep trying *) + in + ( match src_port with + | None -> get_udpv4v6_listening_fd t 0 + | Some port -> get_udpv4v6_listening_fd t port ) + >>= fun fd -> + write_to_fd fd buf diff --git a/src/stack-unix/udpv6_socket.ml b/src/stack-unix/udpv6_socket.ml index 9b0d179b4..1fe9fdcdb 100644 --- a/src/stack-unix/udpv6_socket.ml +++ b/src/stack-unix/udpv6_socket.ml @@ -33,6 +33,7 @@ let get_udpv6_listening_fd {listen_fds;interface} port = Lwt.return @@ Hashtbl.find listen_fds (interface,port) with Not_found -> let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in + Lwt_unix.(setsockopt fd IPV6_ONLY true); Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) >>= fun () -> Hashtbl.add listen_fds (interface, port) fd; From 87e27c15335050ca5a13986ce30bce71e9fdd9a2 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 30 Sep 2020 19:05:10 +0200 Subject: [PATCH 08/18] stack-socket: connect no longer receives an unused list of ip addresses this cleans up the interface (needs to be synced with the mirage tool) --- src/stack-unix/tcpip_stack_socket.ml | 59 ++++----------------------- src/stack-unix/tcpip_stack_socket.mli | 6 +-- 2 files changed, 12 insertions(+), 53 deletions(-) diff --git a/src/stack-unix/tcpip_stack_socket.ml b/src/stack-unix/tcpip_stack_socket.ml index fe20d6ae8..b95fdc3c3 100644 --- a/src/stack-unix/tcpip_stack_socket.ml +++ b/src/stack-unix/tcpip_stack_socket.ml @@ -33,17 +33,6 @@ module V4 = struct let tcpv4 { tcpv4; _ } = tcpv4 let ipv4 _ = None - (* List of IP addresses to bind to *) - let configure _t addrs = - match addrs with - | [] -> 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 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); - Lwt.return_unit - let err_invalid_port p = Printf.sprintf "invalid port number (%d)" p let listen_udpv4 t ~port callback = @@ -110,12 +99,9 @@ module V4 = struct let t, _ = Lwt.task () in t (* TODO cancellation *) - let connect ips udpv4 tcpv4 = - Log.info (fun f -> f "Manager: connect"); - let t = { tcpv4; udpv4 } in - Log.info (fun f -> f "Manager: configuring"); - configure t ips >|= fun () -> - t + let connect udpv4 tcpv4 = + Log.info (fun f -> f "IPv4 socket stack: connect"); + Lwt.return { tcpv4; udpv4 } let disconnect _ = Lwt.return_unit end @@ -201,23 +187,9 @@ module V6 = struct let t, _ = Lwt.task () in t (* TODO cancellation *) - (* List of IP addresses to bind to *) - let configure _t addrs = - match addrs with - | [] -> Lwt.return_unit - | [ip] when (Ipaddr.V6.compare Ipaddr.V6.unspecified ip) = 0 -> Lwt.return_unit - | l -> - let pp_iplist fmt l = Format.pp_print_list Ipaddr.V6.pp 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); - Lwt.return_unit - - let connect ips udp tcp = - Log.info (fun f -> f "Manager: connect"); - let t = { tcp; udp } in - Log.info (fun f -> f "Manager: configuring"); - configure t ips >|= fun () -> - t + let connect udp tcp = + Log.info (fun f -> f "IPv6 socket stack: connect"); + Lwt.return { tcp; udp } let disconnect _ = Lwt.return_unit end @@ -303,22 +275,9 @@ module V4V6 = struct let t, _ = Lwt.task () in t (* TODO cancellation *) - (* List of IP addresses to bind to *) - let configure _t addrs = - match addrs with - | [] -> Lwt.return_unit - | l -> - let pp_iplist fmt l = Format.pp_print_list Ipaddr.pp 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); - Lwt.return_unit - - let connect ips udp tcp = - Log.info (fun f -> f "Manager: connect"); - let t = { tcp; udp } in - Log.info (fun f -> f "Manager: configuring"); - configure t ips >|= fun () -> - t + let connect udp tcp = + Log.info (fun f -> f "Dual IPv4 and IPv6 socket stack: connect"); + Lwt.return { tcp; udp } let disconnect _ = Lwt.return_unit end diff --git a/src/stack-unix/tcpip_stack_socket.mli b/src/stack-unix/tcpip_stack_socket.mli index 5be5c351f..11916ca36 100644 --- a/src/stack-unix/tcpip_stack_socket.mli +++ b/src/stack-unix/tcpip_stack_socket.mli @@ -19,7 +19,7 @@ module V4 : sig with module UDPV4 = Udpv4_socket and module TCPV4 = Tcpv4_socket and module IPV4 = Ipv4_socket - val connect : Ipaddr.V4.t list -> Udpv4_socket.t -> Tcpv4_socket.t -> t Lwt.t + val connect : Udpv4_socket.t -> Tcpv4_socket.t -> t Lwt.t end module V6 : sig @@ -27,7 +27,7 @@ module V6 : sig with module UDP = Udpv6_socket and module TCP = Tcpv6_socket and module IP = Ipv6_socket - val connect : Ipaddr.V6.t list -> Udpv6_socket.t -> Tcpv6_socket.t -> t Lwt.t + val connect : Udpv6_socket.t -> Tcpv6_socket.t -> t Lwt.t end module V4V6 : sig @@ -35,5 +35,5 @@ module V4V6 : sig with module UDP = Udpv4v6_socket and module TCP = Tcpv4v6_socket and module IP = Ipv4v6_socket - val connect : Ipaddr.t list -> Udpv4v6_socket.t -> Tcpv4v6_socket.t -> t Lwt.t + val connect : Udpv4v6_socket.t -> Tcpv4v6_socket.t -> t Lwt.t end From 98de8a21a2bf6d8a1c25457453b9ab7fd6a6853d Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 30 Sep 2020 19:41:26 +0200 Subject: [PATCH 09/18] stack-socket: further cleanups --- src/stack-unix/ipv4_socket.ml | 17 ++++++------- src/stack-unix/ipv4v6_socket.ml | 15 +++++------ src/stack-unix/ipv6_socket.ml | 16 +++++------- src/stack-unix/tcpip_stack_socket.ml | 2 +- src/stack-unix/tcpv4v6_socket.ml | 19 +++++++++----- src/stack-unix/tcpv4v6_socket.mli | 2 +- src/stack-unix/udpv4_socket.ml | 13 ++-------- src/stack-unix/udpv4v6_socket.ml | 37 ++++++++++++++-------------- src/stack-unix/udpv6_socket.ml | 13 ++-------- 9 files changed, 56 insertions(+), 78 deletions(-) diff --git a/src/stack-unix/ipv4_socket.ml b/src/stack-unix/ipv4_socket.ml index 77e387f69..790a6bccf 100644 --- a/src/stack-unix/ipv4_socket.ml +++ b/src/stack-unix/ipv4_socket.ml @@ -14,25 +14,22 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt - -type t = Ipaddr.V4.t option -type +'a io = 'a Lwt.t +type t = unit type error = Mirage_protocols.Ip.error type ipaddr = Ipaddr.V4.t -type buffer = Cstruct.t -type callback = src:ipaddr -> dst:ipaddr -> buffer -> unit io +type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t let pp_error = Mirage_protocols.Ip.pp_error let pp_ipaddr = Ipaddr.V4.pp let mtu _ = 1500 - Ipv4_wire.sizeof_ipv4 -let disconnect _ = return_unit -let connect _ = return_unit +let disconnect _ = Lwt.return_unit +let connect _ = Lwt.return_unit -let input _ ~tcp:_ ~udp:_ ~default:_ _ = return_unit -let write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ = fail (Failure "Not implemented") +let input _ ~tcp:_ ~udp:_ ~default:_ _ = Lwt.return_unit +let write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ = + Lwt.fail (Failure "Not implemented") let get_ip _ = [Ipaddr.V4.any] let src _ ~dst:_ = raise (Failure "Not implemented") diff --git a/src/stack-unix/ipv4v6_socket.ml b/src/stack-unix/ipv4v6_socket.ml index 5606dbe9f..f8c49910c 100644 --- a/src/stack-unix/ipv4v6_socket.ml +++ b/src/stack-unix/ipv4v6_socket.ml @@ -14,25 +14,22 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt - type t = unit -type +'a io = 'a Lwt.t type error = Mirage_protocols.Ip.error type ipaddr = Ipaddr.t -type buffer = Cstruct.t -type callback = src:ipaddr -> dst:ipaddr -> buffer -> unit io +type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t let pp_error = Mirage_protocols.Ip.pp_error let pp_ipaddr = Ipaddr.pp let mtu _ = 1500 - Ipv6_wire.sizeof_ipv6 -let disconnect _ = return_unit -let connect _ = return_unit +let disconnect _ = Lwt.return_unit +let connect _ = Lwt.return_unit -let input _ ~tcp:_ ~udp:_ ~default:_ _ = return_unit -let write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ = fail (Failure "Not implemented") +let input _ ~tcp:_ ~udp:_ ~default:_ _ = Lwt.return_unit +let write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ = + Lwt.fail (Failure "Not implemented") let get_ip _ = [Ipaddr.V6 Ipaddr.V6.unspecified] let src _ ~dst:_ = raise (Failure "Not implemented") diff --git a/src/stack-unix/ipv6_socket.ml b/src/stack-unix/ipv6_socket.ml index 4300ca7b4..9507ec7b6 100644 --- a/src/stack-unix/ipv6_socket.ml +++ b/src/stack-unix/ipv6_socket.ml @@ -15,26 +15,22 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt - type t = unit -type +'a io = 'a Lwt.t type error = Mirage_protocols.Ip.error type ipaddr = Ipaddr.V6.t -type buffer = Cstruct.t -type callback = src:ipaddr -> dst:ipaddr -> buffer -> unit io +type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t let pp_error = Mirage_protocols.Ip.pp_error let pp_ipaddr = Ipaddr.V6.pp let mtu _ = 1500 - Ipv6_wire.sizeof_ipv6 -let id _ = () -let disconnect () = return_unit -let connect () = return_unit +let disconnect () = Lwt.return_unit +let connect () = Lwt.return_unit -let input _ ~tcp:_ ~udp:_ ~default:_ _ = return_unit -let write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ = fail (Failure "Not implemented") +let input _ ~tcp:_ ~udp:_ ~default:_ _ = Lwt.return_unit +let write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ = + Lwt.fail (Failure "Not implemented") let get_ip _ = [Ipaddr.V6.unspecified] let src _ ~dst:_ = raise (Failure "Not implemented") diff --git a/src/stack-unix/tcpip_stack_socket.ml b/src/stack-unix/tcpip_stack_socket.ml index b95fdc3c3..790c139cc 100644 --- a/src/stack-unix/tcpip_stack_socket.ml +++ b/src/stack-unix/tcpip_stack_socket.ml @@ -31,7 +31,7 @@ module V4 = struct let udpv4 { udpv4; _ } = udpv4 let tcpv4 { tcpv4; _ } = tcpv4 - let ipv4 _ = None + let ipv4 _ = () let err_invalid_port p = Printf.sprintf "invalid port number (%d)" p diff --git a/src/stack-unix/tcpv4v6_socket.ml b/src/stack-unix/tcpv4v6_socket.ml index 5c1e91841..b175a3bf1 100644 --- a/src/stack-unix/tcpv4v6_socket.ml +++ b/src/stack-unix/tcpv4v6_socket.ml @@ -27,11 +27,15 @@ type t = { include Tcp_socket -let connect addr = +let connect ipv4 ipv6 = let t = - match addr with - | None -> { interface=None } - | Some ip -> { interface=Some (Ipaddr_unix.to_inet_addr ip) } + let interface = + match ipv4, ipv6 with + | None, None -> None + | _, Some ip -> Some (Ipaddr_unix.V6.to_inet_addr ip) + | Some ip, _ -> Some (Ipaddr_unix.V4.to_inet_addr ip) + in + { interface } in Lwt.return t @@ -42,8 +46,11 @@ let dst fd = | Unix.ADDR_INET (ia,port) -> Ipaddr_unix.of_inet_addr ia,port let create_connection ?keepalive _t (dst,dst_port) = - let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in - Lwt_unix.(setsockopt fd IPV6_ONLY false); + let family = match dst with + | Ipaddr.V4 _ -> Lwt_unix.PF_INET + | Ipaddr.V6 _ -> Lwt_unix.PF_INET6 + in + let fd = Lwt_unix.(socket family SOCK_STREAM 0) in Lwt.catch (fun () -> Lwt_unix.connect fd (Lwt_unix.ADDR_INET ((Ipaddr_unix.to_inet_addr dst), dst_port)) diff --git a/src/stack-unix/tcpv4v6_socket.mli b/src/stack-unix/tcpv4v6_socket.mli index dfbc6647d..58a86d7d2 100644 --- a/src/stack-unix/tcpv4v6_socket.mli +++ b/src/stack-unix/tcpv4v6_socket.mli @@ -22,4 +22,4 @@ include Mirage_protocols.TCP and type error = [ Mirage_protocols.Tcp.error | `Exn of exn ] and type write_error = [ Mirage_protocols.Tcp.write_error | `Exn of exn ] -val connect : Ipaddr.t option -> t Lwt.t +val connect : Ipaddr.V4.t option -> Ipaddr.V6.t option -> t Lwt.t diff --git a/src/stack-unix/udpv4_socket.ml b/src/stack-unix/udpv4_socket.ml index fd468a971..eea1ae958 100644 --- a/src/stack-unix/udpv4_socket.ml +++ b/src/stack-unix/udpv4_socket.ml @@ -17,8 +17,6 @@ open Lwt.Infix type ipaddr = Ipaddr.V4.t -type flow = Lwt_unix.file_descr -type ip = Ipaddr.V4.t option (* source ip and port *) type ipinput = unit Lwt.t type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t @@ -43,7 +41,7 @@ type error = [`Sendto_failed] let pp_error ppf = function | `Sendto_failed -> Fmt.pf ppf "sendto failed to write any bytes" -let connect (id:ip) = +let connect id = let t = let listen_fds = Hashtbl.create 7 in let interface = @@ -55,14 +53,7 @@ let connect (id:ip) = let disconnect _ = Lwt.return_unit -let id { interface; _ } = - Some (Ipaddr_unix.V4.of_inet_addr_exn interface) - -(* FIXME: how does this work at all ?? *) - let input ~listeners:_ _ = - (* TODO terminate when signalled by disconnect *) - let t, _ = Lwt.task () in - t +let input ~listeners:_ _ = Lwt.return_unit let write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf = let open Lwt_unix in diff --git a/src/stack-unix/udpv4v6_socket.ml b/src/stack-unix/udpv4v6_socket.ml index 440088f5e..2aeb3b3b8 100644 --- a/src/stack-unix/udpv4v6_socket.ml +++ b/src/stack-unix/udpv4v6_socket.ml @@ -18,8 +18,6 @@ open Lwt.Infix type ipaddr = Ipaddr.t -type flow = Lwt_unix.file_descr -type ip = Ipaddr.t option (* source ip and port *) type ipinput = unit Lwt.t type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t @@ -28,12 +26,18 @@ type t = { listen_fds: ((Unix.inet_addr * int),Lwt_unix.file_descr) Hashtbl.t; (* UDPv6 fds bound to a particular source ip/port *) } -let get_udpv4v6_listening_fd {listen_fds;interface} port = +let get_udpv4v6_listening_fd {listen_fds;interface} ?dst port = try Lwt.return @@ Hashtbl.find listen_fds (interface,port) with Not_found -> - let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in - Lwt_unix.(setsockopt fd IPV6_ONLY false); + let family, sockopt = + match dst with + | Some (Ipaddr.V4 _) -> Lwt_unix.PF_INET, false + | Some (Ipaddr.V6 _) -> Lwt_unix.PF_INET6, false + | None -> Lwt_unix.PF_INET6, true + in + let fd = Lwt_unix.(socket family SOCK_DGRAM 0) in + if sockopt then Lwt_unix.(setsockopt fd IPV6_ONLY false); Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) >>= fun () -> Hashtbl.add listen_fds (interface, port) fd; @@ -45,26 +49,21 @@ type error = [`Sendto_failed] let pp_error ppf = function | `Sendto_failed -> Fmt.pf ppf "sendto failed to write any bytes" -let connect (id:ip) = +let connect ipv4 ipv6 = let t = let listen_fds = Hashtbl.create 7 in let interface = - match id with - | None -> Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified - | Some ip -> Ipaddr_unix.to_inet_addr ip + (* TODO handle Some _, Some _ case appropriately? *) + match ipv4, ipv6 with + | None, None -> Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified + | _, Some ip -> Ipaddr_unix.V6.to_inet_addr ip + | Some ip, _ -> Ipaddr_unix.V4.to_inet_addr ip in { interface; listen_fds } in Lwt.return t let disconnect _ = Lwt.return_unit -let id { interface; _ } = - Some (Ipaddr_unix.V6.of_inet_addr_exn interface) - -(* FIXME: how does this work at all ?? *) - let input ~listeners:_ _ = - (* TODO terminate when signalled by disconnect *) - let t, _ = Lwt.task () in - t +let input ~listeners:_ _ = Lwt.return_unit let write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf = let open Lwt_unix in @@ -76,7 +75,7 @@ let write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf = | n -> write_to_fd fd (Cstruct.sub buf n (Cstruct.len buf - n)) (* keep trying *) in ( match src_port with - | None -> get_udpv4v6_listening_fd t 0 - | Some port -> get_udpv4v6_listening_fd t port ) + | None -> get_udpv4v6_listening_fd t ~dst 0 + | Some port -> get_udpv4v6_listening_fd t ~dst port ) >>= fun fd -> write_to_fd fd buf diff --git a/src/stack-unix/udpv6_socket.ml b/src/stack-unix/udpv6_socket.ml index 1fe9fdcdb..ddb1d916e 100644 --- a/src/stack-unix/udpv6_socket.ml +++ b/src/stack-unix/udpv6_socket.ml @@ -18,8 +18,6 @@ open Lwt.Infix type ipaddr = Ipaddr.V6.t -type flow = Lwt_unix.file_descr -type ip = Ipaddr.V6.t option (* source ip and port *) type ipinput = unit Lwt.t type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t @@ -45,7 +43,7 @@ type error = [`Sendto_failed] let pp_error ppf = function | `Sendto_failed -> Fmt.pf ppf "sendto failed to write any bytes" -let connect (id:ip) = +let connect id = let t = let listen_fds = Hashtbl.create 7 in let interface = @@ -57,14 +55,7 @@ let connect (id:ip) = let disconnect _ = Lwt.return_unit -let id { interface; _ } = - Some (Ipaddr_unix.V6.of_inet_addr_exn interface) - -(* FIXME: how does this work at all ?? *) - let input ~listeners:_ _ = - (* TODO terminate when signalled by disconnect *) - let t, _ = Lwt.task () in - t +let input ~listeners:_ _ = Lwt.return_unit let write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf = let open Lwt_unix in From 8a270d54d6e0e9b0c886be3f8e2382bd5b50b821 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 30 Sep 2020 20:02:24 +0200 Subject: [PATCH 10/18] stack-socket: listen_tcp bind to given IP address --- src/stack-unix/tcpip_stack_socket.ml | 18 +++++--------- src/stack-unix/tcpv4v6_socket.ml | 30 +++++++++++------------ src/stack-unix/tcpv4v6_socket.mli | 2 +- src/stack-unix/udpv4v6_socket.ml | 36 ++++++++++++---------------- 4 files changed, 37 insertions(+), 49 deletions(-) diff --git a/src/stack-unix/tcpip_stack_socket.ml b/src/stack-unix/tcpip_stack_socket.ml index 790c139cc..340736667 100644 --- a/src/stack-unix/tcpip_stack_socket.ml +++ b/src/stack-unix/tcpip_stack_socket.ml @@ -61,17 +61,15 @@ module V4 = struct in loop ()) - let listen_tcpv4 ?keepalive _t ~port callback = + let listen_tcpv4 ?keepalive t ~port callback = if port < 0 || port > 65535 then raise (Invalid_argument (err_invalid_port port)) else let fd = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; - (* 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 *) Lwt.async (fun () -> - Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) >>= fun () -> + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (t.udpv4.interface, port)) >>= fun () -> Lwt_unix.listen fd 10; (* TODO cancellation *) let rec loop () = @@ -148,18 +146,16 @@ module V6 = struct in loop ()) - let listen_tcp ?keepalive _t ~port callback = + let listen_tcp ?keepalive t ~port callback = if port < 0 || port > 65535 then raise (Invalid_argument (err_invalid_port port)) else let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; Lwt_unix.(setsockopt fd IPV6_ONLY true); - (* 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.V6.to_inet_addr Ipaddr.V6.unspecified in (* FIXME: we should not ignore the result *) Lwt.async (fun () -> - Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) >>= fun () -> + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (t.udp.interface, port)) >>= fun () -> Lwt_unix.listen fd 10; (* TODO cancellation *) let rec loop () = @@ -236,18 +232,16 @@ module V4V6 = struct in loop ()) - let listen_tcp ?keepalive _t ~port callback = + let listen_tcp ?keepalive t ~port callback = if port < 0 || port > 65535 then raise (Invalid_argument (err_invalid_port port)) else let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; Lwt_unix.(setsockopt fd IPV6_ONLY false); - (* 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.V6.to_inet_addr Ipaddr.V6.unspecified in (* FIXME: we should not ignore the result *) Lwt.async (fun () -> - Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) >>= fun () -> + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (t.udp.interface, port)) >>= fun () -> Lwt_unix.listen fd 10; (* TODO cancellation *) let rec loop () = diff --git a/src/stack-unix/tcpv4v6_socket.ml b/src/stack-unix/tcpv4v6_socket.ml index b175a3bf1..c9d6e6ea1 100644 --- a/src/stack-unix/tcpv4v6_socket.ml +++ b/src/stack-unix/tcpv4v6_socket.ml @@ -28,16 +28,19 @@ type t = { include Tcp_socket let connect ipv4 ipv6 = - let t = - let interface = - match ipv4, ipv6 with - | None, None -> None - | _, Some ip -> Some (Ipaddr_unix.V6.to_inet_addr ip) - | Some ip, _ -> Some (Ipaddr_unix.V4.to_inet_addr ip) - in - { interface } - in - Lwt.return t + begin + match ipv6, Ipaddr.V4.(compare ipv4 any) with + | None, 0 -> Lwt.return None + | None, _ -> Lwt.return (Some (Ipaddr_unix.V4.to_inet_addr ipv4)) + | Some x, 0 -> + if Ipaddr.V6.(compare unspecified x = 0) then + Lwt.return None + else + Lwt.return (Some (Ipaddr_unix.V6.to_inet_addr x)) + | _ -> + Lwt.fail_with "Both IPv4 and IPv6 address provided to the socket stack" + end >|= fun interface -> + {interface} let dst fd = match Lwt_unix.getpeername fd with @@ -46,11 +49,8 @@ let dst fd = | Unix.ADDR_INET (ia,port) -> Ipaddr_unix.of_inet_addr ia,port let create_connection ?keepalive _t (dst,dst_port) = - let family = match dst with - | Ipaddr.V4 _ -> Lwt_unix.PF_INET - | Ipaddr.V6 _ -> Lwt_unix.PF_INET6 - in - let fd = Lwt_unix.(socket family SOCK_STREAM 0) in + let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in + Lwt_unix.(setsockopt fd IPV6_ONLY false); Lwt.catch (fun () -> Lwt_unix.connect fd (Lwt_unix.ADDR_INET ((Ipaddr_unix.to_inet_addr dst), dst_port)) diff --git a/src/stack-unix/tcpv4v6_socket.mli b/src/stack-unix/tcpv4v6_socket.mli index 58a86d7d2..8b5235dc6 100644 --- a/src/stack-unix/tcpv4v6_socket.mli +++ b/src/stack-unix/tcpv4v6_socket.mli @@ -22,4 +22,4 @@ include Mirage_protocols.TCP and type error = [ Mirage_protocols.Tcp.error | `Exn of exn ] and type write_error = [ Mirage_protocols.Tcp.write_error | `Exn of exn ] -val connect : Ipaddr.V4.t option -> Ipaddr.V6.t option -> t Lwt.t +val connect : Ipaddr.V4.t -> Ipaddr.V6.t option -> t Lwt.t diff --git a/src/stack-unix/udpv4v6_socket.ml b/src/stack-unix/udpv4v6_socket.ml index 2aeb3b3b8..c9521a4a0 100644 --- a/src/stack-unix/udpv4v6_socket.ml +++ b/src/stack-unix/udpv4v6_socket.ml @@ -26,18 +26,12 @@ type t = { listen_fds: ((Unix.inet_addr * int),Lwt_unix.file_descr) Hashtbl.t; (* UDPv6 fds bound to a particular source ip/port *) } -let get_udpv4v6_listening_fd {listen_fds;interface} ?dst port = +let get_udpv4v6_listening_fd {listen_fds;interface} port = try Lwt.return @@ Hashtbl.find listen_fds (interface,port) with Not_found -> - let family, sockopt = - match dst with - | Some (Ipaddr.V4 _) -> Lwt_unix.PF_INET, false - | Some (Ipaddr.V6 _) -> Lwt_unix.PF_INET6, false - | None -> Lwt_unix.PF_INET6, true - in - let fd = Lwt_unix.(socket family SOCK_DGRAM 0) in - if sockopt then Lwt_unix.(setsockopt fd IPV6_ONLY false); + let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in + Lwt_unix.(setsockopt fd IPV6_ONLY false); Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) >>= fun () -> Hashtbl.add listen_fds (interface, port) fd; @@ -50,16 +44,16 @@ let pp_error ppf = function | `Sendto_failed -> Fmt.pf ppf "sendto failed to write any bytes" let connect ipv4 ipv6 = - let t = - let listen_fds = Hashtbl.create 7 in - let interface = - (* TODO handle Some _, Some _ case appropriately? *) - match ipv4, ipv6 with - | None, None -> Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified - | _, Some ip -> Ipaddr_unix.V6.to_inet_addr ip - | Some ip, _ -> Ipaddr_unix.V4.to_inet_addr ip - in { interface; listen_fds } - in Lwt.return t + begin + match ipv6, Ipaddr.V4.(compare ipv4 any) with + | None, 0 -> Lwt.return (Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified) + | None, _ -> Lwt.return (Ipaddr_unix.V4.to_inet_addr ipv4) + | Some x, 0 -> Lwt.return (Ipaddr_unix.V6.to_inet_addr x) + | _ -> + Lwt.fail_with "Both IPv4 and IPv6 address provided to the socket stack" + end >|= fun interface -> + let listen_fds = Hashtbl.create 7 in + { interface; listen_fds } let disconnect _ = Lwt.return_unit @@ -75,7 +69,7 @@ let write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf = | n -> write_to_fd fd (Cstruct.sub buf n (Cstruct.len buf - n)) (* keep trying *) in ( match src_port with - | None -> get_udpv4v6_listening_fd t ~dst 0 - | Some port -> get_udpv4v6_listening_fd t ~dst port ) + | None -> get_udpv4v6_listening_fd t 0 + | Some port -> get_udpv4v6_listening_fd t port ) >>= fun fd -> write_to_fd fd buf From b523ddf6b8a911d1b36886a4ceb0185b14a068ec Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 30 Sep 2020 20:18:53 +0200 Subject: [PATCH 11/18] stack-socket: tcp: bind to given IP address and use prefix.t The motivation is to unify the socket and direct stack configuration, and being able to reuse the same command line arguments. --- src/stack-unix/tcpv4_socket.ml | 11 ++++------- src/stack-unix/tcpv4_socket.mli | 2 +- src/stack-unix/tcpv4v6_socket.ml | 18 ++++++++---------- src/stack-unix/tcpv4v6_socket.mli | 2 +- src/stack-unix/tcpv6_socket.ml | 13 +++++++------ src/stack-unix/tcpv6_socket.mli | 2 +- src/stack-unix/udpv4_socket.ml | 12 +++++------- src/stack-unix/udpv4v6_socket.ml | 7 ++++--- src/stack-unix/udpv6_socket.ml | 8 +++++--- 9 files changed, 36 insertions(+), 39 deletions(-) diff --git a/src/stack-unix/tcpv4_socket.ml b/src/stack-unix/tcpv4_socket.ml index b13836aa2..f55a43f83 100644 --- a/src/stack-unix/tcpv4_socket.ml +++ b/src/stack-unix/tcpv4_socket.ml @@ -21,17 +21,13 @@ type flow = Lwt_unix.file_descr type ipinput = unit Lwt.t type t = { - interface: Unix.inet_addr option; (* source ip to bind to *) + interface: Unix.inet_addr; (* source ip to bind to *) } include Tcp_socket let connect addr = - let t = - match addr with - | None -> { interface=None } - | Some ip -> { interface=Some (Ipaddr_unix.V4.to_inet_addr ip) } - in + let t = { interface = Ipaddr_unix.V4.to_inet_addr (Ipaddr.V4.Prefix.address addr) } in Lwt.return t let dst fd = @@ -44,9 +40,10 @@ let dst fd = | Some ip -> ip,port end -let create_connection ?keepalive _t (dst,dst_port) = +let create_connection ?keepalive t (dst,dst_port) = let fd = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in Lwt.catch (fun () -> + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (t.interface, 0)) >>= fun () -> Lwt_unix.connect fd (Lwt_unix.ADDR_INET ((Ipaddr_unix.V4.to_inet_addr dst), dst_port)) >>= fun () -> diff --git a/src/stack-unix/tcpv4_socket.mli b/src/stack-unix/tcpv4_socket.mli index 2ea3dc8d2..e8f6afb0f 100644 --- a/src/stack-unix/tcpv4_socket.mli +++ b/src/stack-unix/tcpv4_socket.mli @@ -21,4 +21,4 @@ include Mirage_protocols.TCP and type error = [ Mirage_protocols.Tcp.error | `Exn of exn ] and type write_error = [ Mirage_protocols.Tcp.write_error | `Exn of exn ] -val connect : Ipaddr.V4.t option -> t Lwt.t +val connect : Ipaddr.V4.Prefix.t -> t Lwt.t diff --git a/src/stack-unix/tcpv4v6_socket.ml b/src/stack-unix/tcpv4v6_socket.ml index c9d6e6ea1..e79af6cf8 100644 --- a/src/stack-unix/tcpv4v6_socket.ml +++ b/src/stack-unix/tcpv4v6_socket.ml @@ -22,21 +22,18 @@ type flow = Lwt_unix.file_descr type ipinput = unit Lwt.t type t = { - interface: Unix.inet_addr option; (* source ip to bind to *) + interface: Unix.inet_addr; (* source ip to bind to *) } include Tcp_socket let connect ipv4 ipv6 = begin - match ipv6, Ipaddr.V4.(compare ipv4 any) with - | None, 0 -> Lwt.return None - | None, _ -> Lwt.return (Some (Ipaddr_unix.V4.to_inet_addr ipv4)) - | Some x, 0 -> - if Ipaddr.V6.(compare unspecified x = 0) then - Lwt.return None - else - Lwt.return (Some (Ipaddr_unix.V6.to_inet_addr x)) + let v4 = Ipaddr.V4.Prefix.address ipv4 in + match ipv6, Ipaddr.V4.(compare v4 any) with + | None, 0 -> Lwt.return (Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified) + | None, _ -> Lwt.return (Ipaddr_unix.V4.to_inet_addr v4) + | Some x, 0 -> Lwt.return (Ipaddr_unix.V6.to_inet_addr (Ipaddr.V6.Prefix.address x)) | _ -> Lwt.fail_with "Both IPv4 and IPv6 address provided to the socket stack" end >|= fun interface -> @@ -48,10 +45,11 @@ let dst fd = raise (Failure "unexpected: got a unix instead of tcp sock") | Unix.ADDR_INET (ia,port) -> Ipaddr_unix.of_inet_addr ia,port -let create_connection ?keepalive _t (dst,dst_port) = +let create_connection ?keepalive t (dst,dst_port) = let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in Lwt_unix.(setsockopt fd IPV6_ONLY false); Lwt.catch (fun () -> + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (t.interface, 0)) >>= fun () -> Lwt_unix.connect fd (Lwt_unix.ADDR_INET ((Ipaddr_unix.to_inet_addr dst), dst_port)) >>= fun () -> diff --git a/src/stack-unix/tcpv4v6_socket.mli b/src/stack-unix/tcpv4v6_socket.mli index 8b5235dc6..cfcfa9be0 100644 --- a/src/stack-unix/tcpv4v6_socket.mli +++ b/src/stack-unix/tcpv4v6_socket.mli @@ -22,4 +22,4 @@ include Mirage_protocols.TCP and type error = [ Mirage_protocols.Tcp.error | `Exn of exn ] and type write_error = [ Mirage_protocols.Tcp.write_error | `Exn of exn ] -val connect : Ipaddr.V4.t -> Ipaddr.V6.t option -> t Lwt.t +val connect : Ipaddr.V4.Prefix.t -> Ipaddr.V6.Prefix.t option -> t Lwt.t diff --git a/src/stack-unix/tcpv6_socket.ml b/src/stack-unix/tcpv6_socket.ml index d01514453..e44aa3ce1 100644 --- a/src/stack-unix/tcpv6_socket.ml +++ b/src/stack-unix/tcpv6_socket.ml @@ -22,18 +22,18 @@ type flow = Lwt_unix.file_descr type ipinput = unit Lwt.t type t = { - interface: Unix.inet_addr option; (* source ip to bind to *) + interface: Unix.inet_addr; (* source ip to bind to *) } include Tcp_socket let connect addr = - let t = + let ip = match addr with - | None -> { interface=None } - | Some ip -> { interface=Some (Ipaddr_unix.V6.to_inet_addr ip) } + | None -> Ipaddr.V6.unspecified + | Some ip -> Ipaddr.V6.Prefix.address ip in - Lwt.return t + Lwt.return { interface = Ipaddr_unix.V6.to_inet_addr ip } let dst fd = match Lwt_unix.getpeername fd with @@ -45,10 +45,11 @@ let dst fd = | Some ip -> ip,port end -let create_connection ?keepalive _t (dst,dst_port) = +let create_connection ?keepalive t (dst,dst_port) = let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in Lwt_unix.(setsockopt fd IPV6_ONLY true); Lwt.catch (fun () -> + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (t.interface, 0)) >>= fun () -> Lwt_unix.connect fd (Lwt_unix.ADDR_INET ((Ipaddr_unix.V6.to_inet_addr dst), dst_port)) >>= fun () -> diff --git a/src/stack-unix/tcpv6_socket.mli b/src/stack-unix/tcpv6_socket.mli index ae483bfc3..3ef3f94aa 100644 --- a/src/stack-unix/tcpv6_socket.mli +++ b/src/stack-unix/tcpv6_socket.mli @@ -22,4 +22,4 @@ include Mirage_protocols.TCP and type error = [ Mirage_protocols.Tcp.error | `Exn of exn ] and type write_error = [ Mirage_protocols.Tcp.write_error | `Exn of exn ] -val connect : Ipaddr.V6.t option -> t Lwt.t +val connect : Ipaddr.V6.Prefix.t option -> t Lwt.t diff --git a/src/stack-unix/udpv4_socket.ml b/src/stack-unix/udpv4_socket.ml index eea1ae958..81ac366bc 100644 --- a/src/stack-unix/udpv4_socket.ml +++ b/src/stack-unix/udpv4_socket.ml @@ -41,15 +41,13 @@ type error = [`Sendto_failed] let pp_error ppf = function | `Sendto_failed -> Fmt.pf ppf "sendto failed to write any bytes" -let connect id = +let connect ip = let t = let listen_fds = Hashtbl.create 7 in - let interface = - match id with - | None -> Ipaddr_unix.V4.to_inet_addr Ipaddr.V4.any - | Some ip -> Ipaddr_unix.V4.to_inet_addr ip - in { interface; listen_fds } - in Lwt.return t + let interface = Ipaddr_unix.V4.to_inet_addr (Ipaddr.V4.Prefix.address ip) in + { interface; listen_fds } + in + Lwt.return t let disconnect _ = Lwt.return_unit diff --git a/src/stack-unix/udpv4v6_socket.ml b/src/stack-unix/udpv4v6_socket.ml index c9521a4a0..4926a8c25 100644 --- a/src/stack-unix/udpv4v6_socket.ml +++ b/src/stack-unix/udpv4v6_socket.ml @@ -45,10 +45,11 @@ let pp_error ppf = function let connect ipv4 ipv6 = begin - match ipv6, Ipaddr.V4.(compare ipv4 any) with + let v4 = Ipaddr.V4.Prefix.address ipv4 in + match ipv6, Ipaddr.V4.(compare v4 any) with | None, 0 -> Lwt.return (Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified) - | None, _ -> Lwt.return (Ipaddr_unix.V4.to_inet_addr ipv4) - | Some x, 0 -> Lwt.return (Ipaddr_unix.V6.to_inet_addr x) + | None, _ -> Lwt.return (Ipaddr_unix.V4.to_inet_addr v4) + | Some x, 0 -> Lwt.return (Ipaddr_unix.V6.to_inet_addr (Ipaddr.V6.Prefix.address x)) | _ -> Lwt.fail_with "Both IPv4 and IPv6 address provided to the socket stack" end >|= fun interface -> diff --git a/src/stack-unix/udpv6_socket.ml b/src/stack-unix/udpv6_socket.ml index ddb1d916e..26a1c313a 100644 --- a/src/stack-unix/udpv6_socket.ml +++ b/src/stack-unix/udpv6_socket.ml @@ -49,9 +49,11 @@ let connect id = let interface = match id with | None -> Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified - | Some ip -> Ipaddr_unix.V6.to_inet_addr ip - in { interface; listen_fds } - in Lwt.return t + | Some ip -> Ipaddr_unix.V6.to_inet_addr (Ipaddr.V6.Prefix.address ip) + in + { interface; listen_fds } + in + Lwt.return t let disconnect _ = Lwt.return_unit From 76b857821c1af5d4bfd603b0df790e04489d4159 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 30 Sep 2020 21:28:12 +0200 Subject: [PATCH 12/18] stack-socket: refactor --- src/stack-unix/tcpip_stack_socket.ml | 108 +++++++++++++++------------ src/stack-unix/tcpv4v6_socket.ml | 34 ++++++--- src/stack-unix/udpv4v6_socket.ml | 81 ++++++++++++++------ 3 files changed, 141 insertions(+), 82 deletions(-) diff --git a/src/stack-unix/tcpip_stack_socket.ml b/src/stack-unix/tcpip_stack_socket.ml index 340736667..45dadc3c8 100644 --- a/src/stack-unix/tcpip_stack_socket.ml +++ b/src/stack-unix/tcpip_stack_socket.ml @@ -212,58 +212,72 @@ module V4V6 = struct else (* FIXME: we should not ignore the result *) Lwt.async (fun () -> - UDP.get_udpv4v6_listening_fd t.udp port >>= fun fd -> - let buf = Cstruct.create 4096 in - let rec loop () = - (* 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.of_inet_addr addr in - let dst = Ipaddr.(V6 V6.unspecified) 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 ()) + UDP.get_udpv4v6_listening_fd t.udp port >|= fun fds -> + List.iter (fun fd -> + Lwt.async (fun () -> + let buf = Cstruct.create 4096 in + let rec loop () = + (* 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.of_inet_addr addr in + let dst = Ipaddr.(V6 V6.unspecified) 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 ())) fds) let listen_tcp ?keepalive t ~port callback = if port < 0 || port > 65535 then raise (Invalid_argument (err_invalid_port port)) else - let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in - Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; - Lwt_unix.(setsockopt fd IPV6_ONLY false); - (* FIXME: we should not ignore the result *) - Lwt.async (fun () -> - Lwt_unix.bind fd (Lwt_unix.ADDR_INET (t.udp.interface, port)) >>= fun () -> - Lwt_unix.listen fd 10; - (* TODO cancellation *) - let rec 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 fds = + match t.udp.interface with + | `Any -> + let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in + Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; + Lwt_unix.(setsockopt fd IPV6_ONLY false); + [ (fd, Lwt_unix.ADDR_INET (UDP.any_v6, port)) ] + | `Ip (v4, v6) -> + let fd = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in + Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; + let fd' = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in + Lwt_unix.setsockopt fd' Lwt_unix.SO_REUSEADDR true; + [ (fd, Lwt_unix.ADDR_INET (v4, port)) ; (fd', Lwt_unix.ADDR_INET (v6, port)) ] + in + List.iter (fun (fd, addr) -> + (* FIXME: we should not ignore the result *) + Lwt.async (fun () -> + Lwt_unix.bind fd addr >>= fun () -> + Lwt_unix.listen fd 10; + (* TODO cancellation *) + let rec 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 ())) fds let listen _t = let t, _ = Lwt.task () in diff --git a/src/stack-unix/tcpv4v6_socket.ml b/src/stack-unix/tcpv4v6_socket.ml index e79af6cf8..e8827ae95 100644 --- a/src/stack-unix/tcpv4v6_socket.ml +++ b/src/stack-unix/tcpv4v6_socket.ml @@ -22,22 +22,27 @@ type flow = Lwt_unix.file_descr type ipinput = unit Lwt.t type t = { - interface: Unix.inet_addr; (* source ip to bind to *) + interface: [ `Any | `Ip of Unix.inet_addr * Unix.inet_addr ]; (* source ip to bind to *) } include Tcp_socket let connect ipv4 ipv6 = - begin + let interface = let v4 = Ipaddr.V4.Prefix.address ipv4 in + let v4_unix = Ipaddr_unix.V4.to_inet_addr v4 in + let any_v6 = Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified in match ipv6, Ipaddr.V4.(compare v4 any) with - | None, 0 -> Lwt.return (Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified) - | None, _ -> Lwt.return (Ipaddr_unix.V4.to_inet_addr v4) - | Some x, 0 -> Lwt.return (Ipaddr_unix.V6.to_inet_addr (Ipaddr.V6.Prefix.address x)) - | _ -> - Lwt.fail_with "Both IPv4 and IPv6 address provided to the socket stack" - end >|= fun interface -> - {interface} + | None, 0 -> `Any + | None, _ -> `Ip (v4_unix, any_v6) + | Some x, v4_any -> + let v6 = Ipaddr.V6.Prefix.address x in + if Ipaddr.V6.(compare v6 unspecified = 0) && v4_any = 0 then + `Any + else + `Ip (v4_unix, Ipaddr_unix.V6.to_inet_addr v6) + in + Lwt.return {interface} let dst fd = match Lwt_unix.getpeername fd with @@ -46,10 +51,15 @@ let dst fd = | Unix.ADDR_INET (ia,port) -> Ipaddr_unix.of_inet_addr ia,port let create_connection ?keepalive t (dst,dst_port) = - let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in - Lwt_unix.(setsockopt fd IPV6_ONLY false); + let family, proj = match dst with + | Ipaddr.V4 _ -> Lwt_unix.PF_INET, fst + | Ipaddr.V6 _ -> Lwt_unix.PF_INET6, snd + in + let fd = Lwt_unix.(socket family SOCK_STREAM 0) in Lwt.catch (fun () -> - Lwt_unix.bind fd (Lwt_unix.ADDR_INET (t.interface, 0)) >>= fun () -> + (match t.interface with + | `Any -> Lwt.return_unit + | `Ip p -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (proj p, 0))) >>= fun () -> Lwt_unix.connect fd (Lwt_unix.ADDR_INET ((Ipaddr_unix.to_inet_addr dst), dst_port)) >>= fun () -> diff --git a/src/stack-unix/udpv4v6_socket.ml b/src/stack-unix/udpv4v6_socket.ml index 4926a8c25..ebcb85da8 100644 --- a/src/stack-unix/udpv4v6_socket.ml +++ b/src/stack-unix/udpv4v6_socket.ml @@ -21,21 +21,34 @@ type ipaddr = Ipaddr.t type ipinput = unit Lwt.t type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t +let any_v6 = Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified + type t = { - interface: Unix.inet_addr; (* source ip to bind to *) - listen_fds: ((Unix.inet_addr * int),Lwt_unix.file_descr) Hashtbl.t; (* UDPv6 fds bound to a particular source ip/port *) + interface: [ `Any | `Ip of Unix.inet_addr * Unix.inet_addr ]; (* source ip to bind to *) + listen_fds: (int,Lwt_unix.file_descr * Lwt_unix.file_descr option) Hashtbl.t; (* UDP fds bound to a particular port *) } let get_udpv4v6_listening_fd {listen_fds;interface} port = try - Lwt.return @@ Hashtbl.find listen_fds (interface,port) + Lwt.return + (match Hashtbl.find listen_fds port with + | fd, None -> [ fd ] + | fd, Some fd' -> [ fd ; fd' ]) with Not_found -> - let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in - Lwt_unix.(setsockopt fd IPV6_ONLY false); - Lwt_unix.bind fd (Lwt_unix.ADDR_INET (interface, port)) - >>= fun () -> - Hashtbl.add listen_fds (interface, port) fd; - Lwt.return fd + (match interface with + | `Any -> + let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in + Lwt_unix.(setsockopt fd IPV6_ONLY false); + Lwt.return ((fd, None), [ fd ]) + | `Ip (v4, v6) -> + let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (v4, port)) >>= fun () -> + let fd' = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in + Lwt_unix.(setsockopt fd' IPV6_ONLY true); + Lwt_unix.bind fd' (Lwt_unix.ADDR_INET (v6, port)) >|= fun () -> + ((fd, Some fd'), [ fd ; fd' ])) >|= fun (fds, r) -> + Hashtbl.add listen_fds port fds; + r type error = [`Sendto_failed] @@ -44,22 +57,45 @@ let pp_error ppf = function | `Sendto_failed -> Fmt.pf ppf "sendto failed to write any bytes" let connect ipv4 ipv6 = - begin - let v4 = Ipaddr.V4.Prefix.address ipv4 in + let v4 = Ipaddr.V4.Prefix.address ipv4 in + let v4_unix = Ipaddr_unix.V4.to_inet_addr v4 in + let interface = match ipv6, Ipaddr.V4.(compare v4 any) with - | None, 0 -> Lwt.return (Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified) - | None, _ -> Lwt.return (Ipaddr_unix.V4.to_inet_addr v4) - | Some x, 0 -> Lwt.return (Ipaddr_unix.V6.to_inet_addr (Ipaddr.V6.Prefix.address x)) - | _ -> - Lwt.fail_with "Both IPv4 and IPv6 address provided to the socket stack" - end >|= fun interface -> + | None, 0 -> `Any + | None, _ -> `Ip (v4_unix, any_v6) + | Some x, v4_any -> + let v6 = Ipaddr.V6.Prefix.address x in + if Ipaddr.V6.(compare v6 unspecified = 0) && v4_any = 0 then + `Any + else + `Ip (v4_unix, Ipaddr_unix.V6.to_inet_addr v6) + in let listen_fds = Hashtbl.create 7 in - { interface; listen_fds } + Lwt.return { interface; listen_fds } let disconnect _ = Lwt.return_unit let input ~listeners:_ _ = Lwt.return_unit +let create_socket t ?port dst = + let bind fd proj dfl = match t.interface, port with + | `Any, None -> Lwt.return_unit + | `Any, Some p -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (dfl, p)) + | `Ip p, _ -> + let port = match port with None -> 0 | Some p -> p in + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (proj p, port)) + in + match dst with + | Ipaddr.V4 _ -> + let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in + bind fd fst (Ipaddr_unix.V4.to_inet_addr Ipaddr.V4.any) >|= fun () -> + fd + | Ipaddr.V6 _ -> + let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in + Lwt_unix.(setsockopt fd IPV6_ONLY true); + bind fd snd any_v6 >|= fun () -> + fd + let write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf = let open Lwt_unix in let rec write_to_fd fd buf = @@ -69,8 +105,7 @@ let write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf = | 0 -> Lwt.return @@ Error `Sendto_failed | n -> write_to_fd fd (Cstruct.sub buf n (Cstruct.len buf - n)) (* keep trying *) in - ( match src_port with - | None -> get_udpv4v6_listening_fd t 0 - | Some port -> get_udpv4v6_listening_fd t port ) - >>= fun fd -> - write_to_fd fd buf + create_socket t ?port:src_port dst >>= fun fd -> + write_to_fd fd buf >>= fun r -> + Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >|= fun () -> + r From 23779dac80e2134850dcd6d9da4e28c6e9419b95 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 30 Sep 2020 22:45:48 +0200 Subject: [PATCH 13/18] stack-socket: bind in the socket in the udp dual stack case --- src/stack-unix/udpv4v6_socket.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/stack-unix/udpv4v6_socket.ml b/src/stack-unix/udpv4v6_socket.ml index ebcb85da8..61990cde3 100644 --- a/src/stack-unix/udpv4v6_socket.ml +++ b/src/stack-unix/udpv4v6_socket.ml @@ -39,7 +39,8 @@ let get_udpv4v6_listening_fd {listen_fds;interface} port = | `Any -> let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in Lwt_unix.(setsockopt fd IPV6_ONLY false); - Lwt.return ((fd, None), [ fd ]) + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (any_v6, port)) >|= fun () -> + ((fd, None), [ fd ]) | `Ip (v4, v6) -> let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in Lwt_unix.bind fd (Lwt_unix.ADDR_INET (v4, port)) >>= fun () -> From dee9e055202064ec5fc32175e4e58c7578b3697c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 30 Sep 2020 21:49:01 +0200 Subject: [PATCH 14/18] ipv6: revise connect --- src/ipv6/ipv6.ml | 39 ++++++++++++--------------------------- src/ipv6/ipv6.mli | 5 ++--- 2 files changed, 14 insertions(+), 30 deletions(-) diff --git a/src/ipv6/ipv6.ml b/src/ipv6/ipv6.ml index 1dd025bb0..46f3408b2 100644 --- a/src/ipv6/ipv6.ml +++ b/src/ipv6/ipv6.ml @@ -111,28 +111,9 @@ module Make (N : Mirage_net.S) let src t ~dst = Ndpv6.select_source t.ctx dst - let set_ip t ip = - let now = C.elapsed_ns () in - let ctx, outs = Ndpv6.add_ip ~now t.ctx ip in - t.ctx <- ctx; - (* MCP: replace the below *) - Lwt_list.iter_s (output_ign t) outs - let get_ip t = Ndpv6.get_ip t.ctx - let set_ip_gateways t ips = - let now = C.elapsed_ns () in - let ctx = Ndpv6.add_routers ~now t.ctx ips in - t.ctx <- ctx; - Lwt.return_unit - - let set_ip_netmask t pfx = - let now = C.elapsed_ns () in - let ctx = Ndpv6.add_prefix ~now t.ctx pfx in - t.ctx <- ctx; - Lwt.return_unit - let pseudoheader t ?src:source dst proto len = let ph = Cstruct.create (16 + 16 + 8) in let src = match source with None -> src t ~dst | Some x -> x in @@ -145,14 +126,21 @@ module Make (N : Mirage_net.S) Cstruct.set_uint8 ph 39 (Ipv6_wire.protocol_to_int proto); ph - let (>>=?) (x,f) g = match x with - | Some x -> f x >>= g - | None -> g () - - let connect ?ip ?netmask ?gateways netif ethif = + let connect ?cidr ?gateway netif ethif = Log.info (fun f -> f "IP6: Starting"); let now = C.elapsed_ns () in let ctx, outs = Ndpv6.local ~now ~random:R.generate (E.mac ethif) in + let ctx, outs = match cidr with + | None -> ctx, outs + | Some p -> + let ctx, outs' = Ndpv6.add_ip ~now ctx (Ipaddr.V6.Prefix.address p) in + let ctx = Ndpv6.add_prefix ~now ctx (Ipaddr.V6.Prefix.prefix p) in + ctx, outs @ outs' + in + let ctx = match gateway with + | None -> ctx + | Some ip -> Ndpv6.add_routers ~now ctx [ip] + in let t = {ctx; ethif} in let task, u = Lwt.task () in Lwt.async (fun () -> start_ticking t u); @@ -168,9 +156,6 @@ module Make (N : Mirage_net.S) Lwt.pick [ (* MCP: replace this error swallowing with proper propagation *) (Lwt_list.iter_s (output_ign t) outs >>= fun () -> - (ip, Lwt_list.iter_s (set_ip t)) >>=? fun () -> - (netmask, Lwt_list.iter_s (set_ip_netmask t)) >>=? fun () -> - (gateways, set_ip_gateways t) >>=? fun () -> task) ; (N.listen netif ~header_size:Ethernet_wire.sizeof_ethernet ethif_listener >|= fun _ -> ()) ; timeout diff --git a/src/ipv6/ipv6.mli b/src/ipv6/ipv6.mli index 0159024e4..552f26a15 100644 --- a/src/ipv6/ipv6.mli +++ b/src/ipv6/ipv6.mli @@ -21,8 +21,7 @@ module Make (N : Mirage_net.S) (Clock : Mirage_clock.MCLOCK) : sig include Mirage_protocols.IP with type ipaddr = Ipaddr.V6.t val connect : - ?ip:Ipaddr.V6.t list -> - ?netmask:Ipaddr.V6.Prefix.t list -> - ?gateways:Ipaddr.V6.t list -> + ?cidr:Ipaddr.V6.Prefix.t -> + ?gateway:Ipaddr.V6.t -> N.t -> E.t -> t Lwt.t end From 871ec7cc7565d48b1576a0ddd6d617b2d62fb6b4 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 1 Oct 2020 11:15:11 +0200 Subject: [PATCH 15/18] IPv6 direct stack: accept handle_ra argument to connect dual stack: accept ipv4_only and ipv6_only arguments fix tests with revised API --- src/ipv6/ipv6.ml | 4 +- src/ipv6/ipv6.mli | 1 + src/ipv6/ndpv6.ml | 19 ++++-- src/ipv6/ndpv6.mli | 4 +- src/stack-direct/tcpip_stack_direct.ml | 26 ++++++--- src/stack-direct/tcpip_stack_direct.mli | 2 +- src/stack-unix/tcpip_stack_socket.ml | 16 ++++- src/stack-unix/tcpv4v6_socket.ml | 78 +++++++++++++++---------- src/stack-unix/tcpv4v6_socket.mli | 2 +- src/stack-unix/udpv4v6_socket.ml | 75 +++++++++++++++--------- test/test_connect_ipv6.ml | 6 +- test/test_iperf_ipv6.ml | 6 +- test/test_ipv6.ml | 6 +- test/test_socket.ml | 17 +++--- test/vnetif_common.ml | 11 ++-- 15 files changed, 171 insertions(+), 102 deletions(-) diff --git a/src/ipv6/ipv6.ml b/src/ipv6/ipv6.ml index 46f3408b2..d05d2a390 100644 --- a/src/ipv6/ipv6.ml +++ b/src/ipv6/ipv6.ml @@ -126,10 +126,10 @@ module Make (N : Mirage_net.S) Cstruct.set_uint8 ph 39 (Ipv6_wire.protocol_to_int proto); ph - let connect ?cidr ?gateway netif ethif = + let connect ?(handle_ra = true) ?cidr ?gateway netif ethif = Log.info (fun f -> f "IP6: Starting"); let now = C.elapsed_ns () in - let ctx, outs = Ndpv6.local ~now ~random:R.generate (E.mac ethif) in + let ctx, outs = Ndpv6.local ~handle_ra ~now ~random:R.generate (E.mac ethif) in let ctx, outs = match cidr with | None -> ctx, outs | Some p -> diff --git a/src/ipv6/ipv6.mli b/src/ipv6/ipv6.mli index 552f26a15..9a2c91ae3 100644 --- a/src/ipv6/ipv6.mli +++ b/src/ipv6/ipv6.mli @@ -21,6 +21,7 @@ module Make (N : Mirage_net.S) (Clock : Mirage_clock.MCLOCK) : sig include Mirage_protocols.IP with type ipaddr = Ipaddr.V6.t val connect : + ?handle_ra:bool -> ?cidr:Ipaddr.V6.Prefix.t -> ?gateway:Ipaddr.V6.t -> N.t -> E.t -> t Lwt.t diff --git a/src/ipv6/ndpv6.ml b/src/ipv6/ndpv6.ml index 4ff1790fe..9bbf37650 100644 --- a/src/ipv6/ndpv6.ml +++ b/src/ipv6/ndpv6.ml @@ -1035,7 +1035,8 @@ type context = base_reachable_time : time; reachable_time : time; retrans_timer : time; - packet_queue : (int * (Cstruct.t -> int)) PacketQueue.t } + packet_queue : (int * (Cstruct.t -> int)) PacketQueue.t; + handle_ra : bool } let next_hop ctx ip = if PrefixList.is_local ctx.prefix_list ip then @@ -1109,7 +1110,7 @@ let send ~now ctx ?src dst proto size fillf = let siz, fill = Allocate.hdr ~hlim:ctx.cur_hop_limit ~src ~dst ~proto ~size fillf in send' ~now ctx dst siz fill -let local ~now ~random mac = +let local ~handle_ra ~now ~random mac = let ctx = { neighbor_cache = NeighborCache.empty; prefix_list = PrefixList.link_local; @@ -1121,7 +1122,8 @@ let local ~now ~random mac = base_reachable_time = Defaults.reachable_time; reachable_time = compute_reachable_time random Defaults.reachable_time; retrans_timer = Defaults.retrans_timer; - packet_queue = PacketQueue.empty 3 } + packet_queue = PacketQueue.empty 3; + handle_ra } in let ip = link_local_addr mac in let address_list, actions = @@ -1247,9 +1249,14 @@ let handle ~now ~random ctx buf = let open Parser in match packet (AddressList.is_my_addr ctx.address_list) buf with | RA (src, dst, ra) -> - let ctx, actions = handle_ra ~now ~random ctx ~src ~dst ra in - let ctx, bufs = process_actions ~now ctx actions in - ctx, bufs, [] + if ctx.handle_ra then + let ctx, actions = handle_ra ~now ~random ctx ~src ~dst ra in + let ctx, bufs = process_actions ~now ctx actions in + ctx, bufs, [] + else begin + Log.info (fun m -> m "Ignoring router advertisement (stack is configured to not handle them)"); + ctx, [], [] + end | NS (src, dst, ns) -> let ctx, actions = handle_ns ~now ctx ~src ~dst ns in let ctx, bufs = process_actions ~now ctx actions in diff --git a/src/ipv6/ndpv6.mli b/src/ipv6/ndpv6.mli index df2907ea1..5df9b2d71 100644 --- a/src/ipv6/ndpv6.mli +++ b/src/ipv6/ndpv6.mli @@ -30,9 +30,9 @@ type event = type context -val local : now:time -> random:(int -> Cstruct.t) -> Macaddr.t -> +val local : handle_ra:bool -> now:time -> random:(int -> Cstruct.t) -> Macaddr.t -> context * (Macaddr.t * int * (buffer -> int)) list -(** [local ~now ~random mac] is a pair [ctx, outs] where [ctx] is a local IPv6 context +(** [local ~handle_ra ~now ~random mac] is a pair [ctx, outs] where [ctx] is a local IPv6 context associated to the hardware address [mac]. [outs] is a list of ethif packets to be sent. *) diff --git a/src/stack-direct/tcpip_stack_direct.ml b/src/stack-direct/tcpip_stack_direct.ml index afc7546ae..dfbc0340c 100644 --- a/src/stack-direct/tcpip_stack_direct.ml +++ b/src/stack-direct/tcpip_stack_direct.ml @@ -281,9 +281,13 @@ module IPV4V6 (Ipv4 : Mirage_protocols.IPV4) (Ipv6 : Mirage_protocols.IPV6) = st | `Ipv6 e -> Ipv6.pp_error ppf e | `Msg m -> Fmt.string ppf m - type t = { ipv4 : Ipv4.t ; ipv6 : Ipv6.t } + type t = { ipv4 : Ipv4.t ; ipv4_only : bool ; ipv6 : Ipv6.t ; ipv6_only : bool } - let connect ipv4 ipv6 = Lwt.return { ipv4 ; ipv6 } + let connect ~ipv4_only ~ipv6_only ipv4 ipv6 = + if ipv4_only && ipv6_only then + Lwt.fail_with "cannot configure stack with both IPv4 only and IPv6 only" + else + Lwt.return { ipv4 ; ipv4_only ; ipv6 ; ipv6_only } let disconnect _ = Lwt.return_unit @@ -298,9 +302,9 @@ module IPV4V6 (Ipv4 : Mirage_protocols.IPV4) (Ipv6 : Mirage_protocols.IPV6) = st fun buf -> if Cstruct.len buf >= 1 then let v = Cstruct.get_uint8 buf 0 lsr 4 in - if v = 4 then + if v = 4 && not t.ipv6_only then Ipv4.input t.ipv4 ~tcp:tcp4 ~udp:udp4 ~default:default4 buf - else if v = 6 then + else if v = 6 && not t.ipv4_only then Ipv6.input t.ipv6 ~tcp:tcp6 ~udp:udp6 ~default:default6 buf else Lwt.return_unit @@ -310,7 +314,7 @@ module IPV4V6 (Ipv4 : Mirage_protocols.IPV4) (Ipv6 : Mirage_protocols.IPV6) = st let write t ?fragment ?ttl ?src dst proto ?size headerf bufs = match dst with | Ipaddr.V4 dst -> - begin + if not t.ipv6_only then match match src with | None -> Ok None @@ -322,9 +326,12 @@ module IPV4V6 (Ipv4 : Mirage_protocols.IPV4) (Ipv6 : Mirage_protocols.IPV6) = st Ipv4.write t.ipv4 ?fragment ?ttl ?src dst proto ?size headerf bufs >|= function | Ok () -> Ok () | Error e -> Error (`Ipv4 e) + else begin + Log.warn (fun m -> m "attempted to write an IPv4 packet in a v6 only stack"); + Lwt.return (Ok ()) end | Ipaddr.V6 dst -> - begin + if not t.ipv4_only then match match src with | None -> Ok None @@ -336,6 +343,9 @@ module IPV4V6 (Ipv4 : Mirage_protocols.IPV4) (Ipv6 : Mirage_protocols.IPV6) = st Ipv6.write t.ipv6 ?fragment ?ttl ?src dst proto ?size headerf bufs >|= function | Ok () -> Ok () | Error e -> Error (`Ipv6 e) + else begin + Log.warn (fun m -> m "attempted to write an IPv6 packet in a v4 only stack"); + Lwt.return (Ok ()) end let pseudoheader t ?src dst proto len = @@ -345,7 +355,7 @@ module IPV4V6 (Ipv4 : Mirage_protocols.IPV4) (Ipv6 : Mirage_protocols.IPV6) = st match src with | None -> None | Some (Ipaddr.V4 src) -> Some src - | _ -> None (* TODO *) + | _ -> None (* cannot happen *) in Ipv4.pseudoheader t.ipv4 ?src dst proto len | Ipaddr.V6 dst -> @@ -353,7 +363,7 @@ module IPV4V6 (Ipv4 : Mirage_protocols.IPV4) (Ipv6 : Mirage_protocols.IPV6) = st match src with | None -> None | Some (Ipaddr.V6 src) -> Some src - | _ -> None (* TODO *) + | _ -> None (* cannot happen *) in Ipv6.pseudoheader t.ipv6 ?src dst proto len diff --git a/src/stack-direct/tcpip_stack_direct.mli b/src/stack-direct/tcpip_stack_direct.mli index e7a5a7dc1..4f8da4f3c 100644 --- a/src/stack-direct/tcpip_stack_direct.mli +++ b/src/stack-direct/tcpip_stack_direct.mli @@ -92,7 +92,7 @@ module type TCPV4V6_DIRECT = Mirage_protocols.TCP module IPV4V6 (Ipv4 : Mirage_protocols.IPV4) (Ipv6 : Mirage_protocols.IPV6) : sig include Mirage_protocols.IP with type ipaddr = Ipaddr.t - val connect : Ipv4.t -> Ipv6.t -> t Lwt.t + val connect : ipv4_only:bool -> ipv6_only:bool -> Ipv4.t -> Ipv6.t -> t Lwt.t end module MakeV4V6 diff --git a/src/stack-unix/tcpip_stack_socket.ml b/src/stack-unix/tcpip_stack_socket.ml index 45dadc3c8..aac8656a7 100644 --- a/src/stack-unix/tcpip_stack_socket.ml +++ b/src/stack-unix/tcpip_stack_socket.ml @@ -242,15 +242,25 @@ module V4V6 = struct match t.udp.interface with | `Any -> let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in - Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; + Lwt_unix.(setsockopt fd SO_REUSEADDR true); Lwt_unix.(setsockopt fd IPV6_ONLY false); [ (fd, Lwt_unix.ADDR_INET (UDP.any_v6, port)) ] | `Ip (v4, v6) -> let fd = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in - Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; + Lwt_unix.(setsockopt fd SO_REUSEADDR true); let fd' = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in - Lwt_unix.setsockopt fd' Lwt_unix.SO_REUSEADDR true; + Lwt_unix.(setsockopt fd' SO_REUSEADDR true); + Lwt_unix.(setsockopt fd' IPV6_ONLY true); [ (fd, Lwt_unix.ADDR_INET (v4, port)) ; (fd', Lwt_unix.ADDR_INET (v6, port)) ] + | `V4_only ip -> + let fd = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in + Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; + [ (fd, Lwt_unix.ADDR_INET (ip, port)) ] + | `V6_only ip -> + let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in + Lwt_unix.(setsockopt fd SO_REUSEADDR true); + Lwt_unix.(setsockopt fd IPV6_ONLY true); + [ (fd, Lwt_unix.ADDR_INET (ip, port)) ] in List.iter (fun (fd, addr) -> (* FIXME: we should not ignore the result *) diff --git a/src/stack-unix/tcpv4v6_socket.ml b/src/stack-unix/tcpv4v6_socket.ml index e8827ae95..ed910473a 100644 --- a/src/stack-unix/tcpv4v6_socket.ml +++ b/src/stack-unix/tcpv4v6_socket.ml @@ -22,25 +22,32 @@ type flow = Lwt_unix.file_descr type ipinput = unit Lwt.t type t = { - interface: [ `Any | `Ip of Unix.inet_addr * Unix.inet_addr ]; (* source ip to bind to *) + interface: [ `Any | `Ip of Unix.inet_addr * Unix.inet_addr | `V4_only of Unix.inet_addr | `V6_only of Unix.inet_addr ]; (* source ip to bind to *) } include Tcp_socket -let connect ipv4 ipv6 = +let connect ~ipv4_only ~ipv6_only ipv4 ipv6 = let interface = let v4 = Ipaddr.V4.Prefix.address ipv4 in let v4_unix = Ipaddr_unix.V4.to_inet_addr v4 in let any_v6 = Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified in - match ipv6, Ipaddr.V4.(compare v4 any) with - | None, 0 -> `Any - | None, _ -> `Ip (v4_unix, any_v6) - | Some x, v4_any -> - let v6 = Ipaddr.V6.Prefix.address x in - if Ipaddr.V6.(compare v6 unspecified = 0) && v4_any = 0 then - `Any - else - `Ip (v4_unix, Ipaddr_unix.V6.to_inet_addr v6) + if ipv4_only then + `V4_only v4_unix + else if ipv6_only then + `V6_only (match ipv6 with + | None -> any_v6 + | Some x -> Ipaddr_unix.V6.to_inet_addr (Ipaddr.V6.Prefix.address x)) + else + match ipv6, Ipaddr.V4.(compare v4 any) with + | None, 0 -> `Any + | None, _ -> `Ip (v4_unix, any_v6) + | Some x, v4_any -> + let v6 = Ipaddr.V6.Prefix.address x in + if Ipaddr.V6.(compare v6 unspecified = 0) && v4_any = 0 then + `Any + else + `Ip (v4_unix, Ipaddr_unix.V6.to_inet_addr v6) in Lwt.return {interface} @@ -51,23 +58,32 @@ let dst fd = | Unix.ADDR_INET (ia,port) -> Ipaddr_unix.of_inet_addr ia,port let create_connection ?keepalive t (dst,dst_port) = - let family, proj = match dst with - | Ipaddr.V4 _ -> Lwt_unix.PF_INET, fst - | Ipaddr.V6 _ -> Lwt_unix.PF_INET6, snd - in - let fd = Lwt_unix.(socket family SOCK_STREAM 0) in - Lwt.catch (fun () -> - (match t.interface with - | `Any -> Lwt.return_unit - | `Ip p -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (proj p, 0))) >>= fun () -> - Lwt_unix.connect fd - (Lwt_unix.ADDR_INET ((Ipaddr_unix.to_inet_addr dst), dst_port)) - >>= fun () -> - ( match keepalive with - | None -> () - | Some { Mirage_protocols.Keepalive.after; interval; probes } -> - Tcp_socket_options.enable_keepalive ~fd ~after ~interval ~probes ); - Lwt.return (Ok fd)) - (fun exn -> - Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >>= fun () -> - Lwt.return (Error (`Exn exn))) + match + match dst, t.interface with + | Ipaddr.V4 _, (`Any | `Ip _ | `V4_only _) -> Ok (Lwt_unix.PF_INET, fst) + | Ipaddr.V6 _, (`Any | `Ip _ | `V6_only _) -> Ok (Lwt_unix.PF_INET6, snd) + | Ipaddr.V4 _, `V6_only _ -> + Error (`Msg "Attempted to connect to an IPv4 host, but stack is IPv6 only") + | Ipaddr.V6 _, `V4_only _ -> + Error (`Msg "Attempted to connect to an IPv6 host, but stack is IPv4 only") + with + | Error (`Msg m) -> Lwt.return (Error (`Exn (Invalid_argument m))) + | Ok (family, proj) -> + let fd = Lwt_unix.(socket family SOCK_STREAM 0) in + Lwt.catch (fun () -> + (match t.interface with + | `Any -> Lwt.return_unit + | `Ip p -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (proj p, 0)) + | `V4_only ip -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, 0)) + | `V6_only ip -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, 0))) >>= fun () -> + Lwt_unix.connect fd + (Lwt_unix.ADDR_INET ((Ipaddr_unix.to_inet_addr dst), dst_port)) + >>= fun () -> + ( match keepalive with + | None -> () + | Some { Mirage_protocols.Keepalive.after; interval; probes } -> + Tcp_socket_options.enable_keepalive ~fd ~after ~interval ~probes ); + Lwt.return (Ok fd)) + (fun exn -> + Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >>= fun () -> + Lwt.return (Error (`Exn exn))) diff --git a/src/stack-unix/tcpv4v6_socket.mli b/src/stack-unix/tcpv4v6_socket.mli index cfcfa9be0..0ca1ecfb1 100644 --- a/src/stack-unix/tcpv4v6_socket.mli +++ b/src/stack-unix/tcpv4v6_socket.mli @@ -22,4 +22,4 @@ include Mirage_protocols.TCP and type error = [ Mirage_protocols.Tcp.error | `Exn of exn ] and type write_error = [ Mirage_protocols.Tcp.write_error | `Exn of exn ] -val connect : Ipaddr.V4.Prefix.t -> Ipaddr.V6.Prefix.t option -> t Lwt.t +val connect : ipv4_only:bool -> ipv6_only:bool -> Ipaddr.V4.Prefix.t -> Ipaddr.V6.Prefix.t option -> t Lwt.t diff --git a/src/stack-unix/udpv4v6_socket.ml b/src/stack-unix/udpv4v6_socket.ml index 61990cde3..30b5429d5 100644 --- a/src/stack-unix/udpv4v6_socket.ml +++ b/src/stack-unix/udpv4v6_socket.ml @@ -24,7 +24,7 @@ type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lw let any_v6 = Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified type t = { - interface: [ `Any | `Ip of Unix.inet_addr * Unix.inet_addr ]; (* source ip to bind to *) + interface: [ `Any | `Ip of Unix.inet_addr * Unix.inet_addr | `V4_only of Unix.inet_addr | `V6_only of Unix.inet_addr ]; (* source ip to bind to *) listen_fds: (int,Lwt_unix.file_descr * Lwt_unix.file_descr option) Hashtbl.t; (* UDP fds bound to a particular port *) } @@ -47,29 +47,47 @@ let get_udpv4v6_listening_fd {listen_fds;interface} port = let fd' = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in Lwt_unix.(setsockopt fd' IPV6_ONLY true); Lwt_unix.bind fd' (Lwt_unix.ADDR_INET (v6, port)) >|= fun () -> - ((fd, Some fd'), [ fd ; fd' ])) >|= fun (fds, r) -> + ((fd, Some fd'), [ fd ; fd' ]) + | `V4_only ip -> + let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, port)) >|= fun () -> + ((fd, None), [ fd ]) + | `V6_only ip -> + let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in + Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, port)) >|= fun () -> + ((fd, None), [ fd ])) >|= fun (fds, r) -> Hashtbl.add listen_fds port fds; r -type error = [`Sendto_failed] +type error = [`Sendto_failed | `Different_ip_version] let pp_error ppf = function | `Sendto_failed -> Fmt.pf ppf "sendto failed to write any bytes" + | `Different_ip_version -> + Fmt.string ppf "attempting to send to a destination with a different IP protocol version" -let connect ipv4 ipv6 = +let connect ~ipv4_only ~ipv6_only ipv4 ipv6 = let v4 = Ipaddr.V4.Prefix.address ipv4 in let v4_unix = Ipaddr_unix.V4.to_inet_addr v4 in let interface = - match ipv6, Ipaddr.V4.(compare v4 any) with - | None, 0 -> `Any - | None, _ -> `Ip (v4_unix, any_v6) - | Some x, v4_any -> - let v6 = Ipaddr.V6.Prefix.address x in - if Ipaddr.V6.(compare v6 unspecified = 0) && v4_any = 0 then - `Any - else - `Ip (v4_unix, Ipaddr_unix.V6.to_inet_addr v6) + if ipv4_only then + `V4_only v4_unix + else if ipv6_only then + `V6_only ( + match ipv6 with + | None -> any_v6 + | Some x -> Ipaddr_unix.V6.to_inet_addr (Ipaddr.V6.Prefix.address x)) + else + match ipv6, Ipaddr.V4.(compare v4 any) with + | None, 0 -> `Any + | None, _ -> `Ip (v4_unix, any_v6) + | Some x, v4_any -> + let v6 = Ipaddr.V6.Prefix.address x in + if Ipaddr.V6.(compare v6 unspecified = 0) && v4_any = 0 then + `Any + else + `Ip (v4_unix, Ipaddr_unix.V6.to_inet_addr v6) in let listen_fds = Hashtbl.create 7 in Lwt.return { interface; listen_fds } @@ -79,23 +97,26 @@ let disconnect _ = Lwt.return_unit let input ~listeners:_ _ = Lwt.return_unit let create_socket t ?port dst = - let bind fd proj dfl = match t.interface, port with + let bind fd proj dfl = + let p = match port with None -> 0 | Some p -> p in + match t.interface, port with | `Any, None -> Lwt.return_unit | `Any, Some p -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (dfl, p)) - | `Ip p, _ -> - let port = match port with None -> 0 | Some p -> p in - Lwt_unix.bind fd (Lwt_unix.ADDR_INET (proj p, port)) + | `Ip ip, _ -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (proj ip, p)) + | `V4_only ip, _ -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, p)) + | `V6_only ip, _ -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, p)) in - match dst with - | Ipaddr.V4 _ -> + match dst, t.interface with + | Ipaddr.V4 _, (`Any | `Ip _ | `V4_only _) -> let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in bind fd fst (Ipaddr_unix.V4.to_inet_addr Ipaddr.V4.any) >|= fun () -> - fd - | Ipaddr.V6 _ -> + Ok fd + | Ipaddr.V6 _, (`Any | `Ip _ | `V6_only _) -> let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in Lwt_unix.(setsockopt fd IPV6_ONLY true); bind fd snd any_v6 >|= fun () -> - fd + Ok fd + | _ -> Lwt.return (Error `Different_ip_version) let write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf = let open Lwt_unix in @@ -106,7 +127,9 @@ let write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf = | 0 -> Lwt.return @@ Error `Sendto_failed | n -> write_to_fd fd (Cstruct.sub buf n (Cstruct.len buf - n)) (* keep trying *) in - create_socket t ?port:src_port dst >>= fun fd -> - write_to_fd fd buf >>= fun r -> - Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >|= fun () -> - r + create_socket t ?port:src_port dst >>= function + | Error e -> Lwt.return (Error e) + | Ok fd -> + write_to_fd fd buf >>= fun r -> + Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >|= fun () -> + r diff --git a/test/test_connect_ipv6.ml b/test/test_connect_ipv6.ml index 18636d399..faac7e95e 100644 --- a/test/test_connect_ipv6.ml +++ b/test/test_connect_ipv6.ml @@ -26,7 +26,9 @@ module Test_connect_ipv6 (B : Vnetif_backends.Backend) = struct module V = VNETIF_STACK (B) let client_address = Ipaddr.V6.of_string_exn "fc00::23" + let client_cidr = Ipaddr.V6.Prefix.make 64 client_address let server_address = Ipaddr.V6.of_string_exn "fc00::45" + let server_cidr = Ipaddr.V6.Prefix.make 64 server_address let test_string = "Hello world from Mirage 123456789...." let backend = V.create_backend () @@ -60,12 +62,12 @@ module Test_connect_ipv6 (B : Vnetif_backends.Backend) = struct (Lwt_unix.sleep timeout >>= fun () -> failf "connect test timedout after %f seconds" timeout) ; - (V.create_stack_v6 ~ip:[server_address] backend >>= fun s1 -> + (V.create_stack_v6 ~cidr:server_cidr backend >>= fun s1 -> V.Stackv6.listen_tcp s1 ~port:80 (fun f -> accept f test_string); V.Stackv6.listen s1) ; (Lwt_unix.sleep 0.1 >>= fun () -> - V.create_stack_v6 ~ip:[client_address] backend >>= fun s2 -> + V.create_stack_v6 ~cidr:client_cidr backend >>= fun s2 -> Lwt.pick [ V.Stackv6.listen s2; (let conn = V.Stackv6.TCP.create_connection (V.Stackv6.tcp s2) in diff --git a/test/test_iperf_ipv6.ml b/test/test_iperf_ipv6.ml index aa1099bb6..a1afcee76 100644 --- a/test/test_iperf_ipv6.ml +++ b/test/test_iperf_ipv6.ml @@ -25,7 +25,9 @@ module Test_iperf_ipv6 (B : Vnetif_backends.Backend) = struct module V = VNETIF_STACK (B) let client_ip = Ipaddr.V6.of_string_exn "fc00::23" + let client_cidr = Ipaddr.V6.Prefix.make 64 client_ip let server_ip = Ipaddr.V6.of_string_exn "fc00::45" + let server_cidr = Ipaddr.V6.Prefix.make 64 server_ip type stats = { mutable bytes: int64; @@ -43,8 +45,8 @@ module Test_iperf_ipv6 (B : Vnetif_backends.Backend) = struct } let default_network ?mtu ?(backend = B.create ()) () = - V.create_stack_v6 ?mtu ?ip:(Some [client_ip]) backend >>= fun client -> - V.create_stack_v6 ?mtu ?ip:(Some [server_ip]) backend >>= fun server -> + V.create_stack_v6 ?mtu ~cidr:client_cidr backend >>= fun client -> + V.create_stack_v6 ?mtu ~cidr:server_cidr backend >>= fun server -> Lwt.return {backend; server; client} let msg = diff --git a/test/test_ipv6.ml b/test/test_ipv6.ml index faf6b60fc..503ea4095 100644 --- a/test/test_ipv6.ml +++ b/test/test_ipv6.ml @@ -25,12 +25,10 @@ type stack = { } let get_stack backend address = - let ip = [address] in - let netmask = [Ipaddr.V6.Prefix.make 24 address] in - let gateways = [] in + let cidr = Ipaddr.V6.Prefix.make 64 address in V.connect backend >>= fun netif -> E.connect netif >>= fun ethif -> - Ipv6.connect ~ip ~netmask ~gateways netif ethif >>= fun ip -> + Ipv6.connect ~cidr netif ethif >>= fun ip -> Udp.connect ip >>= fun udp -> Lwt.return { backend; netif; ethif; ip; udp } diff --git a/test/test_socket.ml b/test/test_socket.ml index 4b2c10e35..5bc50aaa0 100644 --- a/test/test_socket.ml +++ b/test/test_socket.ml @@ -16,12 +16,13 @@ let or_fail_str ~str f args = | `Error _ -> Alcotest.fail str let localhost = Ipaddr.V4.of_string_exn "127.0.0.1" +let localhost_cidr = Ipaddr.V4.Prefix.make 32 localhost -let make_stack ~ip = - Tcpv4_socket.connect (Some ip) >>= fun tcp -> - Udpv4_socket.connect (Some ip) >>= fun udp -> +let make_stack ~cidr = + Tcpv4_socket.connect cidr >>= fun tcp -> + Udpv4_socket.connect cidr >>= fun udp -> Icmpv4_socket.connect () >>= fun icmp -> - Stack.connect [ip] udp tcp >>= fun stack -> + Stack.connect udp tcp >>= fun stack -> Lwt.return { stack; icmp; udp; tcp } let two_connect_tcp () = @@ -33,8 +34,8 @@ let two_connect_tcp () = Lwt.return_unit in let server_port = 14041 in - make_stack ~ip:localhost >>= fun server -> - make_stack ~ip:localhost >>= fun client -> + make_stack ~cidr:localhost_cidr >>= fun server -> + make_stack ~cidr:localhost_cidr >>= fun client -> Stack.listen_tcpv4 server.stack ~port:server_port announce; Lwt.pick [ @@ -46,8 +47,8 @@ let two_connect_tcp () = ] let icmp_echo_request () = - make_stack ~ip:localhost >>= fun server -> - make_stack ~ip:localhost >>= fun client -> + make_stack ~cidr:localhost_cidr >>= fun server -> + make_stack ~cidr:localhost_cidr >>= fun client -> let echo_request = Icmpv4_packet.(Marshal.make_cstruct ~payload:(Cstruct.create 0) { ty = Icmpv4_wire.Echo_request; diff --git a/test/vnetif_common.ml b/test/vnetif_common.ml index fa2046bee..47ed34130 100644 --- a/test/vnetif_common.ml +++ b/test/vnetif_common.ml @@ -43,11 +43,10 @@ sig val create_stack : ?mtu:int -> cidr:Ipaddr.V4.Prefix.t -> ?gateway:Ipaddr.V4.t -> backend -> Stackv4.t Lwt.t - (** [create_stack backend ?mtu ip netmask gateway] adds a listener + (** [create_stack ?mtu ?cidr ?gateway backend] adds a listener function to the backend *) - val create_stack_v6 : ?mtu:int -> ?ip:Ipaddr.V6.t list -> - ?netmask:Ipaddr.V6.Prefix.t list -> - ?gateways:Ipaddr.V6.t list -> backend -> Stackv6.t Lwt.t + val create_stack_v6 : ?mtu:int -> ?cidr:Ipaddr.V6.Prefix.t -> + ?gateway:Ipaddr.V6.t -> backend -> Stackv6.t Lwt.t val create_backend_listener : backend -> (buffer -> unit io) -> id @@ -100,11 +99,11 @@ struct T4.connect ipv4 >>= fun tcpv4 -> Stackv4.connect netif ethif arpv4 ipv4 icmpv4 udpv4 tcpv4 - let create_stack_v6 ?mtu ?ip ?netmask ?gateways backend = + let create_stack_v6 ?mtu ?cidr ?gateway backend = let size_limit = match mtu with None -> None | Some x -> Some x in V.connect ?size_limit backend >>= fun netif -> E.connect netif >>= fun ethif -> - Ip6.connect ?ip ?netmask ?gateways netif ethif >>= fun ipv6 -> + Ip6.connect ?cidr ?gateway netif ethif >>= fun ipv6 -> U6.connect ipv6 >>= fun udpv6 -> T6.connect ipv6 >>= fun tcpv6 -> Stackv6.connect netif ethif ipv6 udpv6 tcpv6 From 217bd8c3b4f29c29a3ecf8217bcc870ee7408ef2 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 1 Oct 2020 11:24:36 +0200 Subject: [PATCH 16/18] ipv6: fail if number of IP addresses mismatches the expected amount --- src/ipv6/ipv6.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ipv6/ipv6.ml b/src/ipv6/ipv6.ml index d05d2a390..d283eeaa9 100644 --- a/src/ipv6/ipv6.ml +++ b/src/ipv6/ipv6.ml @@ -160,11 +160,11 @@ module Make (N : Mirage_net.S) (N.listen netif ~header_size:Ethernet_wire.sizeof_ethernet ethif_listener >|= fun _ -> ()) ; timeout ] >>= fun () -> + let expected_ips = match cidr with None -> 1 | Some _ -> 2 in match get_ip t with - | [] -> Lwt.fail_with "IP6 not started, couldn't assign IP" - | ips -> + | ips when List.length ips = expected_ips -> Log.info (fun f -> f "IP6: Started with %a" Fmt.(list ~sep:(unit ",@ ") Ipaddr.V6.pp) ips); Lwt.return t - + | _ -> Lwt.fail_with "IP6 not started, couldn't assign IP addresses" end From 95506511c123dce7e8ee56007efbaf885fb124a5 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 1 Oct 2020 17:29:15 +0200 Subject: [PATCH 17/18] ipv4 + ipv6: accept no_init --- src/ipv4/static_ipv4.ml | 9 ++++--- src/ipv4/static_ipv4.mli | 4 +-- src/ipv6/ipv6.ml | 53 +++++++++++++++++++++------------------- src/ipv6/ipv6.mli | 1 + 4 files changed, 37 insertions(+), 30 deletions(-) diff --git a/src/ipv4/static_ipv4.ml b/src/ipv4/static_ipv4.ml index 60512d426..8f7f6a65e 100644 --- a/src/ipv4/static_ipv4.ml +++ b/src/ipv4/static_ipv4.ml @@ -158,10 +158,13 @@ module Make (R: Mirage_random.S) (C: Mirage_clock.MCLOCK) (Ethernet: Mirage_prot | Some `ICMP | None -> default ~proto:packet.proto ~src ~dst payload let connect - ~cidr ?gateway ?(fragment_cache_size = 1024 * 256) ethif arp = - Arpv4.set_ips arp [Ipaddr.V4.Prefix.address cidr] >>= fun () -> + ?(no_init = false) ~cidr ?gateway ?(fragment_cache_size = 1024 * 256) ethif arp = + (if no_init then + Lwt.return_unit + else + Arpv4.set_ips arp [Ipaddr.V4.Prefix.address cidr]) >|= fun () -> let cache = Fragments.Cache.empty fragment_cache_size in - Lwt.return { ethif; arp; cidr; gateway; cache } + { ethif; arp; cidr; gateway; cache } let disconnect _ = Lwt.return_unit diff --git a/src/ipv4/static_ipv4.mli b/src/ipv4/static_ipv4.mli index 84f643d0b..69c30bef9 100644 --- a/src/ipv4/static_ipv4.mli +++ b/src/ipv4/static_ipv4.mli @@ -17,9 +17,9 @@ module Make (R: Mirage_random.S) (C: Mirage_clock.MCLOCK) (E: Mirage_protocols.ETHERNET) (A: Mirage_protocols.ARP) : sig include Mirage_protocols.IP with type ipaddr = Ipaddr.V4.t - val connect : cidr:Ipaddr.V4.Prefix.t -> ?gateway:Ipaddr.V4.t -> + val connect : ?no_init:bool -> cidr:Ipaddr.V4.Prefix.t -> ?gateway:Ipaddr.V4.t -> ?fragment_cache_size:int -> E.t -> A.t -> t Lwt.t - (** [connect ~cidr ~gateway ~fragment_cache_size eth arp] connects the ipv4 + (** [connect ~no_init ~cidr ~gateway ~fragment_cache_size eth arp] connects the ipv4 device using [cidr] and [gateway] for network communication. The size of the IPv4 fragment cache (for reassembly) can be provided in byte-size of fragments (defaults to 256kB). *) diff --git a/src/ipv6/ipv6.ml b/src/ipv6/ipv6.ml index d283eeaa9..40c16a65e 100644 --- a/src/ipv6/ipv6.ml +++ b/src/ipv6/ipv6.ml @@ -126,7 +126,7 @@ module Make (N : Mirage_net.S) Cstruct.set_uint8 ph 39 (Ipv6_wire.protocol_to_int proto); ph - let connect ?(handle_ra = true) ?cidr ?gateway netif ethif = + let connect ?(no_init = false) ?(handle_ra = true) ?cidr ?gateway netif ethif = Log.info (fun f -> f "IP6: Starting"); let now = C.elapsed_ns () in let ctx, outs = Ndpv6.local ~handle_ra ~now ~random:R.generate (E.mac ethif) in @@ -142,29 +142,32 @@ module Make (N : Mirage_net.S) | Some ip -> Ndpv6.add_routers ~now ctx [ip] in let t = {ctx; ethif} in - let task, u = Lwt.task () in - Lwt.async (fun () -> start_ticking t u); - (* call listen until we're good in respect to DAD *) - let ethif_listener = - let noop ~src:_ ~dst:_ _ = Lwt.return_unit in - E.input ethif - ~arpv4:(fun _ -> Lwt.return_unit) - ~ipv4:(fun _ -> Lwt.return_unit) - ~ipv6:(input t ~tcp:noop ~udp:noop ~default:(fun ~proto:_ -> noop)) - in - let timeout = T.sleep_ns (Duration.of_sec 3) in - Lwt.pick [ - (* MCP: replace this error swallowing with proper propagation *) - (Lwt_list.iter_s (output_ign t) outs >>= fun () -> - task) ; - (N.listen netif ~header_size:Ethernet_wire.sizeof_ethernet ethif_listener >|= fun _ -> ()) ; - timeout - ] >>= fun () -> - let expected_ips = match cidr with None -> 1 | Some _ -> 2 in - match get_ip t with - | ips when List.length ips = expected_ips -> - Log.info (fun f -> f "IP6: Started with %a" - Fmt.(list ~sep:(unit ",@ ") Ipaddr.V6.pp) ips); + if no_init then Lwt.return t - | _ -> Lwt.fail_with "IP6 not started, couldn't assign IP addresses" + else + let task, u = Lwt.task () in + Lwt.async (fun () -> start_ticking t u); + (* call listen until we're good in respect to DAD *) + let ethif_listener = + let noop ~src:_ ~dst:_ _ = Lwt.return_unit in + E.input ethif + ~arpv4:(fun _ -> Lwt.return_unit) + ~ipv4:(fun _ -> Lwt.return_unit) + ~ipv6:(input t ~tcp:noop ~udp:noop ~default:(fun ~proto:_ -> noop)) + in + let timeout = T.sleep_ns (Duration.of_sec 3) in + Lwt.pick [ + (* MCP: replace this error swallowing with proper propagation *) + (Lwt_list.iter_s (output_ign t) outs >>= fun () -> + task) ; + (N.listen netif ~header_size:Ethernet_wire.sizeof_ethernet ethif_listener >|= fun _ -> ()) ; + timeout + ] >>= fun () -> + let expected_ips = match cidr with None -> 1 | Some _ -> 2 in + match get_ip t with + | ips when List.length ips = expected_ips -> + Log.info (fun f -> f "IP6: Started with %a" + Fmt.(list ~sep:(unit ",@ ") Ipaddr.V6.pp) ips); + Lwt.return t + | _ -> Lwt.fail_with "IP6 not started, couldn't assign IP addresses" end diff --git a/src/ipv6/ipv6.mli b/src/ipv6/ipv6.mli index 9a2c91ae3..d7b1eb91e 100644 --- a/src/ipv6/ipv6.mli +++ b/src/ipv6/ipv6.mli @@ -21,6 +21,7 @@ module Make (N : Mirage_net.S) (Clock : Mirage_clock.MCLOCK) : sig include Mirage_protocols.IP with type ipaddr = Ipaddr.V6.t val connect : + ?no_init:bool -> ?handle_ra:bool -> ?cidr:Ipaddr.V6.Prefix.t -> ?gateway:Ipaddr.V6.t -> From 8b84db23cdbfc7ccb9e11926578776d6ba51840b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 30 Sep 2020 11:50:39 +0200 Subject: [PATCH 18/18] require mirage-protocols 5.0.0 Also, adapt the IP.mtu implementation to its interface: now ~dst:ipaddr is required. This allows the dual stack to provide appropriate numbers. --- src/ipv4/static_ipv4.ml | 2 +- src/ipv6/ipv6.ml | 2 +- src/stack-direct/tcpip_stack_direct.ml | 6 +++--- src/stack-unix/ipv4_socket.ml | 2 +- src/stack-unix/ipv4v6_socket.ml | 4 +++- src/stack-unix/ipv6_socket.ml | 2 +- src/tcp/flow.ml | 6 +++--- tcpip.opam | 6 +++--- test/dune | 2 +- 9 files changed, 17 insertions(+), 15 deletions(-) diff --git a/src/ipv4/static_ipv4.ml b/src/ipv4/static_ipv4.ml index 8f7f6a65e..761353b9a 100644 --- a/src/ipv4/static_ipv4.ml +++ b/src/ipv4/static_ipv4.ml @@ -176,6 +176,6 @@ module Make (R: Mirage_random.S) (C: Mirage_clock.MCLOCK) (Ethernet: Mirage_prot let src t ~dst:_ = Ipaddr.V4.Prefix.address t.cidr - let mtu t = Ethernet.mtu t.ethif - Ipv4_wire.sizeof_ipv4 + let mtu t ~dst:_ = Ethernet.mtu t.ethif - Ipv4_wire.sizeof_ipv4 end diff --git a/src/ipv6/ipv6.ml b/src/ipv6/ipv6.ml index 40c16a65e..83292a660 100644 --- a/src/ipv6/ipv6.ml +++ b/src/ipv6/ipv6.ml @@ -61,7 +61,7 @@ module Make (N : Mirage_net.S) in loop (Some u) - let mtu t = E.mtu t.ethif - Ipv6_wire.sizeof_ipv6 + let mtu t ~dst:_ = E.mtu t.ethif - Ipv6_wire.sizeof_ipv6 let write t ?fragment:_ ?ttl:_ ?src dst proto ?(size = 0) headerf bufs = let now = C.elapsed_ns () in diff --git a/src/stack-direct/tcpip_stack_direct.ml b/src/stack-direct/tcpip_stack_direct.ml index dfbc0340c..b7f528942 100644 --- a/src/stack-direct/tcpip_stack_direct.ml +++ b/src/stack-direct/tcpip_stack_direct.ml @@ -376,9 +376,9 @@ module IPV4V6 (Ipv4 : Mirage_protocols.IPV4) (Ipv6 : Mirage_protocols.IPV6) = st List.map (fun ip -> Ipaddr.V4 ip) (Ipv4.get_ip t.ipv4) @ List.map (fun ip -> Ipaddr.V6 ip) (Ipv6.get_ip t.ipv6) - let mtu t = - (* TODO incorrect for IPv4 *) - Ipv6.mtu t.ipv6 + let mtu t ~dst = match dst with + | Ipaddr.V4 dst -> Ipv4.mtu t.ipv4 ~dst + | Ipaddr.V6 dst -> Ipv6.mtu t.ipv6 ~dst end module MakeV4V6 diff --git a/src/stack-unix/ipv4_socket.ml b/src/stack-unix/ipv4_socket.ml index 790a6bccf..ecd2fae70 100644 --- a/src/stack-unix/ipv4_socket.ml +++ b/src/stack-unix/ipv4_socket.ml @@ -22,7 +22,7 @@ type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t let pp_error = Mirage_protocols.Ip.pp_error let pp_ipaddr = Ipaddr.V4.pp -let mtu _ = 1500 - Ipv4_wire.sizeof_ipv4 +let mtu _ ~dst:_ = 1500 - Ipv4_wire.sizeof_ipv4 let disconnect _ = Lwt.return_unit let connect _ = Lwt.return_unit diff --git a/src/stack-unix/ipv4v6_socket.ml b/src/stack-unix/ipv4v6_socket.ml index f8c49910c..3f31ebbf1 100644 --- a/src/stack-unix/ipv4v6_socket.ml +++ b/src/stack-unix/ipv4v6_socket.ml @@ -22,7 +22,9 @@ type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t let pp_error = Mirage_protocols.Ip.pp_error let pp_ipaddr = Ipaddr.pp -let mtu _ = 1500 - Ipv6_wire.sizeof_ipv6 +let mtu _ ~dst = match dst with + | Ipaddr.V4 _ -> 1500 - Ipv4_wire.sizeof_ipv4 + | Ipaddr.V6 _ -> 1500 - Ipv6_wire.sizeof_ipv6 let disconnect _ = Lwt.return_unit let connect _ = Lwt.return_unit diff --git a/src/stack-unix/ipv6_socket.ml b/src/stack-unix/ipv6_socket.ml index 9507ec7b6..b9811e82c 100644 --- a/src/stack-unix/ipv6_socket.ml +++ b/src/stack-unix/ipv6_socket.ml @@ -23,7 +23,7 @@ type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t let pp_error = Mirage_protocols.Ip.pp_error let pp_ipaddr = Ipaddr.V6.pp -let mtu _ = 1500 - Ipv6_wire.sizeof_ipv6 +let mtu _ ~dst:_ = 1500 - Ipv6_wire.sizeof_ipv6 let disconnect () = Lwt.return_unit let connect () = Lwt.return_unit diff --git a/src/tcp/flow.ml b/src/tcp/flow.ml index f74fbe21d..f4a80fc55 100644 --- a/src/tcp/flow.ml +++ b/src/tcp/flow.ml @@ -316,7 +316,7 @@ struct let emitted_keepalive_warning = ref false let new_pcb t params id keepalive = - let mtu_mss = Ip.mtu t.ip - Tcp_wire.sizeof_tcp in + let mtu_mss = Ip.mtu t.ip ~dst:(WIRE.dst id) - Tcp_wire.sizeof_tcp in let { tx_wnd; sequence; options; tx_isn; rx_wnd; rx_wnd_scaleoffer } = params in @@ -413,7 +413,7 @@ struct Hashtbl.add t.listens id (params.tx_isn, (pushf, (pcb, th))); Stats.incr_listen (); (* Queue a SYN ACK for transmission *) - let options = Options.MSS (Ip.mtu t.ip - Tcp_wire.sizeof_tcp) :: opts in + let options = Options.MSS (Ip.mtu t.ip ~dst:(WIRE.dst id) - Tcp_wire.sizeof_tcp) :: opts in TXS.output ~flags:Segment.Syn ~options pcb.txq (Cstruct.create 0) >>= fun () -> Lwt.return (pcb, th) @@ -685,7 +685,7 @@ struct (* TODO: This is hardcoded for now - make it configurable *) let rx_wnd_scaleoffer = wscale_default in let options = - Options.MSS (Ip.mtu t.ip - Tcp_wire.sizeof_tcp) :: Options.Window_size_shift rx_wnd_scaleoffer :: [] + Options.MSS (Ip.mtu t.ip ~dst - Tcp_wire.sizeof_tcp) :: Options.Window_size_shift rx_wnd_scaleoffer :: [] in let window = 5840 in let th, wakener = MProf.Trace.named_task "TCP connect" in diff --git a/tcpip.opam b/tcpip.opam index 4b5dd68e8..950fa30fd 100644 --- a/tcpip.opam +++ b/tcpip.opam @@ -28,8 +28,8 @@ depends: [ "mirage-net" {>= "3.0.0"} "mirage-clock" {>= "3.0.0"} "mirage-random" {>= "2.0.0"} - "mirage-stack" {>= "2.1.0"} - "mirage-protocols" {>= "4.0.0" & < "5.0.0"} + "mirage-stack" {>= "2.2.0"} + "mirage-protocols" {>= "5.0.0"} "mirage-time" {>= "2.0.0"} "ipaddr" {>= "5.0.0"} "macaddr" {>="4.0.0"} @@ -48,7 +48,7 @@ depends: [ "pcap-format" {with-test} "mirage-clock-unix" {with-test & >= "3.0.0"} "mirage-random-test" {with-test & >= "0.1.0"} - "arp-mirage" {with-test & >= "2.0.0"} + "arp" {with-test & >= "2.3.0"} "ipaddr-cstruct" {with-test} "lru" {>= "0.3.0"} ] diff --git a/test/dune b/test/dune index 00275c7d3..b79dc50de 100644 --- a/test/dune +++ b/test/dune @@ -2,7 +2,7 @@ (name test) (libraries alcotest mirage-random-test lwt.unix logs logs.fmt mirage-profile mirage-flow mirage-vnetif mirage-clock-unix pcap-format duration - mirage-random rresult mirage-protocols mirage-stack arp arp-mirage + mirage-random rresult mirage-protocols mirage-stack arp arp.mirage ethernet tcpip.ipv4 tcpip.tcp tcpip.udp tcpip.stack-direct tcpip.icmpv4 tcpip.udpv4-socket tcpip.tcpv4-socket tcpip.icmpv4-socket tcpip.stack-socket tcpip.ipv6 ipaddr-cstruct macaddr-cstruct tcpip.unix)