Merge pull request mirage#516 from hannesm/add-get-cidr

IP: add configured_ips : t -> prefix list

src/core/ip.ml

@@ -17,6 +17,8 @@ module type S = sig
   val pp_error: error Fmt.t
   type ipaddr
   val pp_ipaddr : ipaddr Fmt.t
+  type prefix
+  val pp_prefix : prefix Fmt.t
   type t
   val disconnect : t -> unit Lwt.t
   type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
@@ -30,5 +32,7 @@ module type S = sig
   val pseudoheader : t -> ?src:ipaddr -> ipaddr -> proto -> int -> Cstruct.t
   val src: t -> dst:ipaddr -> ipaddr
   val get_ip: t -> ipaddr list
+  [@@ocaml.deprecated "this function will be removed soon, use [configured_ips] instead."]
+  val configured_ips: t -> prefix list
   val mtu: t -> dst:ipaddr -> int
 end

src/core/ip.mli

@@ -28,6 +28,12 @@ module type S = sig
   val pp_ipaddr : ipaddr Fmt.t
   (** [pp_ipaddr] is the pretty-printer for IP addresses. *)
 
+  type prefix
+  (** The type for the IP address and netmask. *)
+
+  val pp_prefix : prefix Fmt.t
+  (** [pp_prefix] is the pretty-printer for the prefix. *)
+
   type t
   (** The type representing the internal state of the IP layer. *)
 
@@ -76,9 +82,15 @@ module type S = sig
       the same IP, which is the only one set. *)
 
   val get_ip: t -> ipaddr list
+  [@@ocaml.deprecated "this function will be removed soon, use [configured_ips] instead."]
   (** Get the IP addresses associated with this interface. For IPv4, only
       one IP address can be set at a time, so the list will always be of
-      length 1 (and may be the default value, 0.0.0.0). *)
+      length 1 (and may be the default value, [[10.0.0.2]]). *)
+
+  val configured_ips: t -> prefix list
+  (** Get the prefix associated with this interface. For IPv4, only
+      one prefix can be set at a time, so the list will always be of
+      length 1, e.g. [[10.0.0.2/24]]. *)
 
   val mtu: t -> dst:ipaddr -> int
   (** [mtu ~dst ip] is the Maximum Transmission Unit of the [ip] i.e. the

src/core/stack.ml

@@ -10,7 +10,7 @@ module type V4V6 = sig
 
   module TCP: Tcp.S with type ipaddr = Ipaddr.t
 
-  module IP: Ip.S with type ipaddr = Ipaddr.t
+  module IP: Ip.S with type ipaddr = Ipaddr.t and type prefix = Ipaddr.Prefix.t
 
   val udp: t -> UDP.t
   (** [udp t] obtains a descriptor for use with the [UDP] module,

src/ipv4/static_ipv4.ml

@@ -33,6 +33,10 @@ module Make (R: Mirage_random.S) (C: Mirage_clock.MCLOCK) (Ethernet: Ethernet.S)
 
   let pp_ipaddr = Ipaddr.V4.pp
 
+  type prefix = Ipaddr.V4.Prefix.t
+
+  let pp_prefix = Ipaddr.V4.Prefix.pp
+
   type t = {
     ethif : Ethernet.t;
     arp : Arpv4.t;
@@ -170,6 +174,8 @@ module Make (R: Mirage_random.S) (C: Mirage_clock.MCLOCK) (Ethernet: Ethernet.S)
 
   let get_ip t = [Ipaddr.V4.Prefix.address t.cidr]
 
+  let configured_ips t = [t.cidr]
+
   let pseudoheader t ?src dst proto len =
     let src = match src with None -> Ipaddr.V4.Prefix.address t.cidr | Some x -> x in
     Ipv4_packet.Marshal.pseudoheader ~src ~dst ~proto len

src/ipv4/static_ipv4.mli

@@ -15,7 +15,7 @@
  *)
 
 module Make (R: Mirage_random.S) (C: Mirage_clock.MCLOCK) (E: Ethernet.S) (A: Arp.S) : sig
-  include Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t
+  include Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t and type prefix = Ipaddr.V4.Prefix.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

src/ipv6/ipv6.ml

@@ -31,6 +31,10 @@ module Make (N : Mirage_net.S)
 
   let pp_ipaddr = Ipaddr.V6.pp
 
+  type prefix = Ipaddr.V6.Prefix.t
+
+  let pp_prefix = Ipaddr.V6.Prefix.pp
+
   type t =
     { ethif : E.t;
       mutable ctx : Ndpv6.context }
@@ -114,6 +118,9 @@ module Make (N : Mirage_net.S)
   let get_ip t =
     Ndpv6.get_ip t.ctx
 
+  let configured_ips t =
+    Ndpv6.configured_ips t.ctx
+
   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
@@ -133,7 +140,7 @@ module Make (N : Mirage_net.S)
     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, outs' = Ndpv6.add_ip ~now ctx p in
         let ctx = Ndpv6.add_prefix ~now ctx (Ipaddr.V6.Prefix.prefix p) in
         ctx, outs @ outs'
     in

src/ipv6/ipv6.mli

@@ -19,7 +19,7 @@ module Make (N : Mirage_net.S)
             (R : Mirage_random.S)
             (T : Mirage_time.S)
             (Clock : Mirage_clock.MCLOCK) : sig
-  include Tcpip.Ip.S with type ipaddr = Ipaddr.V6.t
+  include Tcpip.Ip.S with type ipaddr = Ipaddr.V6.t and type prefix = Ipaddr.V6.Prefix.t
   val connect :
     ?no_init:bool ->
     ?handle_ra:bool ->

src/ipv6/ndpv6.ml

@@ -41,7 +41,6 @@ module Log = (val Logs.src_log src : Logs.LOG)
 
 module Ipaddr = Ipaddr.V6
 
-type buffer = Cstruct.t
 type ipaddr = Ipaddr.t
 type prefix = Ipaddr.Prefix.t
 type time   = int64
@@ -106,7 +105,8 @@ let interface_addr mac =
     (c 4 lsl 8 + c 5)
 
 let link_local_addr mac =
-  Ipaddr.(Prefix.network_address Prefix.link (interface_addr mac))
+  let addr = Ipaddr.(Prefix.network_address Prefix.link (interface_addr mac)) in
+  Ipaddr.Prefix.(make (bits link) addr)
 
 let multicast_mac =
   let pbuf = Cstruct.create 6 in
@@ -272,7 +272,7 @@ module AddressList = struct
     | DEPRECATED of time option
 
   type t =
-    (Ipaddr.t * state) list
+    (Ipaddr.Prefix.t * state) list
 
   let empty =
     []
@@ -288,37 +288,41 @@ module AddressList = struct
   let select_source al ~dst:_ =
     let rec loop = function
       | (_, TENTATIVE _) :: rest -> loop rest
-      | (ip, _) :: _             -> ip (* FIXME *)
+      | (ip, _) :: _             -> Ipaddr.Prefix.address ip (* FIXME *)
       | []                       -> Ipaddr.unspecified
     in
     loop al
 
   let tick_one ~now ~retrans_timer = function
-    | (ip, TENTATIVE (timeout, n, t)) when t <= now ->
+    | (prefix, TENTATIVE (timeout, n, t)) when t <= now ->
       if n + 1 >= Defaults.dup_addr_detect_transmits then
         let timeout = match timeout with
           | None -> None
           | Some (preferred_lifetime, valid_lifetime) ->
             Some (Int64.add now preferred_lifetime, valid_lifetime)
         in
+        let ip = Ipaddr.Prefix.address prefix in
         Log.debug (fun f -> f "SLAAC: %a --> PREFERRED" Ipaddr.pp ip);
-        Some (ip, PREFERRED timeout), []
+        Some (prefix, PREFERRED timeout), []
       else
+        let ip = Ipaddr.Prefix.address prefix in
         let dst = Ipaddr.Prefix.network_address solicited_node_prefix ip in
-        Some (ip, TENTATIVE (timeout, n+1, Int64.add now retrans_timer)),
+        Some (prefix, TENTATIVE (timeout, n+1, Int64.add now retrans_timer)),
         [SendNS (`Unspecified, dst, ip)]
-    | ip, PREFERRED (Some (preferred_timeout, valid_lifetime)) when preferred_timeout <= now ->
+    | prefix, PREFERRED (Some (preferred_timeout, valid_lifetime)) when preferred_timeout <= now ->
+      let ip = Ipaddr.Prefix.address prefix in
       Log.debug (fun f -> f "SLAAC: %a --> DEPRECATED" Ipaddr.pp ip);
       let valid_timeout = match valid_lifetime with
         | None -> None
         | Some valid_lifetime -> Some (Int64.add now valid_lifetime)
       in
-      Some (ip, DEPRECATED valid_timeout), []
-    | ip, DEPRECATED (Some t) when t <= now ->
+      Some (prefix, DEPRECATED valid_timeout), []
+    | prefix, DEPRECATED (Some t) when t <= now ->
+      let ip = Ipaddr.Prefix.address prefix in
       Log.debug (fun f -> f "SLAAC: %a --> EXPIRED" Ipaddr.pp ip);
       None, []
-    | addr ->
-      Some addr, []
+    | x ->
+      Some x, []
 
   let tick al ~now ~retrans_timer =
     List.fold_right (fun ip (ips, acts) ->
@@ -340,22 +344,23 @@ module AddressList = struct
     match List.mem_assoc ip al with
     | false ->
       let al = (ip, TENTATIVE (lft, 0, Int64.add now retrans_timer)) :: al in
-      let dst = Ipaddr.Prefix.network_address solicited_node_prefix ip in
-      al, [SendNS (`Unspecified, dst, ip)]
+      let src = Ipaddr.Prefix.address ip in
+      let dst = Ipaddr.Prefix.network_address solicited_node_prefix src in
+      al, [SendNS (`Unspecified, dst, src)]
     | true ->
       Log.warn (fun f -> f "ndpv6: attempted to add ip %a already in address list"
-                   Ipaddr.pp ip);
+                   Ipaddr.Prefix.pp ip);
       al, []
 
   let is_my_addr al ip =
     List.exists (function
         | _, TENTATIVE _ -> false
-        | ip', (PREFERRED _ | DEPRECATED _) -> Ipaddr.compare ip' ip = 0
+        | ip', (PREFERRED _ | DEPRECATED _) -> Ipaddr.(compare (Prefix.address ip') ip) = 0
       ) al
 
   let find_prefix al pfx =
     let rec loop = function
-      | (ip, _) :: _ when Ipaddr.Prefix.mem ip pfx -> Some ip
+      | (ip, _) :: _ when Ipaddr.Prefix.mem (Ipaddr.Prefix.address ip) pfx -> Some ip
       | _ :: rest -> loop rest
       | [] -> None
     in
@@ -369,19 +374,16 @@ module AddressList = struct
       al, []
     | None ->
       let ip = Ipaddr.Prefix.network_address pfx (interface_addr mac) in
-      add al ~now ~retrans_timer ~lft ip
+      let prefix = Ipaddr.Prefix.(make (bits pfx) ip) in
+      add al ~now ~retrans_timer ~lft prefix
 
   let handle_na al ip =
     (* FIXME How to notify the client? *)
-    try
-      match List.assoc ip al with
-      | TENTATIVE _ ->
-        Log.info (fun f -> f "DAD: Failed: %a" Ipaddr.pp ip);
-        List.remove_assoc ip al
-      | _ ->
-        al
-    with
-    | Not_found -> al
+    match List.partition (fun (pre, _) -> Ipaddr.Prefix.mem ip pre) al with
+    | [ (_, TENTATIVE _) ], rest ->
+      Log.info (fun f -> f "DAD: Failed: %a" Ipaddr.pp ip);
+      rest
+    | _ -> al
 end
 
 module PrefixList = struct
@@ -1021,9 +1023,9 @@ module Parser = struct
 end
 
 type event =
-  [ `Tcp of ipaddr * ipaddr * buffer
-  | `Udp of ipaddr * ipaddr * buffer
-  | `Default of int * ipaddr * ipaddr * buffer ]
+  [ `Tcp of ipaddr * ipaddr * Cstruct.t
+  | `Udp of ipaddr * ipaddr * Cstruct.t
+  | `Default of int * ipaddr * ipaddr * Cstruct.t ]
 
 (* TODO add destination cache *)
 type context =
@@ -1142,6 +1144,9 @@ let add_ip ~now ctx ip =
   process_actions ~now ctx actions
 
 let get_ip ctx =
+  List.map Ipaddr.Prefix.address (AddressList.to_list ctx.address_list)
+
+let configured_ips ctx =
   AddressList.to_list ctx.address_list
 
 let select_source ctx dst =

src/ipv6/ndpv6.mli

@@ -14,54 +14,56 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
 
-type buffer = Cstruct.t
 type ipaddr = Ipaddr.V6.t
 type prefix = Ipaddr.V6.Prefix.t
 type time   = int64
 
-val checksum : buffer -> buffer list -> int
+val checksum : Cstruct.t -> Cstruct.t list -> int
 
 type event =
-  [ `Tcp of ipaddr * ipaddr * buffer
-  | `Udp of ipaddr * ipaddr * buffer
-  | `Default of int * ipaddr * ipaddr * buffer ]
+  [ `Tcp of ipaddr * ipaddr * Cstruct.t
+  | `Udp of ipaddr * ipaddr * Cstruct.t
+  | `Default of int * ipaddr * ipaddr * Cstruct.t ]
 
 type context
 
 val local : handle_ra:bool -> now:time -> random:(int -> Cstruct.t) -> Macaddr.t ->
-  context * (Macaddr.t * int * (buffer -> int)) list
+  context * (Macaddr.t * int * (Cstruct.t -> int)) list
 (** [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. *)
 
-val add_ip : now:time -> context -> ipaddr ->
-  context * (Macaddr.t * int * (buffer -> int)) list
+val add_ip : now:time -> context -> prefix ->
+  context * (Macaddr.t * int * (Cstruct.t -> int)) list
 (** [add_ip ~now ctx ip] is [ctx', outs] where [ctx'] is [ctx] updated with a
     new local ip and [outs] is a list of ethif packets to be sent. *)
 
 val get_ip : context -> ipaddr list
 (** [get_ip ctx] returns the list of local ips. *)
 
+val configured_ips : context -> prefix list
+(** [configured_ips ctx] returns the list of local prefixes. *)
+
 val select_source : context -> ipaddr -> ipaddr
 (** [select_source ctx ip] returns the ip that should be put in the source field
     of a packet destined to [ip]. *)
 
-val handle : now:time -> random:(int -> Cstruct.t) -> context -> buffer ->
-  context * (Macaddr.t * int * (buffer -> int)) list * event list
+val handle : now:time -> random:(int -> Cstruct.t) -> context -> Cstruct.t ->
+  context * (Macaddr.t * int * (Cstruct.t -> int)) list * event list
 (** [handle ~now ~random ctx buf] handles an incoming ipv6 packet.  It returns
     [ctx', bufs, evs] where [ctx'] is the updated context, [bufs] is a list of
     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 -> ?src:ipaddr -> ipaddr -> Tcpip.Ip.proto ->
-  int -> (buffer -> buffer -> int) -> context * (Macaddr.t * int * (buffer -> int)) list
+  int -> (Cstruct.t -> Cstruct.t -> int) -> context * (Macaddr.t * int * (Cstruct.t -> int)) list
 (** [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
     by destination, their size, and fill function. *)
 
-val tick : now:time -> context -> context * (Macaddr.t * int * (buffer -> int)) list
+val tick : now:time -> context -> context * (Macaddr.t * int * (Cstruct.t -> int)) list
 (** [tick ~now ctx] should be called periodically (every 1s is good).  It
     returns [ctx', bufs] where [ctx'] is the updated context and [bufs] is a list of
     packets to be sent. *)

src/stack-direct/tcpip_stack_direct.ml

@@ -19,13 +19,18 @@ open Lwt.Infix
 let src = Logs.Src.create "tcpip-stack-direct" ~doc:"Pure OCaml TCP/IP stack"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-module IPV4V6 (Ipv4 : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) (Ipv6 : Tcpip.Ip.S with type ipaddr = Ipaddr.V6.t) = struct
+module IPV4V6
+    (Ipv4 : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t and type prefix = Ipaddr.V4.Prefix.t)
+    (Ipv6 : Tcpip.Ip.S with type ipaddr = Ipaddr.V6.t and type prefix = Ipaddr.V6.Prefix.t) = struct
 
   type ipaddr   = Ipaddr.t
   type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
 
   let pp_ipaddr = Ipaddr.pp
 
+  type prefix = Ipaddr.Prefix.t
+  let pp_prefix = Ipaddr.Prefix.pp
+
   type error = [ Tcpip.Ip.error | `Ipv4 of Ipv4.error | `Ipv6 of Ipv6.error | `Msg of string ]
 
   let pp_error ppf = function
@@ -125,9 +130,15 @@ module IPV4V6 (Ipv4 : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) (Ipv6 : Tcpip.I
     | Ipaddr.V4 dst -> Ipaddr.V4 (Ipv4.src t.ipv4 ~dst)
     | Ipaddr.V6 dst -> Ipaddr.V6 (Ipv6.src t.ipv6 ~dst)
 
+  [@@@alert "-deprecated"]
   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)
+  [@@@alert "+deprecated"]
+
+  let configured_ips t =
+    List.map (fun cidr -> Ipaddr.V4 cidr) (Ipv4.configured_ips t.ipv4) @
+    List.map (fun cidr -> Ipaddr.V6 cidr) (Ipv6.configured_ips t.ipv6)
 
   let mtu t ~dst = match dst with
     | Ipaddr.V4 dst -> Ipv4.mtu t.ipv4 ~dst
@@ -162,7 +173,7 @@ module MakeV4V6
 
   let pp fmt t =
     Format.fprintf fmt "mac=%a,ip=%a" Macaddr.pp (Eth.mac t.ethif)
-      Fmt.(list ~sep:(any ", ") Ipaddr.pp) (IP.get_ip t.ip)
+      Fmt.(list ~sep:(any ", ") IP.pp_prefix) (IP.configured_ips t.ip)
 
   let tcp { tcp; _ } = tcp
   let udp { udp; _ } = udp