diff --git a/src/tcp/pcb.ml b/src/tcp/pcb.ml index 0caeddf62..f2eb3e3a6 100644 --- 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 index 6c318c69d..0cd173dd7 100644 --- 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 index 361b0fc8b..2ba825be6 100644 --- 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 index 1b0aa6ce1..a9b639c8f 100644 --- 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,7 +123,6 @@ let run backend fsm sut () = | None -> Lwt.return_unit | Some err -> Alcotest.fail err; - Lwt.return_unit ] @@ -131,7 +130,7 @@ let run backend fsm sut () = 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