Merge pull request #433 from hannesm/tcpip-stack-socket-v6

move Tcpip_stack_socket to Tcpip_stack_socket.V4, provide Tcpip_stack_socket.V6; also dual direct stack and fixes

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

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
 
@@ -173,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

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

src/ipv6/ipv6.ml

@@ -61,9 +61,9 @@ 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 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
@@ -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,41 +126,48 @@ 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 ?(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 ~now ~random:R.generate (E.mac ethif) 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))
+    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 ->
+        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 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 () ->
-       (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
-    ] >>= fun () ->
-    match get_ip t with
-    | [] -> Lwt.fail_with "IP6 not started, couldn't assign IP"
-    | ips ->
-      Log.info (fun f -> f "IP6: Started with %a"
-                   Fmt.(list ~sep:(unit ",@ ") Ipaddr.V6.pp) ips);
+    let ctx = match gateway with
+      | None -> ctx
+      | Some ip -> Ndpv6.add_routers ~now ctx [ip]
+    in
+    let t = {ctx; ethif} in
+    if no_init then
       Lwt.return t
-
+    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

src/ipv6/ipv6.mli

@@ -21,8 +21,9 @@ 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 ->
+    ?no_init:bool ->
+    ?handle_ra:bool ->
+    ?cidr:Ipaddr.V6.Prefix.t ->
+    ?gateway:Ipaddr.V6.t ->
     N.t -> E.t -> t Lwt.t
 end

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
@@ -1104,12 +1105,12 @@ 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
 
-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

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. *)
 
@@ -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