Improve Tcp.Wire module

- add doc strings - rename `type id` into `type t` - rename the `wire` creator function into `v` - expose `src` to get the local IP
mirage · Aug 1, 2017 · e66753f · e66753f
1 parent 22c1379
commit e66753f
Show file tree

Hide file tree

Showing 4 changed files with 82 additions and 60 deletions.
diff --git a/src/tcp/pcb.ml b/src/tcp/pcb.ml
@@ -45,7 +45,7 @@ struct
     | #Mirage_protocols.Tcp.write_error as e -> Mirage_protocols.Tcp.pp_write_error ppf e
 
   type pcb = {
-    id: WIRE.id;
+    id: WIRE.t;
     wnd: Window.t;            (* Window information *)
     rxq: RXS.t;               (* Received segments queue for out-of-order data *)
     txq: TXS.t;               (* Transmit segments queue *)
@@ -61,17 +61,17 @@ struct
     ip : Ip.t;
     clock : Clock.t;
     mutable localport : int;
-    channels: (WIRE.id, connection) Hashtbl.t;
+    channels: (WIRE.t, connection) Hashtbl.t;
     (* server connections the process of connecting - SYN-ACK sent
        waiting for ACK *)
-    listens: (WIRE.id, (Sequence.t * ((pcb -> unit Lwt.t) * connection)))
+    listens: (WIRE.t, (Sequence.t * ((pcb -> unit Lwt.t) * connection)))
         Hashtbl.t;
     (* clients in the process of connecting *)
-    connects: (WIRE.id, ((connection, error) result Lwt.u * Sequence.t)) Hashtbl.t;
+    connects: (WIRE.t, ((connection, error) result Lwt.u * Sequence.t)) Hashtbl.t;
   }
 
   let pp_pcb fmt pcb =
-    Format.fprintf fmt "id=[%a] state=[%a]" WIRE.pp_id pcb.id State.pp pcb.state
+    Format.fprintf fmt "id=[%a] state=[%a]" WIRE.pp pcb.id State.pp pcb.state
 
   let pp_stats fmt t =
     Format.fprintf fmt "[channels=%d listens=%d connects=%d]"
@@ -95,7 +95,7 @@ struct
       let fin = match flags with Segment.Fin -> true | _ -> false in
       let rst = match flags with Segment.Rst -> true | _ -> false in
       let psh = match flags with Segment.Psh -> true | _ -> false in
-      WIRE.xmit ~ip ~id ~syn ~fin ~rst ~psh ~rx_ack ~seq ~window ~options datav
+      WIRE.xmit ~ip id ~syn ~fin ~rst ~psh ~rx_ack ~seq ~window ~options datav
 
     (* Output an RST response when we dont have a PCB *)
     let send_rst { ip; _ } id ~sequence ~ack_number ~syn ~fin =
@@ -104,16 +104,16 @@ struct
       let options = [] in
       let seq = ack_number in
       let rx_ack = Some Sequence.(add sequence (of_int32 datalen)) in
-      WIRE.xmit ~ip ~id ~rst:true ~rx_ack ~seq ~window ~options (Cstruct.create 0)
+      WIRE.xmit ~ip id ~rst:true ~rx_ack ~seq ~window ~options (Cstruct.create 0)
 
     (* Output a SYN packet *)
     let send_syn { ip; _ } id ~tx_isn ~options ~window =
-      WIRE.xmit ~ip ~id ~syn:true ~rx_ack:None ~seq:tx_isn ~window ~options
+      WIRE.xmit ~ip id ~syn:true ~rx_ack:None ~seq:tx_isn ~window ~options
         (Cstruct.create 0)
 
     (* Queue up an immediate close segment *)
     let close pcb =
-      Log.debug (fun f -> f "Closing connection %a" WIRE.pp_id pcb.id);
+      Log.debug (fun f -> f "Closing connection %a" WIRE.pp pcb.id);
       match State.state pcb.state with
       | State.Established | State.Close_wait ->
         UTX.wait_for_flushed pcb.utx >>= fun () ->
@@ -230,17 +230,17 @@ struct
     | Some _ ->
       Hashtbl.remove t.channels id;
       Stats.decr_channel ();
-      Log.debug (fun f -> f "removed %a from active channels" WIRE.pp_id id);
+      Log.debug (fun f -> f "removed %a from active channels" WIRE.pp id);
     | None ->
       match hashtbl_find t.listens id with
       | Some (isn, _) ->
         if isn = tx_isn then (
           Hashtbl.remove t.listens id;
           Stats.decr_listen ();
-          Log.debug (fun f -> f "removed %a from incomplete listen pcbs" WIRE.pp_id id);
+          Log.debug (fun f -> f "removed %a from incomplete listen pcbs" WIRE.pp id);
         )
       | None ->
-        Log.debug (fun f -> f "error in removing %a - no such connection" WIRE.pp_id id)
+        Log.debug (fun f -> f "error in removing %a - no such connection" WIRE.pp id)
 
   let pcb_allocs = ref 0
   let th_allocs = ref 0
@@ -346,7 +346,7 @@ struct
     (* Add the PCB to our listens table *)
     if Hashtbl.mem t.listens id then (
       Log.debug (fun f -> f "duplicate attempt to make a connection: %a .\
-      Removing the old state and replacing with new attempt" WIRE.pp_id id);
+      Removing the old state and replacing with new attempt" WIRE.pp id);
       Hashtbl.remove t.listens id;
       Stats.decr_listen ();
     );
@@ -433,7 +433,7 @@ struct
 
   let process_syn t id ~listeners ~tx_wnd ~ack_number ~sequence ~options ~syn ~fin =
     Logs.(log_with_stats Debug "process-syn" t);
-    match listeners @@ WIRE.src_port_of_id id with
+    match listeners @@ WIRE.src_port id with
     | Some pushf ->
       (* XXX: I've no clue why this is the way it is, static 16 bits
          plus some random -- hannes *)
@@ -505,7 +505,9 @@ struct
     | Error s -> Log.debug (fun f -> f "parsing TCP header failed: %s" s);
       Lwt.return_unit
     | Ok (pkt, payload) ->
-      let id = WIRE.wire ~src_port:pkt.dst_port ~dst_port:pkt.src_port ~dst:src ~src:dst in
+      let id =
+        WIRE.v ~src_port:pkt.dst_port ~dst_port:pkt.src_port ~dst:src ~src:dst
+      in
       (* Lookup connection from the active PCB hash *)
       with_hashtbl t.channels id
         (* PCB exists, so continue the connection state machine in tcp_input *)
@@ -562,7 +564,7 @@ struct
   (* Close - no more will be written *)
   let close pcb = Tx.close pcb
 
-  let dst pcb = WIRE.dst_of_id pcb.id
+  let dst pcb = WIRE.dst pcb.id, WIRE.dst_port pcb.id
 
   let getid t dst dst_port =
     (* TODO: make this more robust and recognise when all ports are gone *)
@@ -574,13 +576,14 @@ struct
       Hashtbl.mem t.connects id ||
       Hashtbl.mem t.listens id
     in
-    let inuse t id = islistener t (WIRE.src_port_of_id id) || idinuse t id in
+    let inuse t id = islistener t (WIRE.src_port id) || idinuse t id in
     let rec bumpport t =
       (match t.localport with
        | 65535 -> t.localport <- 10000
        | _ -> t.localport <- t.localport + 1);
-      let id = WIRE.wire ~src:(Ip.src t.ip ~dst)
-          ~src_port:t.localport ~dst ~dst_port in
+      let id =
+        WIRE.v ~src:(Ip.src t.ip ~dst) ~src_port:t.localport ~dst ~dst_port
+      in
       if inuse t id then bumpport t else id
     in
     bumpport t
@@ -628,7 +631,7 @@ struct
       Log.debug (fun f ->
           f "duplicate attempt to make a connection: [%a]. \
              Removing the old state and replacing with new attempt"
-            WIRE.pp_id id);
+            WIRE.pp id);
       Hashtbl.remove t.connects id;
       Stats.decr_connect ();
     );

diff --git a/src/tcp/wire.ml b/src/tcp/wire.ml
@@ -27,26 +27,26 @@ module Make (Ip:Mirage_protocols_lwt.IP) = struct
 
   let pp_error = Mirage_protocols.Ip.pp_error
 
-  type id = {
+  type t = {
     dst_port: int;             (* Remote TCP port *)
     dst: Ip.ipaddr;            (* Remote IP address *)
     src_port: int;             (* Local TCP port *)
     src: Ip.ipaddr;            (* Local IP address *)
   }
 
-  let wire ~src ~src_port ~dst ~dst_port =
-    { dst_port ; dst ; src_port ; src }
+  let v ~src ~src_port ~dst ~dst_port = { dst_port ; dst ; src_port ; src }
 
-  let src_port_of_id id = id.src_port
+  let src t = t.src
+  let dst t = t.dst
+  let src_port t = t.src_port
+  let dst_port t = t.dst_port
 
-  let dst_of_id id = (id.dst, id.dst_port)
-
-  let pp_id fmt id =
+  let pp ppf t =
     let uip = Ip.to_uipaddr in
-    Format.fprintf fmt "remote %a,%d to local %a, %d"
-      Ipaddr.pp_hum (uip id.dst) id.dst_port Ipaddr.pp_hum (uip id.src) id.src_port
+    Fmt.pf ppf "remote %a,%d to local %a, %d"
+      Ipaddr.pp_hum (uip t.dst) t.dst_port Ipaddr.pp_hum (uip t.src) t.src_port
 
-  let xmit ~ip ~id:{ src_port; dst_port; dst; _ } ?(rst=false) ?(syn=false)
+  let xmit ~ip { src_port; dst_port; dst; _ } ?(rst=false) ?(syn=false)
       ?(fin=false) ?(psh=false)
       ~rx_ack ~seq ~window ~options payload
     =

diff --git a/src/tcp/wire.mli b/src/tcp/wire.mli
@@ -16,26 +16,41 @@
 
 open Result
 
-module Make(Ip:Mirage_protocols_lwt.IP) : sig
+module Make (Ip:Mirage_protocols_lwt.IP) : sig
 
   type error = Mirage_protocols.Ip.error
+  (** The type for TCP wire errors. *)
 
   val pp_error: error Fmt.t
+  (** [pp_error] is the pretty-printer for TCP wire {!error}s. *)
 
-  type id
+  type t
+  (** The type for TCP wire values. *)
 
-  val src_port_of_id : id -> int
+  val pp: t Fmt.t
+  (** [pp] is the pretty-printer for TCP wire values. *)
 
-  val dst_of_id : id -> (Ip.ipaddr * int)
+  val dst_port : t -> int
+  (** Remote TCP port *)
 
-  val wire : src:Ip.ipaddr -> src_port:int -> dst:Ip.ipaddr -> dst_port:int -> id
+  val dst: t -> Ip.ipaddr
+  (** Remote IP address *)
 
-  val pp_id : Format.formatter -> id -> unit
+  val src_port : t -> int
+  (** Local TCP port *)
 
-  val xmit : ip:Ip.t -> id:id ->
+  val src: t -> Ip.ipaddr
+  (** Local IP address *)
+
+  val v: src:Ip.ipaddr -> src_port:int -> dst:Ip.ipaddr -> dst_port:int -> t
+  (** [v ~src ~src_port ~dst ~dst_port] is the wire value [v] with the
+      corresponding local and remote IP/TCP parameters. *)
+
+  val xmit: ip:Ip.t -> t ->
     ?rst:bool -> ?syn:bool -> ?fin:bool -> ?psh:bool ->
     rx_ack:Sequence.t option -> seq:Sequence.t -> window:int ->
     options:Options.t list ->
     Cstruct.t -> (unit, error) result Lwt.t
+  (** [xmit] emits a TCP packet over the network. *)
 
 end
diff --git a/test/test_rfc5961.ml b/test/test_rfc5961.ml
@@ -112,7 +112,7 @@ let run backend fsm sut () =
 
         (* time to let the other end connects to the network and listen.
          * Otherwise initial syn might need to be repeated slowing down the test *)
-        (Time.sleep_ns (Duration.of_ms 100) >>= fun () -> 
+        (Time.sleep_ns (Duration.of_ms 100) >>= fun () ->
          sut stackv4 (Lwt_mvar.put error_mbox) >>= fun _ ->
          Time.sleep_ns (Duration.of_ms 100));
       ] >>= fun () -> Lwt.return_none);
@@ -123,15 +123,14 @@ let run backend fsm sut () =
   | None -> Lwt.return_unit
   | Some err ->
     Alcotest.fail err;
-    Lwt.return_unit
   ]
 
 
 (* Helper functions *)
 let reply_id_from ~src ~dst data =
   let sport = Tcp_wire.get_tcp_src_port data in
   let dport = Tcp_wire.get_tcp_dst_port data in
-  WIRE.wire ~dst_port:sport ~dst:src ~src_port:dport ~src:dst
+  WIRE.v ~dst_port:sport ~dst:src ~src_port:dport ~src:dst
 
 let ack_for data =
   match Tcp_unmarshal.of_cstruct data with
@@ -187,11 +186,11 @@ let blind_rst_on_syn_scenario =
       if syn then (
         let id = reply_id_from ~src ~dst data in
         (* This -blind- reset must be ignored because of invalid ack. *)
-        WIRE.xmit ~ip ~id ~rst:true ~rx_ack:(ack_from_past data 1)
+        WIRE.xmit ~ip id ~rst:true ~rx_ack:(ack_from_past data 1)
           ~seq:(Sequence.of_int32 0l) ~window ~options (Cstruct.create 0)
         >|= Rresult.R.get_ok >>= fun () ->
         (* The syn-ack must be received and connection established *)
-        WIRE.xmit ~ip ~id ~syn:true ~rx_ack:(ack data) ~seq:(Sequence.of_int32 0l) ~window
+        WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data) ~seq:(Sequence.of_int32 0l) ~window
           ~options (Cstruct.create 0)
           >|= Rresult.R.get_ok >>= fun () ->
         Lwt.return (Fsm_next `WAIT_FOR_ACK)
@@ -214,7 +213,7 @@ let connection_refused_scenario =
       if syn then (
         let id = reply_id_from ~src ~dst data in
         (* refused *)
-        WIRE.xmit ~ip ~id ~rst:true ~rx_ack:(ack data) ~seq:(Sequence.of_int32 0l) ~window
+        WIRE.xmit ~ip id ~rst:true ~rx_ack:(ack data) ~seq:(Sequence.of_int32 0l) ~window
           ~options (Cstruct.create 0)
           >|= Rresult.R.get_ok >>= fun () ->
         Lwt.return Fsm_done
@@ -223,7 +222,7 @@ let connection_refused_scenario =
   let sut stack _fail =
     let conn = VNETIF_STACK.Stackv4.TCPV4.create_connection (VNETIF_STACK.Stackv4.tcpv4 stack) in
     (* connection must be rejected *)
-    expect_error `Refused "connect" conn (server_ip, 80) in 
+    expect_error `Refused "connect" conn (server_ip, 80) in
   (`WAIT_FOR_SYN, fsm), sut
 
 
@@ -234,7 +233,7 @@ let blind_rst_on_established_scenario =
       let syn = Tcp_wire.get_syn data in
       if syn then (
         let id = reply_id_from ~src ~dst data in
-        WIRE.xmit ~ip ~id ~syn:true ~rx_ack:(ack data) ~seq:(Sequence.of_int32 0l) ~window
+        WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data) ~seq:(Sequence.of_int32 0l) ~window
           ~options (Cstruct.create 0)
           >|= Rresult.R.get_ok >>= fun () ->
         Lwt.return (Fsm_next `WAIT_FOR_ACK)
@@ -245,7 +244,7 @@ let blind_rst_on_established_scenario =
         (* This -blind- reset is acceptable, but don't exactly match the next sequence (we started at 0, this is 10).
          * Must trigger a challenge ack and not tear down the connection *)
         let id = reply_id_from ~src ~dst data in
-        WIRE.xmit ~ip ~id ~rst:true ~rx_ack:None ~seq:(Sequence.of_int32 10l)
+        WIRE.xmit ~ip id ~rst:true ~rx_ack:None ~seq:(Sequence.of_int32 10l)
           ~window ~options (Cstruct.create 0)
           >|= Rresult.R.get_ok >>= fun () ->
         Lwt.return (Fsm_next `WAIT_FOR_CHALLENGE)
@@ -265,8 +264,8 @@ let rst_on_established_scenario =
       let syn = Tcp_wire.get_syn data in
       if syn then (
         let id = reply_id_from ~src ~dst data in
-        WIRE.xmit ~ip ~id ~syn:true ~rx_ack:(ack data) ~seq:(Sequence.of_int32
-                                                               0l) ~window
+        WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data)
+          ~seq:(Sequence.of_int32 0l) ~window
           ~options (Cstruct.create 0)
           >|= Rresult.R.get_ok >>= fun () ->
         Lwt.return (Fsm_next `WAIT_FOR_ACK)
@@ -276,7 +275,7 @@ let rst_on_established_scenario =
       if Tcp_wire.get_ack data then (
         let id = reply_id_from ~src ~dst data in
         (* This reset is acceptable and exactly in sequence. Must trigger a reset on the other end *)
-        WIRE.xmit ~ip ~id ~rst:true ~rx_ack:None ~seq:(Sequence.of_int32 1l)
+        WIRE.xmit ~ip id ~rst:true ~rx_ack:None ~seq:(Sequence.of_int32 1l)
           ~window ~options (Cstruct.create 0)
           >|= Rresult.R.get_ok >>= fun () ->
         Lwt.return Fsm_done
@@ -301,8 +300,8 @@ let blind_syn_on_established_scenario =
       let syn = Tcp_wire.get_syn data in
       if syn then (
         let id = reply_id_from ~src ~dst data in
-        WIRE.xmit ~ip ~id ~syn:true ~rx_ack:(ack data) ~seq:(Sequence.of_int32
-                                                               0l) ~window
+        WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data)
+          ~seq:(Sequence.of_int32 0l) ~window
           ~options (Cstruct.create 0)
           >|= Rresult.R.get_ok >>= fun () ->
         Lwt.return (Fsm_next `WAIT_FOR_ACK)
@@ -311,8 +310,10 @@ let blind_syn_on_established_scenario =
     | `WAIT_FOR_ACK ->
       if Tcp_wire.get_ack data then (
         let id = reply_id_from ~src ~dst data in
-        (* This -blind- syn should trigger a challenge ack and not tear down the connection *)
-        WIRE.xmit ~ip ~id ~syn:true ~rx_ack:None ~seq:(Sequence.of_int32 10l)
+
+        (* This -blind- syn should trigger a challenge ack and not
+           tear down the connection *)
+        WIRE.xmit ~ip id ~syn:true ~rx_ack:None ~seq:(Sequence.of_int32 10l)
           ~window ~options (Cstruct.create 0)
           >|= Rresult.R.get_ok >>= fun () ->
         Lwt.return (Fsm_next `WAIT_FOR_CHALLENGE)
@@ -334,8 +335,8 @@ let blind_data_injection_scenario =
       let syn = Tcp_wire.get_syn data in
       if syn then (
         let id = reply_id_from ~src ~dst data in
-        WIRE.xmit ~ip ~id ~syn:true ~rx_ack:(ack data) ~seq:(Sequence.of_int32
-                                                               1000000l) ~window
+        WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data)
+          ~seq:(Sequence.of_int32 1000000l) ~window
           ~options (Cstruct.create 0)
           >|= Rresult.R.get_ok >>= fun () ->
         Lwt.return (Fsm_next `WAIT_FOR_ACK)
@@ -344,9 +345,11 @@ let blind_data_injection_scenario =
     | `WAIT_FOR_ACK ->
       if Tcp_wire.get_ack data then (
         let id = reply_id_from ~src ~dst data in
-        (* This -blind- data should trigger a challenge ack and not tear down the connection *)
+        (* This -blind- data should trigger a challenge ack and not
+           tear down the connection *)
         let invalid_ack =  ack_from_past data (window +100) in
-        WIRE.xmit ~ip ~id ~rx_ack:invalid_ack ~seq:(Sequence.of_int32 1000001l) ~window ~options page
+        WIRE.xmit ~ip id ~rx_ack:invalid_ack ~seq:(Sequence.of_int32 1000001l)
+          ~window ~options page
           >|= Rresult.R.get_ok >>= fun () ->
         Lwt.return (Fsm_next `WAIT_FOR_CHALLENGE)
       ) else
@@ -370,8 +373,8 @@ let data_repeated_ack_scenario =
       let syn = Tcp_wire.get_syn data in
       if syn then (
         let id = reply_id_from ~src ~dst data in
-        WIRE.xmit ~ip ~id ~syn:true ~rx_ack:(ack data) ~seq:(Sequence.of_int32
-                                                               1000000l) ~window
+        WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data)
+          ~seq:(Sequence.of_int32 1000000l) ~window
           ~options (Cstruct.create 0)
           >|= Rresult.R.get_ok >>= fun () ->
         Lwt.return (Fsm_next `WAIT_FOR_ACK)
@@ -382,7 +385,8 @@ let data_repeated_ack_scenario =
         let id = reply_id_from ~src ~dst data in
         (* Ack is old but within the acceptable window. *)
         let valid_ack = ack_from_past data (window -100) in
-        WIRE.xmit ~ip ~id ~rx_ack:valid_ack ~seq:(Sequence.of_int32 1000001l) ~window ~options page
+        WIRE.xmit ~ip id ~rx_ack:valid_ack ~seq:(Sequence.of_int32 1000001l)
+          ~window ~options page
         >|= Rresult.R.get_ok >>= fun () ->
         Lwt.return (Fsm_next `WAIT_FOR_DATA_ACK)
       ) else