diff --git a/.merlin b/.merlin index 992ed1ab0..497d0ee01 100644 --- a/.merlin +++ b/.merlin @@ -1,5 +1,8 @@ PKG lwt ipaddr lwt mirage-types cstruct io-page uint mirage-flow oUnit alcotest +PKG mirage-vnetif pcap-format mirage-console.unix + B _build/** S lib/ S tcp/ S unix/ +S dhcp/ diff --git a/.travis-ci.sh b/.travis-ci.sh index 5ab84620a..621560345 100755 --- a/.travis-ci.sh +++ b/.travis-ci.sh @@ -7,7 +7,6 @@ bash -ex .travis-opam.sh export OPAMYES=1 eval `opam config env` -prefix=`opam config var prefix` git clone git://github.com/mirage/mirage-www cd mirage-www diff --git a/.travis.yml b/.travis.yml index a3d822d3b..117682db1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,4 +2,4 @@ language: c script: bash -ex .travis-ci.sh env: - OCAML_VERSION=4.02 PACKAGE=tcpip MIRAGE_MODE=unix - - OCAML_VERSION=4.01 PACKAGE=tcpip MIRAGE_MODE=xen + - UPDATE_GCC_BINUTILS=1 OCAML_VERSION=4.01 PACKAGE=tcpip MIRAGE_MODE=xen diff --git a/CHANGES b/CHANGES.md similarity index 70% rename from CHANGES rename to CHANGES.md index a26c3faad..46fbfa451 100644 --- a/CHANGES +++ b/CHANGES.md @@ -1,26 +1,75 @@ -2.4.3 (2015-05-05) +### 2.6.1 (2015-09-15) + +* Add optional arguments for settings in ip v6 and v4 connects (#170, by @Drup) +* Expose `Ipv4.Routing.No_route_to_destination_address` (#166, by @yomimono) + +### 2.6.0 (2015-07-29) + +* ARP now handles ARP frames, not Ethernet frames with ARP payload + (#164, by @hannesm) +* Check length of received ethernet frame to avoid cstruct exceptions + (#117, by @hannesm) +* Pull arpv4 module out of ipv4. Also add unit-tests for the newly created + ARP library (#155, by @yomimono) + +### 2.5.1 (2015-07-07) + +* Fix regression introduced in 2.5.0 where packet loss could lead to the + connection to become very slow (#157, MagnusS, @talex5, @yomimono and + @balrajsingh) +* Improve the tests: more logging, more tracing and compile to native code when + available, etc (@MagnusS and @talex5) +* Do not raise `Invalid_argument("Lwt.wakeup_result")` everytime a connection + is closed. Also now pass the raised exceptions to `Lwt.async_exception_hook` + instead of ignoring them transparently, so the user can decide to shutdown + its application if something wrong happens (#153, #156, @yomomino and @talex5) +* The `channel` library now lives in a separate repository and is released + separately (#159, @samoht) + +### 2.5.0 (2015-06-10) + +* The test runs now produce `.pcap` files (#141, by @MagnusS) +* Strip trailing bytes from network packets (#145, by @talex5) +* Add tests for uniform packet loss (#147, by @MagnusS) +* fixed bug where in case of out of order packets the ack and window were set + incorrectly (#140, #146) +* Properly handle RST packets (#107, #148) +* Add a `Log` module to control at runtime the debug statements which are + displayed (#142) +* Writing in a PCB which does not have the right state now returns an error + instead of blocking (#150) + +### 2.4.3 (2015-05-05) + * Fix infinite loop in `Channel.read_line` when the line does not contain a CRLF sequence (#131) -2.4.2 (2015-04-29) +### 2.4.2 (2015-04-29) + * Fix a memory leak in `Channel` (#119, by @yomimono) * Add basic unit-test for channels (#119, by @yomimono) * Add alcotest testing templates * Modernize Travis CI scripts -2.4.1 (2015-04-21): +### 2.4.1 (2015-04-21) + * Merge between 2.4.0 and 2.3.1 -2.4.0: (2015-03-24) +### 2.4.0: (2015-03-24) + * ARP improvements (#118) -2.3.1 (2015-03-31): +### 2.3.1 (2015-03-31) + * Do not raise an assertion if an IP frame has extra trailing bytes (#221). -2.3.0 (2015-03-09): -* Fix `STACKV4` for the `DEVICE` signature which has `connect` removed (in Mirage types 2.3+). +### 2.3.0 (2015-03-09) + +* Fix `STACKV4` for the `DEVICE` signature which has `connect` removed + (in Mirage types 2.3+). + +### 2.2.3 (2015-03-09) -2.2.3 (2015-03-09): * Add ICMPv6 error reporting functions (#101) * Add universal IP address converters (#108) * Add `error_message` functions for human-readable errors (#98) @@ -29,14 +78,18 @@ * Unhook unused modules `Sliding_window` and `Profiler` from the build. (#112) * Add an explicit `connect` method to the signatures. (#100) -2.2.2 (2015-01-11): -* Readded tracing and ARP fixes which got accidentally reverted in the IPv6 merge. (#96) +### 2.2.2 (2015-01-11) + +* Readded tracing and ARP fixes which got accidentally reverted in the IPv6 + merge. (#96) + +### 2.2.1 (2014-12-20) -2.2.1 (2014-12-20): -* Use `Bytes` instead of `String` to begin the `-safe-string` migration in OCaml 4.02.0 (#93). +* Use `Bytes` instead of `String` to begin the `-safe-string` migration in OCaml + 4.02.0 (#93). * Remove dependency on `uint` to avoid the need for a C stub (#92). -2.2.0 (2014-12-18): +### 2.2.0 (2014-12-18) Add IPv6 support. This changeset minimises interface changes to the existing `STACKV4` interfaces to faciliate a progressive merge. The only visible @@ -49,101 +102,124 @@ interface changes are: * Several types that had `v4` in their names (like `IPV4.ipv4addr`) have lost that particle. -2.1.1 (2014-12-12): +### 2.1.1 (2014-12-12) + * Improve console printing for the DHCP client to output line breaks properly on Xen consoles. -2.1.0 (2014-12-07): +### 2.1.0 (2014-12-07) + * Build Xen stubs separately, with `CFLAGS` from `mirage-xen` 2.1.0+. This allows us to use the red zone under x86_64 Unix again. * Adding tracing labels and counters, which introduces a new dependency on the `mirage-profile` package. -2.0.3 (2014-12-05): +### 2.0.3 (2014-12-05) + * Fixed race waiting for ARP response (#86). * Move the the code that configures IPv4 address, netmask and gateways after receiving a successful lease out of the `Dhcp_clientv4` module and into `Stackv4` (#87) -2.0.2 (2014-12-01): -* Add IPv4 multicast to MAC address mapping in IPv4 output processing (#81 from Luke Dunstan). -* Improve formatting of DHCP console logging, including printing out options (#83). +### 2.0.2 (2014-12-01) + +* Add IPv4 multicast to MAC address mapping in IPv4 output processing + (#81 from Luke Dunstan). +* Improve formatting of DHCP console logging, including printing out options + (#83). * Build with -mno-red-zone on x86_64 to avoid stack corruption on Xen (#80). -2.0.1 (2014-11-04): +### 2.0.1 (2014-11-04) + * Fixed race condition in the signalling between the rx/tx threads under load. * Experimentally switch to immediate ACKs in TCPv4 by default instead of delayed ones. -2.0.0 (2014-11-02): +### 2.0.0 (2014-11-02) + * Moved 1s complement checksum C code here from mirage-platform. * Depend on `Console_unix` and `Console_xen` instead of `Console`. * [socket] Do not return an `Eof` when writing 0-length buffer (#76). -* [socket] Accept callbacks now run in async threads instead of being serialised (#75). +* [socket] Accept callbacks now run in async threads instead of being serialised + (#75). + +### 1.1.6 (2014-07-20) -1.1.6 (20-July-2014): * Quieten down the stack logging rate by not announcing IPv6 packet discards. * Raise exception `Bad_option` for unparseable or invalid TCPv4 options (#57). -* Fix linking error with module `Tcp_checksum` by lifting it into top library (#60). +* Fix linking error with module `Tcp_checksum` by lifting it into top library + (#60). * Add `opam` file to permit easier local pinning, and fix Travis to use this. -1.1.5 (18-June-2014): +### 1.1.5 (2014-06-18) + * Ensure that DHCP completes before the application is started, so that unikernels that establish outgoing connections can do so without a race. (fix from Mindy Preston in #53, followup in #55) * Add `echo`, `chargen` and `discard` services into the `examples/` directory. (from Mindy Preston in #52). -1.1.4 (03-June-2014): +### 1.1.4 (2014-06-03) + * [tcp] Fully process the last `ACK` in a 3-way handshake for server connections. This ensures that a `FIN` is correctly transmitted upon application-initiated connection close. (fix from Mindy Preston in #51). -1.1.3 (01-April-2014): +### 1.1.3 (2014-03-01) + * Expose IPV4 through the STACKV4 interface. -1.1.2 (27-March-2014): +### 1.1.2 (2014-03-27) + * Fix DHCP variable length option parsing for MTU responses, which in turns improves robustness on Amazon EC2 (fix from @yomimono via mirage/mirage-tcpip#48) -1.1.1 (21-February-2014): +### 1.1.1 (2014-02-21) + * Catch and ignore top-level socket exceptions (#219). * Set `SO_REUSEADDR` on listening sockets for Unix (#218). * Adapt the Stack interfaces to the v1.1.1 mirage-types interface (see mirage/mirage#226 for details). -1.1.0 (03-February-2014): +### 1.1.0 (2014-02-03) + * Rewrite of the library as a set of functors that parameterize the stack across the `V1_LWT` module types from Mirage 1.1.x. This removes the need to compile separate Xen and Unix versions of the stack. -0.9.5 (08-December-2013): +### 0.9.5 (2013-12-08) + * Build for either Xen or Unix, depending on the value of the `OS` envvar. * Shift to the `mirage-types` 0.5.0+ interfaces, which breaks the socket backend (temporarily). * Port the direct stack to the new interfaces. * Add Travis CI scripts. -0.9.4 (09-August-2013): +### 0.9.4 (2013-08-09) + * Use the `Ipaddr` external library and remove the Homebrew equivalents in `Nettypes`. -0.9.3 (18-July-2013): +### 0.9.3 (2013-07-18) + * Changes in module Manager: Removed some functions from the `.mli (plug/unplug) and added some modifications in the way the Manager interacts with the underlying module Netif. The Netif.create function does not take a callback anymore. -0.9.2 (09-July-2013): +### 0.9.2 (2013-07-09) + * Improve TCP state machine for connection teardown. * Limit fragment number to 8, and coalesce buffers if it goes higher. * Adapt to mirage-platform-0.9.2 API changes. -0.9.1 (12-Jun-2013): +### 0.9.1 (2013-06-12) + * Depend on mirage-platform-0.9.1 direct tuntap interfaces. * Version bump to catch up with mirage-platform. -0.5.2 (08-Feb-2013): +### 0.5.2 (08-Feb-2013-02-03) + * Encourage scatter-gather I/O all the time, rather than playing tricks with packet header buffers. This simplifies the output path considerably and cuts minor heap allocations down. @@ -151,14 +227,17 @@ interface changes are: compiler can do cross-module optimization (this is not a fatal error, but will impact performance if the `cmx` file is not present). -0.5.1 (20-Dec-2012): +### 0.5.1 (20-Dec-2012-12-20) + * Update socket stack to use Cstruct 0.6.0 API -0.5.0 (20-Dec-2012): +### 0.5.0 (2012-12-20) + * Update Cstruct API to 0.6.0 * [tcp] write now blocks if the write buffer and write window are full -0.4.1 (14-Dec-2012): +### 0.4.1 (2012-12-14) + * Add iperf self-test that creates two VIFs and transmits across them. This is a useful local test which stresses the bridge code using just one VM. @@ -171,11 +250,13 @@ interface changes are: * Fix TCP fast recovery to wait until all in-flight packets are acked, rather then exiting early. -0.4.0 (11-Dec-2012): +### 0.4.0 (11-Dec-2012-12-11) + * Require OCaml-4.00.0 or higher, and add relevant build fixes to deal with module packing. -0.3.1 (10-Dec-2012): +### 0.3.1 (2012-12-10) + * Fix the DHCP client marshalling for IPv4 addresses. * Expose the interface MAC address in the Manager signature. * Tweak TCP ISN calculation to be more friendly on a 32-bit host. @@ -184,5 +265,6 @@ interface changes are: * Add Ethif.set/disable_promiscuous to permit directly tapping a network interface. -0.3.0 (04-Sep-2012): +### 0.3.0 (2012-09-04) + * Initial public release. diff --git a/README.md b/README.md index 1aa55c771..317e3504d 100644 --- a/README.md +++ b/README.md @@ -4,3 +4,7 @@ system that supports IPv4, IPv6, ARPv4, DHCPv4 and TCP/IP. * WWW: * E-mail: * Issues: + +### License + +`mirage-tcpip` is distributed under the ISC license. diff --git a/_oasis b/_oasis index 7702db4d9..ab0a80a84 100644 --- a/_oasis +++ b/_oasis @@ -1,9 +1,10 @@ OASISFormat: 0.4 Name: tcpip -Version: 2.4.3 +Version: 2.6.1 Synopsis: Ethernet, TCP/IPv4 and DHCPv4 library Authors: Anil Madhavapeddy, Balraj Singh, Richard Mortier, - Nicolas Ojeda Bar, Thomas Gazagnaire + Nicolas Ojeda Bar, Thomas Gazagnaire, Vincent Bernardoff, + Magnus Skjegstad, Mindy Preston, Thomas Leonard License: ISC Plugins: META (0.4), DevFiles (0.4) BuildTools: ocamlbuild @@ -40,12 +41,20 @@ Library ethif Modules: Ethif BuildDepends: tcpip,io-page,mirage-types,ipaddr,cstruct,lwt +Library arpv4 + CompiledObject: best + Path: lib + Findlibparent: tcpip + Findlibname: arpv4 + Modules: Arpv4, Arpv4_wire + BuildDepends: tcpip,io-page,mirage-types,ipaddr,cstruct,lwt,cstruct.syntax + Library ipv4 CompiledObject: best Path: lib Findlibparent: tcpip Findlibname: ipv4 - Modules: Ipv4, Arpv4 + Modules: Ipv4 BuildDepends: io-page,mirage-types,ipaddr,cstruct,lwt,tcpip Library ipv6 @@ -71,7 +80,8 @@ Library tcp Findlibparent: tcpip Findlibname: tcp Modules: Options,Wire,State,Tcptimer,Sequence,Ack, - Window,Segment,User_buffer,Pcb,Flow + Window,Segment,User_buffer,Pcb,Flow, + Stats, Log BuildDepends: io-page, mirage-types, ipaddr, @@ -79,19 +89,8 @@ Library tcp lwt, tcpip, tcpip.ipv4, - tcpip.ipv6 - -Library channel - CompiledObject: best - Path: channel - Findlibparent: tcpip - Findlibname: channel - Modules: Channel - BuildDepends: io-page, - mirage-types, - ipaddr, - cstruct, - lwt + tcpip.ipv6, + mirage-profile Library dhcpv4 CompiledObject: best @@ -118,6 +117,7 @@ Library "tcpip-stack-direct" cstruct, lwt, tcpip.ethif, + tcpip.arpv4, tcpip.udp, tcpip.tcp, tcpip.dhcpv4 @@ -133,6 +133,17 @@ Library "ethif-unix" lwt, lwt.unix +Library "arpv4-unix" + CompiledObject: best + Path: unix + Findlibparent: tcpip + Findlibname: arpv4-unix + Modules: Arpv4_unix + BuildDepends: tcpip.ethif, + mirage-net-unix, + lwt, + lwt.unix + Library "ipv4-unix" CompiledObject: best Path: unix @@ -217,7 +228,7 @@ Library "tcpv4-unix" Modules: Tcpv4_unix BuildDepends: tcpip.tcp, tcpip.ipv4-unix, - tcpip.channel, + channel, lwt, lwt.unix, mirage-unix, @@ -234,7 +245,7 @@ Library "tcpv6-unix" Modules: Tcpv6_unix BuildDepends: tcpip.tcp, tcpip.ipv6-unix, - tcpip.channel, + channel, lwt, lwt.unix, mirage-unix, @@ -301,14 +312,16 @@ Library "tcpip-stack-socket" io-page.unix Executable test - Build$: flag(tests) - Path: lib_test - Custom: true - MainIs: test.ml - ByteOpt: -g - BuildDepends: alcotest, oUnit, lwt, lwt.unix, io-page.unix, tcpip.channel, - mirage-flow, mirage-vnetif, mirage-console.unix, tcpip.ethif, tcpip.tcp + CompiledObject: best + Build$: flag(tests) + install: false + Path: lib_test/ + MainIs: test.ml + Custom: true + BuildDepends: alcotest, oUnit, lwt, lwt.unix, io-page.unix, + mirage-profile, mirage-flow, mirage-vnetif, + mirage-console.unix, mirage-clock-unix, tcpip.ethif, tcpip.tcp, pcap-format Test test - Run$: flag(tests) - Command: $test + Run$: flag(tests) + Command: $test -q diff --git a/_tags b/_tags index 035dc4d1a..23bab04f3 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: ff3f3aaffeb9a8ae52f69f7e1b8a25ee) +# DO NOT EDIT (digest: b9afd8f7c25862ce87cac4dd55d2c26b) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -32,6 +32,8 @@ true: annot, bin_annot : use_libtcpip_xen_stubs # Library ethif "lib/ethif.cmxs": use_ethif +# Library arpv4 +"lib/arpv4.cmxs": use_arpv4 # Library ipv4 "lib/ipv4.cmxs": use_ipv4 # Library ipv6 @@ -51,6 +53,8 @@ true: annot, bin_annot "tcp/user_buffer.cmx": for-pack(Tcp) "tcp/pcb.cmx": for-pack(Tcp) "tcp/flow.cmx": for-pack(Tcp) +"tcp/stats.cmx": for-pack(Tcp) +"tcp/log.cmx": for-pack(Tcp) : pkg_bytes : pkg_cstruct : pkg_io-page @@ -61,13 +65,6 @@ true: annot, bin_annot : use_ipv4 : use_ipv6 : use_tcpip -# Library channel -"channel/channel.cmxs": use_channel -: pkg_cstruct -: pkg_io-page -: pkg_ipaddr -: pkg_lwt -: pkg_mirage-types # Library dhcpv4 "dhcp/dhcpv4.cmxs": use_dhcpv4 : pkg_bytes @@ -83,11 +80,13 @@ true: annot, bin_annot "lib/tcpip-stack-direct.cmxs": use_tcpip-stack-direct : pkg_bytes : pkg_cstruct +: pkg_cstruct.syntax : pkg_io-page : pkg_ipaddr : pkg_lwt : pkg_mirage-profile : pkg_mirage-types +: use_arpv4 : use_dhcpv4 : use_ethif : use_ipv4 @@ -97,6 +96,8 @@ true: annot, bin_annot : use_udp # Library ethif-unix "unix/ethif-unix.cmxs": use_ethif-unix +# Library arpv4-unix +"unix/arpv4-unix.cmxs": use_arpv4-unix # Library ipv4-unix "unix/ipv4-unix.cmxs": use_ipv4-unix # Library ipv6-unix @@ -119,12 +120,14 @@ true: annot, bin_annot "unix/tcpv6-socket.cmxs": use_tcpv6-socket # Library tcpip-stack-unix "unix/tcpip-stack-unix.cmxs": use_tcpip-stack-unix +: pkg_channel +: pkg_cstruct.syntax : pkg_mirage-clock-unix : pkg_mirage-console.unix : pkg_mirage-net-unix : pkg_mirage-types.lwt : pkg_mirage-unix -: use_channel +: use_arpv4 : use_dhcpv4 : use_ethif : use_ethif-unix @@ -158,28 +161,27 @@ true: annot, bin_annot : use_udpv4-socket : use_udpv6-socket # Executable test -"lib_test/test.byte": oasis_executable_test_byte -: oasis_executable_test_byte -"lib_test/test.byte": pkg_alcotest -"lib_test/test.byte": pkg_bytes -"lib_test/test.byte": pkg_cstruct -"lib_test/test.byte": pkg_io-page -"lib_test/test.byte": pkg_io-page.unix -"lib_test/test.byte": pkg_ipaddr -"lib_test/test.byte": pkg_lwt -"lib_test/test.byte": pkg_lwt.unix -"lib_test/test.byte": pkg_mirage-console.unix -"lib_test/test.byte": pkg_mirage-flow -"lib_test/test.byte": pkg_mirage-profile -"lib_test/test.byte": pkg_mirage-types -"lib_test/test.byte": pkg_mirage-vnetif -"lib_test/test.byte": pkg_oUnit -"lib_test/test.byte": use_channel -"lib_test/test.byte": use_ethif -"lib_test/test.byte": use_ipv4 -"lib_test/test.byte": use_ipv6 -"lib_test/test.byte": use_tcp -"lib_test/test.byte": use_tcpip +: pkg_alcotest +: pkg_bytes +: pkg_cstruct +: pkg_io-page +: pkg_io-page.unix +: pkg_ipaddr +: pkg_lwt +: pkg_lwt.unix +: pkg_mirage-clock-unix +: pkg_mirage-console.unix +: pkg_mirage-flow +: pkg_mirage-profile +: pkg_mirage-types +: pkg_mirage-vnetif +: pkg_oUnit +: pkg_pcap-format +: use_ethif +: use_ipv4 +: use_ipv6 +: use_tcp +: use_tcpip : pkg_alcotest : pkg_bytes : pkg_cstruct @@ -188,19 +190,20 @@ true: annot, bin_annot : pkg_ipaddr : pkg_lwt : pkg_lwt.unix +: pkg_mirage-clock-unix : pkg_mirage-console.unix : pkg_mirage-flow : pkg_mirage-profile : pkg_mirage-types : pkg_mirage-vnetif : pkg_oUnit -: use_channel +: pkg_pcap-format : use_ethif : use_ipv4 : use_ipv6 : use_tcp : use_tcpip -"lib_test/test.byte": custom +: custom # OASIS_STOP true: annot, bin_annot, principal, strict_sequence, debug : pkg_cstruct.syntax diff --git a/channel/channel.ml b/channel/channel.ml deleted file mode 100644 index 1982d7978..000000000 --- a/channel/channel.ml +++ /dev/null @@ -1,218 +0,0 @@ -(* - * Copyright (c) 2011-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. - *) - -(** Buffered reading and writing over the Flow API *) - -open Lwt - -module Make(Flow:V1_LWT.FLOW) = struct - - type flow = Flow.flow - type buffer = Cstruct.t - type +'a io = 'a Lwt.t - type 'a io_stream = 'a Lwt_stream.t - - exception Write_error of Flow.error - exception Read_error of Flow.error - - type t = { - flow: flow; - mutable ibuf: Cstruct.t option; (* Queue of incoming buf *) - mutable obufq: Cstruct.t list; (* Queue of completed writebuf *) - mutable obuf: Cstruct.t option; (* Active write buffer *) - mutable opos: int; (* Position in active write buffer *) - } - - let create flow = - let ibuf = None in - let obufq = [] in - let obuf = None in - let opos = 0 in - { ibuf; obuf; flow; obufq; opos } - - let to_flow { flow; _ } = flow - - let ibuf_refill t = - Flow.read t.flow >>= function - | `Ok buf -> - (* users of get_ibuf (and therefore ibuf_refill) expect the buffer - returned here to have length >0; if Flow.read ever gives us empty - buffers, this will be violated causing Channel users to see Cstruct - exceptions *) - t.ibuf <- Some buf; - return_unit - | `Error e -> - fail (Read_error e) - | `Eof -> - (* close the flow before throwing exception; otherwise it will never be - GC'd *) - Flow.close t.flow >>= fun () -> - fail End_of_file - - let rec get_ibuf t = - match t.ibuf with - | None -> ibuf_refill t >>= fun () -> get_ibuf t - | Some buf when Cstruct.len buf = 0 -> ibuf_refill t >>= fun () -> get_ibuf t - | Some buf -> return buf - - (* Read one character from the input channel *) - let read_char t = - get_ibuf t (* the fact that we returned means we have at least 1 char *) - >>= fun buf -> - let c = Cstruct.get_char buf 0 in - t.ibuf <- Some (Cstruct.shift buf 1); (* advance read buffer, possibly to - EOF *) - return c - - (* Read up to len characters from the input channel - and at most a full view. If not specified, read all *) - let read_some ?len t = - (* get_ibuf potentially throws EOF-related exceptions *) - get_ibuf t >>= fun buf -> - let avail = Cstruct.len buf in - let len = match len with |Some len -> len |None -> avail in - if len < avail then begin - let hd,tl = Cstruct.split buf len in - t.ibuf <- Some tl; (* leave some in the buffer; next time, we won't do a - blocking read *) - return hd - end else begin - t.ibuf <- None; - return buf - end - - (* Read up to len characters from the input channel as a - stream (and read all available if no length specified *) - let read_stream ?len t = - Lwt_stream.from (fun () -> - Lwt.catch - (fun () -> read_some ?len t >>= fun v -> return (Some v)) - (function End_of_file -> return_none | e -> fail e) - ) - - (* Read until a character is found *) - let read_until t ch = - Lwt.catch - (fun () -> - get_ibuf t >>= fun buf -> - let len = Cstruct.len buf in - let rec scan off = - if off = len then None - else if Cstruct.get_char buf off = ch then Some off else scan (off+1) - in - match scan 0 with - | None -> (* not found, return what we have until EOF *) - t.ibuf <- None; (* basically guaranteeing that next read is EOF *) - return (false, buf) - | Some off -> (* found, so split the buffer *) - let hd = Cstruct.sub buf 0 off in - t.ibuf <- Some (Cstruct.shift buf (off+1)); - return (true, hd)) - (function End_of_file -> return (false, Cstruct.create 0) | e -> fail e) - - (* This reads a line of input, which is terminated either by a CRLF - sequence, or the end of the channel (which counts as a line). - @return Returns a stream of views that terminates at EOF. *) - let read_line t = - let rec get acc = - read_until t '\n' >>= function - |(false, v) -> - if Cstruct.len v = 0 then return (v :: acc) else get (v :: acc) - |(true, v) -> begin - (* chop the CR if present *) - let vlen = Cstruct.len v in - let v = - if vlen > 0 && (Cstruct.get_char v (vlen-1) = '\r') then - Cstruct.sub v 0 (vlen-1) else v - in - return (v :: acc) - end - in - get [] >|= List.rev - - (* Output functions *) - - let alloc_obuf t = - let buf = Io_page.to_cstruct (Io_page.get 1) in - t.obuf <- Some buf; - t.opos <- 0; - buf - - (* Queue the active write buffer onto the write queue, resizing the - * view if necessary to the correct size. *) - let queue_obuf t = - match t.obuf with - |None -> () - |Some buf when Cstruct.len buf = t.opos -> (* obuf is full *) - t.obufq <- buf :: t.obufq; - t.obuf <- None - |Some _ when t.opos = 0 -> (* obuf wasnt ever used, so discard *) - t.obuf <- None - |Some buf -> (* partially filled obuf, so resize *) - let buf = Cstruct.sub buf 0 t.opos in - t.obufq <- buf :: t.obufq; - t.obuf <- None - - (* Get an active output buffer, which will allocate it if needed. - * The position to write into is stored in t.opos *) - let get_obuf t = - match t.obuf with - |None -> alloc_obuf t - |Some buf when Cstruct.len buf = t.opos -> queue_obuf t; alloc_obuf t - |Some buf -> buf - - (* Non-blocking character write, since Io page allocation never blocks. - * That may change in the future... *) - let write_char t ch = - let buf = get_obuf t in - Cstruct.set_char buf t.opos ch; - t.opos <- t.opos + 1 - - (* This is zero copy; flush current IO page and queue up the incoming - * buffer directly. *) - let write_buffer t buf = - queue_obuf t; - t.obufq <- buf :: t.obufq - - let rec write_string t s off len = - let buf = get_obuf t in - let avail = Cstruct.len buf - t.opos in - if avail < len then begin - Cstruct.blit_from_string s off buf t.opos avail; - t.opos <- t.opos + avail; - write_string t s (off+avail) (len-avail) - end else begin - Cstruct.blit_from_string s off buf t.opos len; - t.opos <- t.opos + len - end - - let write_line t buf = - write_string t buf 0 (String.length buf); - write_char t '\n' - - let flush t = - queue_obuf t; - let l = List.rev t.obufq in - t.obufq <- []; - Flow.writev t.flow l >>= function - | `Ok () -> Lwt.return_unit - | `Error e -> fail (Write_error e) - | `Eof -> fail End_of_file - - let close t = - Lwt.finalize (fun () -> flush t) (fun () -> Flow.close t.flow) - -end diff --git a/channel/channel.mldylib b/channel/channel.mldylib deleted file mode 100644 index 1fa4c8cb7..000000000 --- a/channel/channel.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 781dc97dc62331eec3ea9ec4373a3ca8) -Channel -# OASIS_STOP diff --git a/channel/channel.mli b/channel/channel.mli deleted file mode 100644 index 3f4f1fbab..000000000 --- a/channel/channel.mli +++ /dev/null @@ -1,21 +0,0 @@ -(* - * Copyright (c) 2011-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. - *) - -module Make(F:V1_LWT.FLOW) : sig - include V1_LWT.CHANNEL with type flow = F.flow - exception Read_error of F.error - exception Write_error of F.error -end diff --git a/channel/channel.mllib b/channel/channel.mllib deleted file mode 100644 index 1fa4c8cb7..000000000 --- a/channel/channel.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 781dc97dc62331eec3ea9ec4373a3ca8) -Channel -# OASIS_STOP diff --git a/dhcp/dhcp_clientv4.ml b/dhcp/dhcp_clientv4.ml index c41834fec..701810f1d 100644 --- a/dhcp/dhcp_clientv4.ml +++ b/dhcp/dhcp_clientv4.ml @@ -15,7 +15,7 @@ * *) -open Lwt +open Lwt.Infix open Printf module Make (Console : V1_LWT.CONSOLE) @@ -182,9 +182,9 @@ module Make (Console : V1_LWT.CONSOLE) end |_ -> Console.log_s t.c "DHCP: ack not for us" end - | Shutting_down -> return_unit - | Lease_held _ -> Console.log_s t.c "DHCP input: lease already held" - | Disabled -> Console.log_s t.c "DHCP input: disabled" + | Shutting_down -> Lwt.return_unit + | Lease_held _ -> Console.log_s t.c "DHCP input: lease already held" + | Disabled -> Console.log_s t.c "DHCP input: disabled" (* Start a DHCP discovery off on an interface *) let start_discovery t = @@ -201,7 +201,7 @@ module Make (Console : V1_LWT.CONSOLE) >>= fun () -> t.state <- Request_sent xid; output_broadcast t ~xid ~yiaddr ~siaddr ~options >>= fun () -> - return_unit + Lwt.return_unit (* DHCP state thred *) let rec dhcp_thread t = @@ -234,7 +234,7 @@ module Make (Console : V1_LWT.CONSOLE) (String.concat ", " (List.map Ipaddr.V4.to_string info.gateways))) >>= fun () -> offer_push (Some info); - return_unit + Lwt.return_unit in let t = { c; mac; udp; state; new_offer } in (* TODO cancellation *) diff --git a/lib/META b/lib/META index 149ec904f..f8e0c7ce9 100644 --- a/lib/META +++ b/lib/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 8744f03c92c9b635c7a66256a0357ddf) -version = "2.4.3" +# DO NOT EDIT (digest: 06d8e8b17cbfae174a9767c2a28f3f58) +version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "io-page mirage-types ipaddr cstruct mirage-profile bytes" archive(byte) = "tcpip.cma" @@ -10,7 +10,7 @@ archive(native, plugin) = "tcpip.cmxs" xen_linkopts = "-ltcpip_xen_stubs" exists_if = "tcpip.cma" package "xen" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" archive(byte) = "tcpip_xen.cma" archive(byte, plugin) = "tcpip_xen.cma" @@ -20,7 +20,7 @@ package "xen" ( ) package "udpv6-unix" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "tcpip.udp tcpip.ipv6-unix lwt lwt.unix ipaddr.unix cstruct.lwt io-page.unix" @@ -32,7 +32,7 @@ package "udpv6-unix" ( ) package "udpv6-socket" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "tcpip.udp lwt lwt.unix ipaddr.unix cstruct.lwt io-page.unix" archive(byte) = "udpv6-socket.cma" @@ -43,7 +43,7 @@ package "udpv6-socket" ( ) package "udpv4-unix" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "tcpip.udp tcpip.ipv4-unix lwt lwt.unix ipaddr.unix cstruct.lwt io-page.unix" @@ -55,7 +55,7 @@ package "udpv4-unix" ( ) package "udpv4-socket" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "tcpip.udp lwt lwt.unix ipaddr.unix cstruct.lwt io-page.unix" archive(byte) = "udpv4-socket.cma" @@ -66,7 +66,7 @@ package "udpv4-socket" ( ) package "udp" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "io-page mirage-types ipaddr cstruct lwt tcpip" archive(byte) = "udp.cma" @@ -77,10 +77,10 @@ package "udp" ( ) package "tcpv6-unix" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = - "tcpip.tcp tcpip.ipv6-unix tcpip.channel lwt lwt.unix mirage-unix mirage-clock-unix ipaddr.unix cstruct.lwt io-page.unix" + "tcpip.tcp tcpip.ipv6-unix channel lwt lwt.unix mirage-unix mirage-clock-unix ipaddr.unix cstruct.lwt io-page.unix" archive(byte) = "tcpv6-unix.cma" archive(byte, plugin) = "tcpv6-unix.cma" archive(native) = "tcpv6-unix.cmxa" @@ -89,7 +89,7 @@ package "tcpv6-unix" ( ) package "tcpv6-socket" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "lwt lwt.unix ipaddr.unix cstruct.lwt io-page.unix" archive(byte) = "tcpv6-socket.cma" @@ -100,10 +100,10 @@ package "tcpv6-socket" ( ) package "tcpv4-unix" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = - "tcpip.tcp tcpip.ipv4-unix tcpip.channel lwt lwt.unix mirage-unix mirage-clock-unix ipaddr.unix cstruct.lwt io-page.unix" + "tcpip.tcp tcpip.ipv4-unix channel lwt lwt.unix mirage-unix mirage-clock-unix ipaddr.unix cstruct.lwt io-page.unix" archive(byte) = "tcpv4-unix.cma" archive(byte, plugin) = "tcpv4-unix.cma" archive(native) = "tcpv4-unix.cmxa" @@ -112,7 +112,7 @@ package "tcpv4-unix" ( ) package "tcpv4-socket" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "lwt lwt.unix ipaddr.unix cstruct.lwt io-page.unix" archive(byte) = "tcpv4-socket.cma" @@ -123,10 +123,10 @@ package "tcpv4-socket" ( ) package "tcp" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = - "io-page mirage-types ipaddr cstruct lwt tcpip tcpip.ipv4 tcpip.ipv6" + "io-page mirage-types ipaddr cstruct lwt tcpip tcpip.ipv4 tcpip.ipv6 mirage-profile" archive(byte) = "tcp.cma" archive(byte, plugin) = "tcp.cma" archive(native) = "tcp.cmxa" @@ -135,7 +135,7 @@ package "tcp" ( ) package "stack-unix" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "tcpip.udpv4-unix tcpip.tcpv4-unix tcpip.udpv6-unix tcpip.tcpv6-unix tcpip.stack-direct lwt lwt.unix ipaddr.unix mirage-unix mirage-clock-unix mirage-console.unix mirage-types.lwt io-page.unix" @@ -147,7 +147,7 @@ package "stack-unix" ( ) package "stack-socket" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "tcpip.udpv4-socket tcpip.udpv6-socket tcpip.tcpv4-socket tcpip.tcpv6-socket lwt lwt.unix ipaddr.unix io-page.unix" @@ -159,10 +159,10 @@ package "stack-socket" ( ) package "stack-direct" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = - "io-page mirage-types ipaddr cstruct lwt tcpip.ethif tcpip.udp tcpip.tcp tcpip.dhcpv4" + "io-page mirage-types ipaddr cstruct lwt tcpip.ethif tcpip.arpv4 tcpip.udp tcpip.tcp tcpip.dhcpv4" archive(byte) = "tcpip-stack-direct.cma" archive(byte, plugin) = "tcpip-stack-direct.cma" archive(native) = "tcpip-stack-direct.cmxa" @@ -171,7 +171,7 @@ package "stack-direct" ( ) package "ipv6-unix" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "tcpip.ethif-unix tcpip.ipv6 lwt lwt.unix" archive(byte) = "ipv6-unix.cma" @@ -182,7 +182,7 @@ package "ipv6-unix" ( ) package "ipv6" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "io-page mirage-types ipaddr cstruct lwt tcpip" archive(byte) = "ipv6.cma" @@ -193,7 +193,7 @@ package "ipv6" ( ) package "ipv4-unix" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "tcpip.ethif-unix tcpip.ipv4 lwt lwt.unix" archive(byte) = "ipv4-unix.cma" @@ -204,7 +204,7 @@ package "ipv4-unix" ( ) package "ipv4" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "io-page mirage-types ipaddr cstruct lwt tcpip" archive(byte) = "ipv4.cma" @@ -215,7 +215,7 @@ package "ipv4" ( ) package "ethif-unix" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "tcpip.ethif mirage-net-unix lwt lwt.unix" archive(byte) = "ethif-unix.cma" @@ -226,7 +226,7 @@ package "ethif-unix" ( ) package "ethif" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "tcpip io-page mirage-types ipaddr cstruct lwt" archive(byte) = "ethif.cma" @@ -237,7 +237,7 @@ package "ethif" ( ) package "dhcpv4" ( - version = "2.4.3" + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" requires = "io-page bytes mirage-types ipaddr cstruct lwt tcpip.udp" archive(byte) = "dhcpv4.cma" @@ -247,15 +247,26 @@ package "dhcpv4" ( exists_if = "dhcpv4.cma" ) -package "channel" ( - version = "2.4.3" +package "arpv4-unix" ( + version = "2.6.1" description = "Ethernet, TCP/IPv4 and DHCPv4 library" - requires = "io-page mirage-types ipaddr cstruct lwt" - archive(byte) = "channel.cma" - archive(byte, plugin) = "channel.cma" - archive(native) = "channel.cmxa" - archive(native, plugin) = "channel.cmxs" - exists_if = "channel.cma" + requires = "tcpip.ethif mirage-net-unix lwt lwt.unix" + archive(byte) = "arpv4-unix.cma" + archive(byte, plugin) = "arpv4-unix.cma" + archive(native) = "arpv4-unix.cmxa" + archive(native, plugin) = "arpv4-unix.cmxs" + exists_if = "arpv4-unix.cma" +) + +package "arpv4" ( + version = "2.6.1" + description = "Ethernet, TCP/IPv4 and DHCPv4 library" + requires = "tcpip io-page mirage-types ipaddr cstruct lwt cstruct.syntax" + archive(byte) = "arpv4.cma" + archive(byte, plugin) = "arpv4.cma" + archive(native) = "arpv4.cmxa" + archive(native, plugin) = "arpv4.cmxs" + exists_if = "arpv4.cma" ) # OASIS_STOP diff --git a/lib/arpv4.ml b/lib/arpv4.ml index c4def96c0..85b4e02d1 100644 --- a/lib/arpv4.ml +++ b/lib/arpv4.ml @@ -15,7 +15,7 @@ * *) -open Lwt +open Lwt.Infix open Printf module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = struct @@ -28,8 +28,6 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str tpa: Ipaddr.V4.t; } - (* TODO implement the full ARP state machine (pending, failed, timer thread, etc) *) - type result = [ `Ok of Macaddr.t | `Timeout ] type entry = @@ -42,25 +40,14 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str mutable bound_ips: Ipaddr.V4.t list; } - cstruct arp { - uint8_t dst[6]; - uint8_t src[6]; - uint16_t ethertype; - uint16_t htype; - uint16_t ptype; - uint8_t hlen; - uint8_t plen; - uint16_t op; - uint8_t sha[6]; - uint32_t spa; - uint8_t tha[6]; - uint32_t tpa - } as big_endian - - cenum op { - Op_request = 1; - Op_reply - } as uint16_t + type 'a io = 'a Lwt.t + type buffer = Cstruct.t + type ipaddr = Ipaddr.V4.t + type macaddr = Macaddr.t + type ethif = Ethif.t + type repr = string + type id = t + type error let arp_timeout = 60. (* age entries out of cache after this many seconds *) let probe_repeat_delay = 1.5 (* per rfc5227, 2s >= probe_repeat_delay >= 1s *) @@ -77,17 +64,18 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str List.iter (Hashtbl.remove t.cache) expired; Time.sleep arp_timeout >>= tick t - (* Prettyprint cache contents *) - let prettyprint t = - printf "ARP info:\n"; - Hashtbl.iter (fun ip entry -> - printf "%s -> %s\n%!" - (Ipaddr.V4.to_string ip) - (match entry with - | Pending _ -> "I" - | Confirmed (_, mac) -> sprintf "V(%s)" (Macaddr.to_string mac) - ) - ) t.cache + let to_repr t = + let print ip entry acc = + let key = Ipaddr.V4.to_string ip in + match entry with + | Pending _ -> acc ^ "\n" ^ key ^ " -> " ^ "Pending" + | Confirmed (time, mac) -> Printf.sprintf "%s\n%s -> Confirmed (%s) (expires %f)\n%!" + acc key (Macaddr.to_string mac) time + in + Lwt.return (Hashtbl.fold print t.cache "") + + let pp fmt repr = + Format.fprintf fmt "%s" repr let notify t ip mac = let now = Clock.time () in @@ -105,6 +93,7 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str (* Input handler for an ARP packet, registered through attach() *) let rec input t frame = + let open Arpv4_wire in MProf.Trace.label "arpv4.input"; match get_arp_op frame with |1 -> (* Request *) @@ -120,7 +109,7 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str let spa = Ipaddr.V4.of_int32 (get_arp_tpa frame) in (* the requested address *) let tpa = Ipaddr.V4.of_int32 (get_arp_spa frame) in (* the requesting host IPv4 *) output t { op=`Reply; sha; tha; spa; tpa } - end else return_unit + end else Lwt.return_unit |2 -> (* Reply *) let spa = Ipaddr.V4.of_int32 (get_arp_spa frame) in let sha = Macaddr.of_bytes_exn (copy_arp_sha frame) in @@ -128,12 +117,13 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str (Ipaddr.V4.to_string spa) (Macaddr.to_string sha); (* If we have pending entry, notify the waiters that answer is ready *) notify t spa sha; - return_unit + Lwt.return_unit |n -> printf "ARP: Unknown message %d ignored\n%!" n; - return_unit + Lwt.return_unit and output t arp = + let open Arpv4_wire in (* Obtain a buffer to write into *) let buf = Io_page.to_cstruct (Io_page.get 1) in (* Write the ARP packet *) @@ -147,20 +137,21 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str |`Reply -> 2 |`Unknown n -> n in - set_arp_dst dmac 0 buf; - set_arp_src smac 0 buf; - set_arp_ethertype buf 0x0806; (* ARP *) - set_arp_htype buf 1; - set_arp_ptype buf 0x0800; (* IPv4 *) - set_arp_hlen buf 6; (* ethernet mac size *) - set_arp_plen buf 4; (* ipv4 size *) - set_arp_op buf op; - set_arp_sha smac 0 buf; - set_arp_spa buf spa; - set_arp_tha dmac 0 buf; - set_arp_tpa buf tpa; + Wire_structs.set_ethernet_dst dmac 0 buf; + Wire_structs.set_ethernet_src smac 0 buf; + Wire_structs.set_ethernet_ethertype buf 0x0806; (* ARP *) + let arpbuf = Cstruct.shift buf 14 in + set_arp_htype arpbuf 1; + set_arp_ptype arpbuf 0x0800; (* IPv4 *) + set_arp_hlen arpbuf 6; (* ethernet mac size *) + set_arp_plen arpbuf 4; (* ipv4 size *) + set_arp_op arpbuf op; + set_arp_sha smac 0 arpbuf; + set_arp_spa arpbuf spa; + set_arp_tha dmac 0 arpbuf; + set_arp_tpa arpbuf tpa; (* Resize buffer to sizeof arp packet *) - let buf = Cstruct.sub buf 0 sizeof_arp in + let buf = Cstruct.sub buf 0 (sizeof_arp + Wire_structs.sizeof_ethernet) in Ethif.write t.ethif buf (* Send a gratuitous ARP for our IP addresses *) @@ -193,12 +184,12 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str let add_ip t ip = if not (List.mem ip t.bound_ips) then set_ips t (ip :: t.bound_ips) - else return_unit + else Lwt.return_unit let remove_ip t ip = if List.mem ip t.bound_ips then set_ips t (List.filter ((<>) ip) t.bound_ips) - else return_unit + else Lwt.return_unit (* Query the cache for an ARP entry, which may result in the sender sleeping waiting for a response *) @@ -233,10 +224,12 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str Lwt.async (retry 0); response - let create ethif = + let connect ethif = let cache = Hashtbl.create 7 in let bound_ips = [] in let t = { ethif; cache; bound_ips } in Lwt.async (tick t); - t + Lwt.return (`Ok t) + + let disconnect t = Lwt.return_unit (* TODO: should kill tick *) end diff --git a/lib/arpv4.mldylib b/lib/arpv4.mldylib new file mode 100644 index 000000000..9cccefe08 --- /dev/null +++ b/lib/arpv4.mldylib @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: 5194760ef3cd01243f8b4b4dc5e5d3b9) +Arpv4 +Arpv4_wire +# OASIS_STOP diff --git a/lib/arpv4.mli b/lib/arpv4.mli index a2d862e7a..602eac32b 100644 --- a/lib/arpv4.mli +++ b/lib/arpv4.mli @@ -15,45 +15,11 @@ * *) -(** INTERNAL: ARP protocol. *) - module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) : sig + include V1_LWT.ARP - (** Type of an ARP record. ARP records are included in Ethif.t - values. They contain, among other bits, a list of bound IPs, and a - IPv4 -> MAC hashtbl. *) - type t - - (** [create ~get_etherbuf ~output ~get_mac] creates a value of type - [t]. *) - val create: Ethif.t -> t - - (** [set_ips arp] sets the bound IP address list, which will xmit a - GARP packet also. *) - val set_ips: t -> Ipaddr.V4.t list -> unit Lwt.t - - (** [get_ips arp] gets the bound IP address list in the [arp] - value. *) - val get_ips: t -> Ipaddr.V4.t list - - (** [add_ip arp ip] adds [ip] to the bound IP address list in the - [arp] value, which will xmit a GARP packet also. *) - val add_ip: t -> Ipaddr.V4.t -> unit Lwt.t - - (** [remove_ip arp ip] removes [ip] to the bound IP address list in - the [arp] value, which will xmit a GARP packet also. *) - val remove_ip: t -> Ipaddr.V4.t -> unit Lwt.t - - (** [input arp frame] will handle an ethernet frame containing an ARP - packet. If it is a response, it will update its cache, otherwise - will try to satisfy the request. *) - val input: t -> Cstruct.t -> unit Lwt.t - - (** [query arp ip] queries the cache in [arp] for an ARP entry - corresponding to [ip], which may result in the sender sleeping - waiting for a response. *) - val query: t -> Ipaddr.V4.t -> [ `Ok of Macaddr.t | `Timeout ] Lwt.t + type ethif = Ethif.t - (** Prettyprint cache contents *) - val prettyprint: t -> unit + (** [connect] creates a value of type [t]. *) + val connect : ethif -> [> `Ok of t | `Error of error ] Lwt.t end diff --git a/lib/arpv4.mllib b/lib/arpv4.mllib new file mode 100644 index 000000000..9cccefe08 --- /dev/null +++ b/lib/arpv4.mllib @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: 5194760ef3cd01243f8b4b4dc5e5d3b9) +Arpv4 +Arpv4_wire +# OASIS_STOP diff --git a/lib/arpv4_wire.ml b/lib/arpv4_wire.ml new file mode 100644 index 000000000..f32122eeb --- /dev/null +++ b/lib/arpv4_wire.ml @@ -0,0 +1,16 @@ +cstruct arp { + uint16_t htype; + uint16_t ptype; + uint8_t hlen; + uint8_t plen; + uint16_t op; + uint8_t sha[6]; + uint32_t spa; + uint8_t tha[6]; + uint32_t tpa +} as big_endian + +cenum op { + Op_request = 1; + Op_reply +} as uint16_t diff --git a/lib/ethif.ml b/lib/ethif.ml index 0aba469cf..d3d6467d3 100644 --- a/lib/ethif.ml +++ b/lib/ethif.ml @@ -15,13 +15,12 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. * *) -open Lwt +open Lwt.Infix module Make(Netif : V1_LWT.NETWORK) = struct type 'a io = 'a Lwt.t type buffer = Cstruct.t - type ipv4addr = Ipaddr.V4.t type macaddr = Macaddr.t type netif = Netif.t @@ -40,27 +39,19 @@ module Make(Netif : V1_LWT.NETWORK) = struct let input ~arpv4 ~ipv4 ~ipv6 t frame = MProf.Trace.label "ethif.input"; - let frame_mac = Macaddr.of_bytes (Wire_structs.copy_ethernet_dst frame) in - match frame_mac with - | None -> return_unit - | Some frame_mac -> begin - if (((Macaddr.compare frame_mac (mac t)) == 0) || (not (Macaddr.is_unicast frame_mac))) then - match Wire_structs.get_ethernet_ethertype frame with - | 0x0806 -> - arpv4 frame (* ARP *) - | 0x0800 -> (* IPv4 *) - let payload = Cstruct.shift frame Wire_structs.sizeof_ethernet in - ipv4 payload - | 0x86dd -> - let payload = Cstruct.shift frame Wire_structs.sizeof_ethernet in - ipv6 payload - | _etype -> - let _payload = Cstruct.shift frame Wire_structs.sizeof_ethernet in - (* TODO default etype payload *) - return_unit - else - return_unit + let of_interest dest = + Macaddr.compare dest (mac t) = 0 || not (Macaddr.is_unicast dest) + in + match Wire_structs.parse_ethernet_frame frame with + | Some (typ, destination, payload) when of_interest destination -> + begin + match typ with + | Some Wire_structs.ARP -> arpv4 payload + | Some Wire_structs.IPv4 -> ipv4 payload + | Some Wire_structs.IPv6 -> ipv6 payload + | None -> Lwt.return_unit (* TODO: default ethertype payload handler *) end + | _ -> Lwt.return_unit let write t frame = MProf.Trace.label "ethif.write"; @@ -72,7 +63,7 @@ module Make(Netif : V1_LWT.NETWORK) = struct let connect netif = MProf.Trace.label "ethif.connect"; - return (`Ok { netif }) + Lwt.return (`Ok { netif }) - let disconnect _ = return_unit + let disconnect _ = Lwt.return_unit end diff --git a/lib/ipv4.ml b/lib/ipv4.ml index 8e39652aa..113425138 100644 --- a/lib/ipv4.ml +++ b/lib/ipv4.ml @@ -14,12 +14,10 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt +open Lwt.Infix open Printf -module Make(Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = struct - - module Arpv4 = Arpv4.Make (Ethif) (Clock) (Time) +module Make(Ethif: V1_LWT.ETHIF) (Arpv4 : V1_LWT.ARP) = struct (** IO operation errors *) type error = [ @@ -36,7 +34,7 @@ module Make(Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = stru type macaddr = Ethif.macaddr type t = { - ethif: Ethif.t; + ethif : Ethif.t; arp : Arpv4.t; mutable ip: Ipaddr.V4.t; mutable netmask: Ipaddr.V4.t; @@ -71,14 +69,14 @@ module Make(Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = stru let destination_mac t = function |ip when ip = Ipaddr.V4.broadcast || ip = Ipaddr.V4.any -> (* Broadcast *) - return Macaddr.broadcast + Lwt.return Macaddr.broadcast |ip when is_local t ip -> (* Local *) Arpv4.query t.arp ip >>= begin function | `Ok mac -> Lwt.return mac | `Timeout -> Lwt.fail (No_route_to_destination_address ip) end |ip when Ipaddr.V4.is_multicast ip -> - return (mac_of_multicast ip) + Lwt.return (mac_of_multicast ip) |ip -> begin (* Gateway *) match t.gateways with |hd::_ -> @@ -86,11 +84,11 @@ module Make(Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = stru | `Ok mac -> Lwt.return mac | `Timeout -> printf "IP.output: arp timeout to gw %s\n%!" (Ipaddr.V4.to_string ip); - fail (No_route_to_destination_address ip) + Lwt.fail (No_route_to_destination_address ip) end |[] -> printf "IP.output: no route to %s\n%!" (Ipaddr.V4.to_string ip); - fail (No_route_to_destination_address ip) + Lwt.fail (No_route_to_destination_address ip) end end @@ -155,13 +153,14 @@ module Make(Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = stru | 15 -> "Precedence cutoff in effect" | code -> Printf.sprintf "Unknown code: %d" code in printf "ICMP Destination Unreachable: %s\n%!" descr; - return () + Lwt.return_unit let icmp_input t src _hdr buf = MProf.Trace.label "icmp_input"; match Wire_structs.Ipv4_wire.get_icmpv4_ty buf with |0 -> (* echo reply *) - return (printf "ICMP: discarding echo reply\n%!") + printf "ICMP: discarding echo reply\n%!"; + Lwt.return_unit |3 -> icmp_dst_unreachable buf |8 -> (* echo request *) (* convert the echo request into an echo reply *) @@ -177,7 +176,7 @@ module Make(Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = stru write t frame buf |ty -> printf "ICMP unknown ty %d\n" ty; - return_unit + Lwt.return_unit let input t ~tcp ~udp ~default buf = (* buf pointers to start of IPv4 header here *) @@ -187,23 +186,24 @@ module Make(Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = stru let payload_len = Wire_structs.Ipv4_wire.get_ipv4_len buf - ihl in let hdr, data = Cstruct.split buf ihl in if Cstruct.len data >= payload_len then begin + (* Strip trailing bytes. See: https://github.com/mirage/mirage-net-xen/issues/24 *) + let data = Cstruct.sub data 0 payload_len in let proto = Wire_structs.Ipv4_wire.get_ipv4_proto buf in match Wire_structs.Ipv4_wire.int_to_protocol proto with | Some `ICMP -> icmp_input t src hdr data | Some `TCP -> tcp ~src ~dst data | Some `UDP -> udp ~src ~dst data | None -> default ~proto ~src ~dst data - end else return_unit + end else Lwt.return_unit - let connect ethif = - let ip = Ipaddr.V4.any in - let netmask = Ipaddr.V4.any in - let gateways = [] in - let arp = Arpv4.create ethif in + let connect + ?(ip=Ipaddr.V4.any) + ?(netmask=Ipaddr.V4.any) + ?(gateways=[]) ethif arp = let t = { ethif; arp; ip; netmask; gateways } in - return (`Ok t) + Lwt.return (`Ok t) - let disconnect _ = return_unit + let disconnect _ = Lwt.return_unit let set_ip t ip = t.ip <- ip; @@ -214,13 +214,13 @@ module Make(Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = stru let set_ip_netmask t netmask = t.netmask <- netmask; - return_unit + Lwt.return_unit let get_ip_netmasks t = [t.netmask] let set_ip_gateways t gateways = t.gateways <- gateways; - return_unit + Lwt.return_unit let get_ip_gateways { gateways; _ } = gateways diff --git a/lib/ipv4.mldylib b/lib/ipv4.mldylib index 150c6ee26..8b8001fd7 100644 --- a/lib/ipv4.mldylib +++ b/lib/ipv4.mldylib @@ -1,5 +1,4 @@ # OASIS_START -# DO NOT EDIT (digest: cb71e7ddbe984c8104a4a6c58420a5a6) +# DO NOT EDIT (digest: e53211788365c0a2b1be74b682c19983) Ipv4 -Arpv4 # OASIS_STOP diff --git a/lib/ipv4.mli b/lib/ipv4.mli index b475923b3..ab4ddfb44 100644 --- a/lib/ipv4.mli +++ b/lib/ipv4.mli @@ -14,7 +14,21 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -module Make ( N:V1_LWT.ETHIF ) ( C:V1.CLOCK ) ( T:V1_LWT.TIME ) : sig +module Make (N:V1_LWT.ETHIF) (A: V1_LWT.ARP) : sig + module Routing : sig + (* this exception can be thrown by `write` or `writev` when the destination + IP address's link-layer address can't be found by ARP *) + exception No_route_to_destination_address of Ipaddr.V4.t + end include V1_LWT.IPV4 with type ethif = N.t - val connect : ethif -> [> `Ok of t | `Error of error ] Lwt.t + val connect : + ?ip:Ipaddr.V4.t -> + ?netmask:Ipaddr.V4.t -> + ?gateways:Ipaddr.V4.t list -> + ethif -> A.t -> [> `Ok of t | `Error of error ] Lwt.t + (** Connect to an ipv4 device. + Default ip is {!Ipaddr.V4.any} + Default netmask is {!Ipaddr.V4.any} + Default gateways are [[]]. *) + end diff --git a/lib/ipv4.mllib b/lib/ipv4.mllib index 150c6ee26..8b8001fd7 100644 --- a/lib/ipv4.mllib +++ b/lib/ipv4.mllib @@ -1,5 +1,4 @@ # OASIS_START -# DO NOT EDIT (digest: cb71e7ddbe984c8104a4a6c58420a5a6) +# DO NOT EDIT (digest: e53211788365c0a2b1be74b682c19983) Ipv4 -Arpv4 # OASIS_STOP diff --git a/lib/ipv6.ml b/lib/ipv6.ml index ba4f1180d..8b9e87625 100644 --- a/lib/ipv6.ml +++ b/lib/ipv6.ml @@ -887,8 +887,7 @@ let add_routers ~now state ips = let get_routers state = RouterList.to_list state.router_list -let (>>=) = Lwt.(>>=) -let (>|=) = Lwt.(>|=) +open Lwt.Infix module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) = struct type ethif = E.t @@ -947,13 +946,6 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) = struct | `Udp (src, dst, pkt) -> udp ~src ~dst pkt | `Default (proto, src, dst, pkt) -> default ~proto ~src ~dst pkt - let connect ethif = - Printf.printf "IP6: Starting\n%!"; - let now = C.time () in - let state, acts = create ~now (E.mac ethif) in - let t = {state; ethif} in - run t acts >>= fun () -> - Lwt.return (`Ok t) let disconnect _ = (* TODO *) Lwt.return_unit @@ -994,4 +986,19 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) = struct let to_uipaddr ip = I.V6 ip let of_uipaddr ip = Some (I.to_v6 ip) + let (>>=?) (x,f) g = match x with + | Some x -> f x >>= g + | None -> g () + + let connect ?ip ?netmask ?gateways ethif = + Printf.printf "IP6: Starting\n%!"; + let now = C.time () in + let state, acts = create ~now (E.mac ethif) in + let t = {state; ethif} in + run t acts >>= fun () -> + (ip, set_ip t) >>=? fun () -> + (netmask, Lwt_list.iter_s (set_ip_netmask t)) >>=? fun () -> + (gateways, set_ip_gateways t) >>=? fun () -> + Lwt.return (`Ok t) + end diff --git a/lib/ipv6.mli b/lib/ipv6.mli index 28d305a50..13f7c0003 100644 --- a/lib/ipv6.mli +++ b/lib/ipv6.mli @@ -16,5 +16,9 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) : sig include V1_LWT.IPV6 with type ethif = E.t - val connect : ethif -> [> `Ok of t | `Error of error ] Lwt.t + val connect : + ?ip:Ipaddr.V6.t -> + ?netmask:Ipaddr.V6.Prefix.t list -> + ?gateways:Ipaddr.V6.t list -> + ethif -> [> `Ok of t | `Error of error ] Lwt.t end diff --git a/lib/tcpip_stack_direct.ml b/lib/tcpip_stack_direct.ml index dd9d5e7d6..8e4ecbca4 100644 --- a/lib/tcpip_stack_direct.ml +++ b/lib/tcpip_stack_direct.ml @@ -14,7 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt +open Lwt.Infix type direct_ipv4_input = src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> Cstruct.t -> unit Lwt.t module type UDPV4_DIRECT = V1_LWT.UDPV4 @@ -29,6 +29,7 @@ module Make (Random : V1.RANDOM) (Netif : V1_LWT.NETWORK) (Ethif : V1_LWT.ETHIF with type netif = Netif.t) + (Arpv4 : V1_LWT.ARP) (Ipv4 : V1_LWT.IPV4 with type ethif = Ethif.t) (Udpv4 : UDPV4_DIRECT with type ip = Ipv4.t) (Tcpv4 : TCPV4_DIRECT with type ip = Ipv4.t) = @@ -41,6 +42,7 @@ struct type mode = V1_LWT.direct_stack_config type id = (console, netif, mode) config type buffer = Cstruct.t + type arpv4 = Arpv4.t type ipv4addr = Ipaddr.V4.t type tcpv4 = Tcpv4.t type udpv4 = Udpv4.t @@ -57,6 +59,7 @@ struct c : Console.t; netif : Netif.t; ethif : Ethif.t; + arpv4 : Arpv4.t; ipv4 : Ipv4.t; udpv4 : Udpv4.t; tcpv4 : Tcpv4.t; @@ -83,8 +86,8 @@ struct Ipv4.set_ip t.ipv4 info.Dhcp.ip_addr >>= fun () -> (match info.Dhcp.netmask with - |Some nm -> Ipv4.set_ip_netmask t.ipv4 nm - |None -> return_unit) + | Some nm -> Ipv4.set_ip_netmask t.ipv4 nm + | None -> Lwt.return_unit) >>= fun () -> Ipv4.set_ip_gateways t.ipv4 info.Dhcp.gateways >>= fun () -> @@ -128,25 +131,25 @@ struct let listen t = Netif.listen t.netif ( Ethif.input - ~arpv4:(Ipv4.input_arpv4 t.ipv4) + ~arpv4:(Arpv4.input t.arpv4) ~ipv4:( Ipv4.input ~tcp:(Tcpv4.input t.tcpv4 ~listeners:(tcpv4_listeners t)) ~udp:(Udpv4.input t.udpv4 ~listeners:(udpv4_listeners t)) - ~default:(fun ~proto:_ ~src:_ ~dst:_ _ -> return_unit) + ~default:(fun ~proto:_ ~src:_ ~dst:_ _ -> Lwt.return_unit) t.ipv4) - ~ipv6:(fun _ -> return_unit) + ~ipv6:(fun _ -> Lwt.return_unit) t.ethif) - let connect id ethif ipv4 udpv4 tcpv4 = + let connect id ethif arpv4 ipv4 udpv4 tcpv4 = let { V1_LWT.console = c; interface = netif; mode; _ } = id in Console.log_s c "Manager: connect" >>= fun () -> let udpv4_listeners = Hashtbl.create 7 in let tcpv4_listeners = Hashtbl.create 7 in - let t = { id; c; mode; netif; ethif; ipv4; tcpv4; udpv4; + let t = { id; c; mode; netif; ethif; arpv4; ipv4; tcpv4; udpv4; udpv4_listeners; tcpv4_listeners } in Console.log_s t.c "Manager: configuring" >>= fun () -> @@ -159,9 +162,8 @@ struct to spawn a background thread, but we need to consider how to inform the application stack that the IP address has changed (perhaps via a control Lwt_stream that the application can ignore if it doesn't care). *) - Console.log_s t.c "Manager: configuration done" - >>= fun () -> - return (`Ok t) + Console.log_s t.c "Manager: configuration done" >>= fun () -> + Lwt.return (`Ok t) let disconnect t = (* TODO: kill the listening thread *) diff --git a/lib/tcpip_stack_direct.mli b/lib/tcpip_stack_direct.mli index f203adeaf..90e809c6e 100644 --- a/lib/tcpip_stack_direct.mli +++ b/lib/tcpip_stack_direct.mli @@ -27,6 +27,7 @@ module Make (Random : V1.RANDOM) (Netif : V1_LWT.NETWORK) (Ethif : V1_LWT.ETHIF with type netif = Netif.t) + (Arpv4 : V1_LWT.ARP) (Ipv4 : V1_LWT.IPV4 with type ethif = Ethif.t) (Udpv4 : UDPV4_DIRECT with type ip = Ipv4.t) (Tcpv4 : TCPV4_DIRECT with type ip = Ipv4.t) : sig @@ -40,5 +41,5 @@ module Make and module TCPV4 = Tcpv4 and module UDPV4 = Udpv4 val connect : (console, netif, mode) V1_LWT.stackv4_config -> - Ethif.t -> Ipv4.t -> Udpv4.t -> Tcpv4.t -> [> `Ok of t | `Error of error ] Lwt.t + Ethif.t -> Arpv4.t -> Ipv4.t -> Udpv4.t -> Tcpv4.t -> [> `Ok of t | `Error of error ] Lwt.t end diff --git a/lib/udp.ml b/lib/udp.ml index 290cef68f..0675bd5d8 100644 --- a/lib/udp.ml +++ b/lib/udp.ml @@ -14,7 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt +open Lwt.Infix module Make(Ip: V1_LWT.IP) = struct @@ -44,15 +44,15 @@ module Make(Ip: V1_LWT.IP) = struct (Wire_structs.get_udp_length buf - Wire_structs.sizeof_udp) in match listeners ~dst_port with - | None -> return_unit + | None -> Lwt.return_unit | Some fn -> let src_port = Wire_structs.get_udp_source_port buf in fn ~src ~dst ~src_port data let writev ?source_port ~dest_ip ~dest_port t bufs = begin match source_port with - | None -> fail (Failure "TODO; random source port") - | Some p -> return p + | None -> Lwt.fail (Failure "TODO; random source port") + | Some p -> Lwt.return p end >>= fun source_port -> let frame, header_len = Ip.allocate_frame t.ip ~dst:dest_ip ~proto:`UDP in let frame = Cstruct.set_len frame (header_len + Wire_structs.sizeof_udp) in @@ -68,8 +68,7 @@ module Make(Ip: V1_LWT.IP) = struct let write ?source_port ~dest_ip ~dest_port t buf = writev ?source_port ~dest_ip ~dest_port t [buf] - let connect ip = - return (`Ok { ip }) + let connect ip = Lwt.return (`Ok { ip }) - let disconnect _ = return_unit + let disconnect _ = Lwt.return_unit end diff --git a/lib/wire_structs.ml b/lib/wire_structs.ml index f594e2164..0223e8911 100644 --- a/lib/wire_structs.ml +++ b/lib/wire_structs.ml @@ -4,6 +4,24 @@ cstruct ethernet { uint16_t ethertype } as big_endian +cenum ethertype { + ARP = 0x0806; + IPv4 = 0x0800; + IPv6 = 0x86dd; + } as uint16_t + +let parse_ethernet_frame frame = + if Cstruct.len frame >= 14 then + (* source + destination + type = 14 *) + let payload = Cstruct.shift frame sizeof_ethernet + and typ = get_ethernet_ethertype frame + and dst = Macaddr.of_bytes_exn (copy_ethernet_dst frame) + in + Some (int_to_ethertype typ, dst, payload) + else + None + + cstruct udp { uint16_t source_port; uint16_t dest_port; diff --git a/lib_test/common.ml b/lib_test/common.ml index 5551064f6..d5c59037a 100644 --- a/lib_test/common.ml +++ b/lib_test/common.ml @@ -1,16 +1,21 @@ -open Lwt - -let cmp a b = String.compare a b = 0 +let (>>=) = Lwt.(>>=) let fail fmt = Printf.ksprintf OUnit.assert_failure fmt -let expect msg expected actual = - (if not (cmp expected actual) then - fail "Expected '%s', got '%s': %s" expected actual msg) ; - Lwt.return_unit - let or_error name fn t = fn t >>= function | `Error e -> fail "or_error starting %s" name - | `Ok t -> return t + | `Ok t -> Lwt.return t + +let assert_string msg a b = + let cmp a b = String.compare a b = 0 in + OUnit.assert_equal ~msg ~printer:(fun x -> x) ~cmp a b + +let assert_cstruct msg a b = + OUnit.assert_equal ~msg ~printer:Cstruct.to_string ~cmp:Cstruct.equal a b + +let assert_bool msg a b = + OUnit.assert_equal ~msg ~printer:string_of_bool a b +let assert_int msg a b = + OUnit.assert_equal ~msg ~printer:string_of_int a b diff --git a/lib_test/test.ml b/lib_test/test.ml index 491b68b6e..26678607a 100644 --- a/lib_test/test.ml +++ b/lib_test/test.ml @@ -15,17 +15,27 @@ *) let suite = [ - "channel", Test_channel.suite ; - "connect", Test_connect.suite ; - "iperf", Test_iperf.suite ; + "arp" , Test_arp.suite ; + "connect", Test_connect.suite ; + "iperf" , Test_iperf.suite ; ] let run test () = Lwt_main.run (test ()) let () = + (* Enable TCP debug output *) + let open Tcp in + [Segment.info; Segment.debug; Pcb.info; Pcb.debug] |> List.iter (fun log -> + Log.enable log; + Log.set_stats log false + ); + (* Uncomment to enable tracing *) + (*let buffer = MProf_unix.mmap_buffer ~size:1000000 "trace.ctf" in + let trace_config = MProf.Trace.Control.make buffer MProf_unix.timestamper in + MProf.Trace.Control.start trace_config;*) let suite = List.map (fun (n, s) -> - n, List.map (fun (d, f) -> d, `Quick, run f) s + n, List.map (fun (d, s, f) -> d, s, run f) s ) suite in - Alcotest.run "irmin" suite + Alcotest.run "tcpip" suite diff --git a/lib_test/test_arp.ml b/lib_test/test_arp.ml new file mode 100644 index 000000000..cca3631b1 --- /dev/null +++ b/lib_test/test_arp.ml @@ -0,0 +1,519 @@ +open Lwt.Infix + +let time_reduction_factor = 60. + +module Fast_clock = struct + + let last_read = ref (Clock.time ()) + + (* from mirage/types/V1.mli module type CLOCK *) + type tm = + { tm_sec: int; (** Seconds 0..60 *) + tm_min: int; (** Minutes 0..59 *) + tm_hour: int; (** Hours 0..23 *) + tm_mday: int; (** Day of month 1..31 *) + tm_mon: int; (** Month of year 0..11 *) + tm_year: int; (** Year - 1900 *) + tm_wday: int; (** Day of week (Sunday is 0) *) + tm_yday: int; (** Day of year 0..365 *) + tm_isdst: bool; (** Daylight time savings in effect *) + } + + let gmtime time = + let tm = Clock.gmtime time in + { + tm_sec = tm.Clock.tm_sec; + tm_min = tm.Clock.tm_min; + tm_hour = tm.Clock.tm_hour; + tm_mday = tm.Clock.tm_mday; + tm_mon = tm.Clock.tm_mon; + tm_year = tm.Clock.tm_year; + tm_wday = tm.Clock.tm_wday; + tm_yday = tm.Clock.tm_yday; + tm_isdst = tm.Clock.tm_isdst; + } + + let time () = + let this_time = Clock.time () in + let clock_diff = ((this_time -. !last_read) *. time_reduction_factor) in + last_read := this_time; + this_time +. clock_diff + +end +module Fast_time = struct + type 'a io = 'a Lwt.t + let sleep time = OS.Time.sleep (time /. time_reduction_factor) +end + +module B = Basic_backend.Make +module V = Vnetif.Make(B) +module E = Ethif.Make(V) +module A = Arpv4.Make(E)(Fast_clock)(Fast_time) + +type arp_stack = { + backend : B.t; + netif: V.t; + ethif: E.t; + arp: A.t; +} + +(* TODO: this code should be in tcpip proper for common use *) +module Parse = struct + type arp = { + op: [ `Request |`Reply |`Unknown of int ]; + sha: Macaddr.t; + spa: Ipaddr.V4.t; + tha: Macaddr.t; + tpa: Ipaddr.V4.t; + } + let garp src_mac src_ip = + { op = `Reply; + sha = src_mac; + tha = Macaddr.broadcast; + spa = src_ip; + tpa = Ipaddr.V4.any; + } + + let cstruct_of_arp arp = + let open Arpv4_wire in + (* Obtain a buffer to write into *) + (* note that sizeof_arp includes sizeof_ethernet by what's currently in + arpv4_wire.ml *) + let buf = Cstruct.create (Arpv4_wire.sizeof_arp + Wire_structs.sizeof_ethernet) in + + (* Write the ARP packet *) + let dmac = Macaddr.to_bytes arp.tha in + let smac = Macaddr.to_bytes arp.sha in + let spa = Ipaddr.V4.to_int32 arp.spa in + let tpa = Ipaddr.V4.to_int32 arp.tpa in + let op = + match arp.op with + |`Request -> 1 + |`Reply -> 2 + |`Unknown n -> n + in + Wire_structs.set_ethernet_dst dmac 0 buf; + Wire_structs.set_ethernet_src smac 0 buf; + Wire_structs.set_ethernet_ethertype buf 0x0806; (* ARP *) + let arpbuf = Cstruct.shift buf 14 in + set_arp_htype arpbuf 1; + set_arp_ptype arpbuf 0x0800; (* IPv4 *) + set_arp_hlen arpbuf 6; (* ethernet mac size *) + set_arp_plen arpbuf 4; (* ipv4 size *) + set_arp_op arpbuf op; + set_arp_sha smac 0 arpbuf; + set_arp_spa arpbuf spa; + set_arp_tha dmac 0 arpbuf; + set_arp_tpa arpbuf tpa; + buf + + let arp_of_cstruct buf = + let open Arpv4_wire in + let buf = Cstruct.shift buf 14 in + let unusable buf = + (* we only know how to deal with ethernet <-> IPv4 *) + get_arp_htype buf <> 1 || get_arp_ptype buf <> 0x0800 + || get_arp_hlen buf <> 6 || get_arp_plen buf <> 4 + in + if (Cstruct.len buf) < sizeof_arp then `Too_short else begin + if (unusable buf) then `Unusable else begin + let op = match get_arp_op buf with + | 1 -> `Request + | 2 -> `Reply + | n -> `Unknown n + in + let src_mac = copy_arp_sha buf in + let target_mac = copy_arp_tha buf in + match (Macaddr.of_bytes src_mac, Macaddr.of_bytes target_mac) with + | None, Some _ -> `Bad_mac [ src_mac ] + | Some _, None -> `Bad_mac [ target_mac ] + | None, None -> `Bad_mac [ src_mac ; target_mac ] + | Some src_mac, Some target_mac -> + let src_ip = Ipaddr.V4.of_int32 (get_arp_spa buf) in + let target_ip = Ipaddr.V4.of_int32 (get_arp_tpa buf) in + `Ok { op; + sha = src_mac; spa = src_ip; + tha = target_mac; tpa = target_ip + } + end + end + let is_garp_for ip buf = match arp_of_cstruct buf with + | `Ok arp -> arp.op = `Reply && arp.tha = Macaddr.broadcast + | _ -> false + + let to_string arp = + let ip_str = Ipaddr.V4.to_string in + let mac_str = Macaddr.to_string in + let op = match arp.op with + | `Request -> "request" + | `Reply -> "reply" + | `Unknown n -> Printf.sprintf "unknown message type (%d)" n + in + Printf.sprintf "%s from mac %s (ip %s) to mac %s (ip %s)" + op (mac_str arp.sha) (ip_str arp.spa) (mac_str arp.tha) (ip_str arp.tpa) + +end + +let first_ip = Ipaddr.V4.of_string_exn "192.168.3.1" +let second_ip = Ipaddr.V4.of_string_exn "192.168.3.10" +let sample_mac = Macaddr.of_string_exn "10:9a:dd:c0:ff:ee" + +let or_error = Common.or_error +let equals = OUnit.assert_equal +let fail = OUnit.assert_failure + +let timeout ~time t = + let msg = "timed out" in + Lwt.pick [ t; OS.Time.sleep time >>= fun () -> fail msg; ] + +let check_response expected buf = + let printer buf = + match Parse.arp_of_cstruct buf with + | `Ok arp -> Parse.to_string arp + | `Unusable -> "Reasonable ARP message for a protocol we don't understand" + | `Bad_mac _ -> "Unparseable MAC in message" + | `Too_short -> "Too short to parse" + in + equals ~printer expected buf + +let fail_on_receipt netif buf = + fail "received traffic when none was expected" + +let single_check netif expected = + V.listen netif (fun buf -> check_response expected buf; V.disconnect netif) + +let arp_reply ~from_netif ~to_netif ~from_ip ~to_ip = + Parse.cstruct_of_arp + { Parse.op = `Reply; + sha = (V.mac from_netif); + tha = (V.mac to_netif); + spa = from_ip; + tpa = to_ip} + +let arp_request ~from_netif ~to_mac ~from_ip ~to_ip = + Parse.cstruct_of_arp + { Parse.op = `Request; + sha = (V.mac from_netif); + tha = to_mac; + spa = from_ip; + tpa = to_ip} + +let get_arp ?(backend = B.create ~use_async_readers:true + ~yield:(fun() -> Lwt_main.yield ()) ()) () = + or_error "backend" V.connect backend >>= fun netif -> + or_error "ethif" E.connect netif >>= fun ethif -> + or_error "arp" A.connect ethif >>= fun arp -> + Lwt.return { backend; netif; ethif; arp } + +(* we almost always want two stacks on the same backend *) +let two_arp () = + get_arp () >>= fun first -> + get_arp ~backend:first.backend () >>= fun second -> + Lwt.return (first, second) + +(* ...but sometimes we want three *) +let three_arp () = + get_arp () >>= fun first -> + get_arp ~backend:first.backend () >>= fun second -> + get_arp ~backend:first.backend () >>= fun third -> + Lwt.return (first, second, third) + +let query_or_die ~arp ~ip ~expected_mac = + A.query arp ip >>= function + | `Timeout -> + let pp_ip = Ipaddr.V4.to_string ip in + Format.printf "Timeout querying %s." pp_ip; + A.to_repr arp >>= fun repr -> + A.pp Format.std_formatter repr; + fail "ARP query failed when success was mandatory"; + Lwt.return_unit + | `Ok mac -> + equals ~printer:Macaddr.to_string expected_mac mac; + Lwt.return_unit + +let set_and_check listener claimant ip = + A.set_ips claimant.arp [ ip ] >>= fun () -> + query_or_die listener ip (V.mac claimant.netif) + +let start_arp_listener stack () = + let noop = (fun buf -> Lwt.return_unit) in + E.input ~arpv4:(A.input stack.arp) ~ipv4:noop ~ipv6:noop stack.ethif + +let output_then_disconnect ~speak:speak_netif ~disconnect:listen_netif bufs = + Lwt.join (List.map (V.write speak_netif) bufs) >>= fun () -> + Lwt_unix.sleep 0.1 >>= fun () -> + V.disconnect listen_netif + +let not_in_cache ~listen probe arp ip = + Lwt.pick [ + single_check listen probe; + OS.Time.sleep 0.1 >>= fun () -> + A.query arp ip >>= function + | `Ok mac -> fail "entry in cache when it shouldn't be" + | `Timeout -> Lwt.return_unit + ] + +let set_ip_sends_garp () = + two_arp () >>= fun (speak, listen) -> + let emit_garp = + OS.Time.sleep 0.1 >>= fun () -> + A.set_ips speak.arp [ first_ip ] >>= fun () -> + equals [ first_ip ] (A.get_ips speak.arp); + Lwt.return_unit + in + let expected_garp = Parse.(cstruct_of_arp (garp (V.mac speak.netif) first_ip)) in + timeout ~time:0.5 ( + Lwt.join [ + single_check listen.netif expected_garp; + emit_garp; + ]) >>= fun () -> + (* now make sure we have consistency when setting *) + A.set_ips speak.arp [] >>= fun () -> + equals [] (A.get_ips speak.arp); + A.set_ips speak.arp [ first_ip; second_ip ] >>= fun () -> + equals [ first_ip; second_ip ] (A.get_ips speak.arp); + Lwt.return_unit + +let add_get_remove_ips () = + get_arp () >>= fun stack -> + equals [] (A.get_ips stack.arp); + A.set_ips stack.arp [ first_ip; first_ip ] >>= fun () -> + let ips = A.get_ips stack.arp in + equals true (List.mem first_ip ips); + equals true (List.for_all (fun a -> a = first_ip) ips); + equals true (List.length ips >= 1 && List.length ips <= 2); + A.remove_ip stack.arp first_ip >>= fun () -> + equals [] (A.get_ips stack.arp); + A.remove_ip stack.arp first_ip >>= fun () -> + equals [] (A.get_ips stack.arp); + A.add_ip stack.arp first_ip >>= fun () -> + equals [ first_ip ] (A.get_ips stack.arp); + A.add_ip stack.arp first_ip >>= fun () -> + equals [ first_ip ] (A.get_ips stack.arp); + Lwt.return_unit + +let input_single_garp () = + two_arp () >>= fun (listen, speak) -> + (* set the IP on speak_arp, which should cause a GARP to be emitted which + listen_arp will hear and cache. *) + let one_and_done buf = + let arpbuf = Cstruct.shift buf 14 in + A.input listen.arp arpbuf >>= fun () -> + V.disconnect listen.netif + in + timeout ~time:0.5 ( + Lwt.join [ + V.listen listen.netif one_and_done; + OS.Time.sleep 0.1 >>= fun () -> + A.set_ips speak.arp [ first_ip ]; + ]) + >>= fun () -> + (* try a lookup of the IP set by speak.arp, and fail if this causes listen_arp + to block or send an ARP query -- listen_arp should answer immediately from + the cache. An attempt to resolve via query will result in a timeout, since + speak.arp has no listener running and therefore won't answer any arp + who-has requests. *) + timeout ~time:0.5 (query_or_die listen.arp first_ip (V.mac speak.netif)) + +let input_single_unicast () = + two_arp () >>= fun (listen, speak) -> + (* contrive to make a reply packet for the listener to hear *) + let for_listener = arp_reply + ~from_netif:speak.netif ~to_netif:listen.netif ~from_ip:first_ip ~to_ip:second_ip + in + let listener = start_arp_listener listen () in + timeout ~time:0.5 ( + Lwt.choose [ + V.listen listen.netif listener; + OS.Time.sleep 0.1 >>= fun () -> + V.write speak.netif for_listener >>= fun () -> + query_or_die listen.arp first_ip (V.mac speak.netif) + ]) + +let input_resolves_wait () = + two_arp () >>= fun (listen, speak) -> + (* contrive to make a reply packet for the listener to hear *) + let for_listener = arp_reply ~from_netif:speak.netif ~to_netif:listen.netif + ~from_ip:first_ip ~to_ip:second_ip in + (* initiate query when the cache is empty. On resolution, fail for a timeout + and test the MAC if resolution was successful, then disconnect the + listening interface to ensure the test terminates. + Fail with a timeout message if the whole thing takes more than 5s. *) + let listener = start_arp_listener listen () in + let query_then_disconnect = + query_or_die listen.arp first_ip (V.mac speak.netif) >>= fun () -> + V.disconnect listen.netif + in + timeout ~time:5.0 ( + Lwt.join [ + V.listen listen.netif listener; + query_then_disconnect; + OS.Time.sleep 0.1 >>= fun () -> E.write speak.ethif for_listener; + ] + ) + +let unreachable_times_out () = + get_arp () >>= fun speak -> + A.query speak.arp first_ip >>= function + | `Ok mac -> fail "query claimed success when impossible" + | `Timeout -> Lwt.return_unit + +let input_replaces_old () = + three_arp () >>= fun (listen, claimant_1, claimant_2) -> + let listener = start_arp_listener listen () in + timeout ~time:2.0 ( + Lwt.join [ + V.listen listen.netif listener; + OS.Time.sleep 0.1 >>= fun () -> + set_and_check listen.arp claimant_1 first_ip >>= fun () -> + set_and_check listen.arp claimant_2 first_ip >>= fun () -> + V.disconnect listen.netif + ]) + +let entries_expire () = + two_arp () >>= fun (listen, speak) -> + A.set_ips listen.arp [ second_ip ] >>= fun () -> + (* here's what we expect listener to emit once its cache entry has expired *) + let expected_arp_query = arp_request ~from_netif:listen.netif + ~to_mac:Macaddr.broadcast ~from_ip:second_ip ~to_ip:first_ip + in + Lwt.async (fun () -> + V.listen listen.netif (start_arp_listener listen ())); + let test = + OS.Time.sleep 0.1 >>= fun () -> + set_and_check listen.arp speak first_ip >>= fun () -> + OS.Time.sleep 1.0 >>= fun () -> + (* asking now should generate a query *) + not_in_cache ~listen:speak.netif expected_arp_query listen.arp first_ip; + in + timeout ~time:5.0 test + +(* RFC isn't strict on how many times to try, so we'll just say any number + greater than 1 is fine *) +let query_retries () = + two_arp () >>= fun (listen, speak) -> + let expected_query = arp_request ~from_netif:speak.netif + ~to_mac:Macaddr.broadcast ~from_ip:Ipaddr.V4.any ~to_ip:first_ip + in + let how_many = ref 0 in + let rec listener buf = + check_response expected_query buf; + if !how_many = 0 then begin + how_many := !how_many + 1; + Lwt.return_unit + end else V.disconnect listen.netif + in + let ask () = + A.query speak.arp first_ip >>= function + | `Timeout -> fail "Received `Timeout before >1 query"; + Lwt.return_unit + | `Ok mac -> fail "got result from query, erroneously"; + Lwt.return_unit + in + Lwt.pick [ + V.listen listen.netif listener; + OS.Time.sleep 0.1 >>= ask; + OS.Time.sleep 6.0 >>= fun () -> fail "query didn't succeed or fail within 6s" + ] + +(* requests for us elicit a reply *) +let requests_are_responded_to () = + let (answerer_ip, inquirer_ip) = (first_ip, second_ip) in + two_arp () >>= fun (inquirer, answerer) -> + (* neither has a listener set up when we set IPs, so no GARPs in the cache *) + A.add_ip answerer.arp answerer_ip >>= fun () -> + A.add_ip inquirer.arp inquirer_ip >>= fun () -> + let request = + Parse.cstruct_of_arp + { Parse.op = `Request; sha = (V.mac inquirer.netif); tha = Macaddr.broadcast; + spa = inquirer_ip; tpa = answerer_ip } + in + let expected_reply = + arp_reply ~from_netif:answerer.netif ~to_netif:inquirer.netif + ~from_ip:answerer_ip ~to_ip:inquirer_ip + in + let listener close_netif buf = + equals ~printer:(Printf.sprintf "%S") + (Cstruct.to_string expected_reply) (Cstruct.to_string buf); + V.disconnect close_netif + in + let arp_listener = + V.listen answerer.netif (start_arp_listener answerer ()) + in + Lwt.pick [ + Lwt.join [ + (* listen for responses and check them against an expected result *) + V.listen inquirer.netif (listener inquirer.netif); + (* start the usual ARP listener, which should respond to requests *) + arp_listener; + (* send a request for the ARP listener to respond to *) + OS.Time.sleep 0.1 >>= fun () -> V.write inquirer.netif request + >>= fun () -> OS.Time.sleep 0.1 >>= fun () -> V.disconnect answerer.netif + ]; + OS.Time.sleep 3.0 >>= fun () -> fail "timed out" + ] + +let requests_not_us () = + let (answerer_ip, inquirer_ip) = (first_ip, second_ip) in + two_arp () >>= fun (answerer, inquirer) -> + A.add_ip answerer.arp answerer_ip >>= fun () -> + A.add_ip inquirer.arp inquirer_ip >>= fun () -> + let ask ip = + Parse.cstruct_of_arp + { Parse.op = `Request; sha = (V.mac inquirer.netif); tha = Macaddr.broadcast; + spa = inquirer_ip; tpa = ip } + in + let requests = List.map ask [ inquirer_ip; Ipaddr.V4.any; + Ipaddr.V4.of_string_exn "255.255.255.255" ] in + let make_requests = Lwt_list.iter_s (V.write inquirer.netif) requests in + let disconnect_listeners () = + Lwt_list.iter_s (V.disconnect) [answerer.netif; inquirer.netif] + in + Lwt.join [ + V.listen answerer.netif (start_arp_listener answerer ()); + V.listen inquirer.netif (fail_on_receipt inquirer.netif); + make_requests >>= fun () -> OS.Time.sleep 0.1 >>= disconnect_listeners + ] + +let nonsense_requests () = + let (answerer_ip, inquirer_ip) = (first_ip, second_ip) in + three_arp () >>= fun (answerer, inquirer, checker) -> + A.set_ips answerer.arp [ answerer_ip ] >>= fun () -> + let request number = + Parse.cstruct_of_arp + { Parse.op = (`Unknown number); sha = (V.mac inquirer.netif); tha = Macaddr.broadcast; + spa = inquirer_ip; tpa = answerer_ip } + in + let requests = List.map request [0; 3; -1; 255; 256; 257; 65536] in + let make_requests = Lwt_list.iter_s (V.write inquirer.netif) requests in + let expected_probe = arp_request ~from_netif:answerer.netif + ~to_mac:Macaddr.broadcast ~from_ip:answerer_ip ~to_ip:inquirer_ip + in + Lwt.async (fun () -> + V.listen answerer.netif (start_arp_listener answerer ())); + timeout ~time:5.0 ( + Lwt.join [ + V.listen inquirer.netif (fail_on_receipt inquirer.netif); + make_requests >>= fun () -> + V.disconnect inquirer.netif >>= fun () -> + (* not sufficient to just check to see whether we've replied; it's equally + possible that we erroneously make a cache entry. Make sure querying + inquirer_ip results in an outgoing request. *) + not_in_cache ~listen:checker.netif expected_probe answerer.arp inquirer_ip + ] ) + +let suite = + [ + "nonsense requests are ignored", `Quick, nonsense_requests; + "requests are responded to", `Quick, requests_are_responded_to; + "irrelevant requests are ignored", `Quick, requests_not_us; + "set_ip sets ip, sends GARP", `Quick, set_ip_sends_garp; + "add_ip, get_ip and remove_ip as advertised", `Quick, add_get_remove_ips; + "GARPs are heard and cached", `Quick, input_single_garp; + "unsolicited unicast replies are heard and cached", `Quick, input_single_unicast; + "solicited unicast replies resolve pending threads", `Quick, input_resolves_wait; + "entries are replaced with new information", `Quick, input_replaces_old; + "unreachable IPs time out", `Quick, unreachable_times_out; + "queries are tried repeatedly before timing out", `Quick, query_retries; + "entries expire", `Quick, entries_expire; + ] diff --git a/lib_test/test_channel.ml b/lib_test/test_channel.ml deleted file mode 100644 index 27eeb27d3..000000000 --- a/lib_test/test_channel.ml +++ /dev/null @@ -1,62 +0,0 @@ -open Lwt - -(* this is a very small set of tests for the channel interface, intended to - ensure that EOF conditions on the underlying flow are handled properly *) -module Channel = Channel.Make(Fflow) - -let cmp a b = - match (String.compare a b) with | 0 -> true | _ -> false - -let fail fmt = Printf.ksprintf OUnit.assert_failure fmt - -let test_read_char_eof () = - let f = Fflow.make () in - let c = Channel.create f in - let try_char_read () = - Channel.read_char c >>= fun ch -> - fail "character %c was returned from Channel.read_char on an empty flow" ch - in - Lwt.try_bind - (try_char_read) - (fun () -> fail "no exception") (* "success" case (no exceptions) *) - (function - | End_of_file -> Lwt.return_unit - | e -> fail "wrong exception: %s" (Printexc.to_string e)) - -let check a b = - OUnit.assert_equal ~printer:(fun a -> a) ~cmp a (Cstruct.to_string b) - -let test_read_until_eof () = - let input = - Fflow.input_string "I am the very model of a modern major general" - in - let f = Fflow.make ~input () in - let c = Channel.create f in - Channel.read_until c 'v' >>= function - | true, buf -> - check "I am the " buf; - Channel.read_until c '\xff' >>= fun (found, buf) -> - OUnit.assert_equal ~msg:"claimed we found a char that couldn't have been - there in read_until" false found; - check "ery model of a modern major general" buf; - Channel.read_until c '\n' >>= fun (found, buf) -> - OUnit.assert_equal ~msg:"claimed we found a char after EOF in read_until" - false found; - OUnit.assert_equal ~printer:string_of_int 0 (Cstruct.len buf); - Lwt.return_unit - | false, _ -> - OUnit.assert_failure "thought we couldn't find a 'v' in input test" - -let test_read_line () = - let input = "I am the very model of a modern major general" in - let f = Fflow.make ~input:(Fflow.input_string input) () in - let c = Channel.create f in - Channel.read_line c >>= fun buf -> - check input (Cstruct.of_string (Cstruct.copyv buf)); - Lwt.return_unit - -let suite = [ - "read_char + EOF" , test_read_char_eof; - "read_until + EOF", test_read_until_eof; - "read_line" , test_read_line; -] diff --git a/lib_test/test_connect.ml b/lib_test/test_connect.ml index fca6a8ccb..99551d5b6 100644 --- a/lib_test/test_connect.ml +++ b/lib_test/test_connect.ml @@ -14,86 +14,123 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt open Common open Vnetif_common -let netmask = Ipaddr.V4.of_string_exn "255.255.255.0" -let gw = Ipaddr.V4.of_string_exn "10.0.0.1" -let client_ip = Ipaddr.V4.of_string_exn "10.0.0.101" -let server_ip = Ipaddr.V4.of_string_exn "10.0.0.100" -let test_string = "Hello world from Mirage 123456789...." - -module C = Console - -let accept c flow expected = - let ip, port = S.T.get_dest flow in - C.log_s c (Printf.sprintf "Accepted connection from %s:%d%!" (Ipaddr.V4.to_string ip) port) >>= fun () -> - S.T.read flow >>= (function - | `Ok b -> expect "accept" expected (Cstruct.to_string b) - | `Eof | `Error _ -> fail "Error while reading%!") - >>= fun () -> - C.log_s c "Connection closed%!" - -let tcp_connect_two_stacks backend = - or_error "console" Console.connect "console" >>= fun c -> - let timeout = 15.0 in - Lwt.pick [ - (Lwt_unix.sleep timeout >>= fun () -> - fail "connect test timedout after %f seconds" timeout) ; - - (create_stack c backend server_ip netmask [gw] >>= fun s1 -> - S.listen_tcpv4 s1 ~port:80 (fun f -> accept c f test_string); - S.listen s1) ; - - (Lwt_unix.sleep 1.0 >>= fun () -> - create_stack c backend client_ip netmask [gw] >>= fun s2 -> - or_error "connect" (S.T.create_connection (S.tcpv4 s2)) (server_ip, 80) >>= fun flow -> - C.log_s c "Connected to other end...%!" >>= fun () -> - S.T.write flow (Cstruct.of_string test_string) >>= (function - | `Ok () -> C.log_s c "wrote hello world%!" - | `Error _ -> fail "client tried to write, got error%!" - | `Eof -> fail "client tried to write, got eof%!") >>= fun () -> - S.T.close flow >>= fun () -> - Lwt.return_unit) ] >>= fun () -> - Lwt.return_unit - -let tcp_connect_one_stack backend = - or_error "console" Console.connect "console" >>= fun c -> - create_stack c backend server_ip netmask [gw] >>= fun s1 -> - let timeout = 15.0 in - Lwt.pick [ - (Lwt_unix.sleep timeout >>= fun () -> - fail "connect test timedout after %f seconds" timeout) ; - - (S.listen_tcpv4 s1 ~port:80 (fun f -> accept c f test_string); - S.listen s1) ; - - (Lwt_unix.sleep 1.0 >>= fun () -> - or_error "connect" (S.T.create_connection (S.tcpv4 s1)) (server_ip, 80) >>= fun flow -> - C.log_s c "Connected to other end...%!" >>= fun () -> - S.T.write flow (Cstruct.of_string test_string) >>= (function - | `Ok () -> C.log_s c "wrote hello world%!" - | `Error _ -> fail "client tried to write, got error%!" - | `Eof -> fail "client tried to write, got eof%!") >>= fun () -> - S.T.close flow >>= fun () -> - Lwt.return_unit) ] >>= fun () -> - Lwt.return_unit +let (>>=) = Lwt.(>>=) + +module Test_connect (B : Vnetif_backends.Backend) = struct + module C = Console + module V = VNETIF_STACK (B) + + let netmask = Ipaddr.V4.of_string_exn "255.255.255.0" + let gw = Ipaddr.V4.of_string_exn "10.0.0.1" + let client_ip = Ipaddr.V4.of_string_exn "10.0.0.101" + let server_ip = Ipaddr.V4.of_string_exn "10.0.0.100" + let test_string = "Hello world from Mirage 123456789...." + let backend = V.create_backend () + + let log_s c fmt = Printf.ksprintf (C.log_s c) (fmt ^^ "%!") + + let err_read_eof () = fail "accept got EOF while reading" + let err_write_eof () = fail "client tried to write, got EOF" + + let err_read e = + let err = V.Stackv4.TCPV4.error_message e in + fail "Error while reading: %s" err + + let err_write e = + let err = V.Stackv4.TCPV4.error_message e in + fail "client tried to write, got %s" err + + let accept c flow expected = + let ip, port = V.Stackv4.TCPV4.get_dest flow in + log_s c "Accepted connection from %s:%d" (Ipaddr.V4.to_string ip) port + >>= fun () -> + V.Stackv4.TCPV4.read flow >>= function + | `Eof -> err_read_eof () + | `Error e -> err_read e + | `Ok b -> + OS.Time.sleep 0.1 >>= fun () -> + (* sleep first to capture data in pcap *) + assert_string "accept" expected (Cstruct.to_string b); + log_s c "Connection closed" + + let test_tcp_connect_two_stacks () = + or_error "console" Console.connect "console" >>= fun c -> + let timeout = 15.0 in + Lwt.pick [ + (Lwt_unix.sleep timeout >>= fun () -> + fail "connect test timedout after %f seconds" timeout) ; + + (V.create_stack c backend server_ip netmask [gw] >>= fun s1 -> + V.Stackv4.listen_tcpv4 s1 ~port:80 (fun f -> accept c f test_string); + V.Stackv4.listen s1) ; + + (Lwt_unix.sleep 0.1 >>= fun () -> + V.create_stack c backend client_ip netmask [gw] >>= fun s2 -> + let conn = V.Stackv4.TCPV4.create_connection (V.Stackv4.tcpv4 s2) in + or_error "connect" conn (server_ip, 80) >>= fun flow -> + log_s c "Connected to other end..." >>= fun () -> + V.Stackv4.TCPV4.write flow (Cstruct.of_string test_string) >>= function + | `Error e -> err_write e + | `Eof -> err_write_eof () + | `Ok () -> + log_s c "wrote hello world" >>= fun () -> + V.Stackv4.TCPV4.close flow >>= fun () -> + Lwt_unix.sleep 1.0 >>= fun () -> (* record some traffic after close *) + Lwt.return_unit) ] + >>= fun () -> + + Lwt.return_unit + + let test_tcp_connect_one_stack () = + or_error "console" Console.connect "console" >>= fun c -> + V.create_stack c backend server_ip netmask [gw] >>= fun s1 -> + let timeout = 15.0 in + Lwt.pick [ + (Lwt_unix.sleep timeout >>= fun () -> + fail "connect test timedout after %f seconds" timeout) ; + + (V.Stackv4.listen_tcpv4 s1 ~port:80 (fun f -> accept c f test_string); + V.Stackv4.listen s1) ; + + (Lwt_unix.sleep 1.0 >>= fun () -> + or_error "connect" (V.Stackv4.TCPV4.create_connection (V.Stackv4.tcpv4 s1)) (server_ip, 80) >>= fun flow -> + C.log_s c "Connected to other end...%!" >>= fun () -> + V.Stackv4.TCPV4.write flow (Cstruct.of_string test_string) >>= (function + | `Ok () -> C.log_s c "wrote hello world%!" + | `Error _ -> fail "client tried to write, got error%!" + | `Eof -> fail "client tried to write, got eof%!") >>= fun () -> + V.Stackv4.TCPV4.close flow >>= fun () -> + Lwt.return_unit) ] >>= fun () -> + Lwt.return_unit + + let record_pcap = + V.record_pcap backend + +end let test_tcp_connect_two_stacks_basic () = - let backend = S.B.create ~use_async_readers:true ~yield:(fun() -> Lwt_main.yield () ) () in (* use_async_readers must be true with tcpip *) - tcp_connect_two_stacks backend + let module Test = Test_connect(Vnetif_backends.Basic) in + Test.record_pcap + "tests/pcap/tcp_connect_two_stacks_basic.pcap" + Test.test_tcp_connect_two_stacks let test_tcp_connect_one_stack_basic () = - let backend = S.B.create ~use_async_readers:true ~yield:(fun() -> Lwt_main.yield () ) () in (* use_async_readers must be true with tcpip *) - tcp_connect_one_stack backend + let module Test = Test_connect(Vnetif_backends.Basic) in + Test.record_pcap + "tests/pcap/tcp_connect_one_stack_basic.pcap" + Test.test_tcp_connect_one_stack let test_tcp_connect_two_stacks_trailing_bytes () = - let backend = Vnetif_backends.Trailing_bytes.create ~use_async_readers:true ~yield:(fun() -> Lwt_main.yield () ) () in (* use_async_readers must be true with tcpip *) - tcp_connect_two_stacks backend + let module Test = Test_connect(Vnetif_backends.Trailing_bytes) in + Test.record_pcap + "tests/pcap/tcp_connect_two_stacks_trailing_bytes.pcap" + Test.test_tcp_connect_two_stacks let suite = [ - "test_tcp_connect_two_stacks_basic" , test_tcp_connect_two_stacks_basic; - "test_tcp_connect_two_stacks_trailing_bytes" , test_tcp_connect_two_stacks_trailing_bytes; - "test_tcp_connect_one_stack_basic" , test_tcp_connect_one_stack_basic; + "test_tcp_connect_two_stacks_basic" , `Quick, test_tcp_connect_two_stacks_basic; + "test_tcp_connect_two_stacks_trailing_bytes" , `Quick, test_tcp_connect_two_stacks_trailing_bytes; + "test_tcp_connect_one_stack_basic" , `Quick, test_tcp_connect_one_stack_basic; ] diff --git a/lib_test/test_iperf.ml b/lib_test/test_iperf.ml index 1d3c17e8b..29a2836c8 100644 --- a/lib_test/test_iperf.ml +++ b/lib_test/test_iperf.ml @@ -16,144 +16,225 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt open Common open Vnetif_common - -let netmask = Ipaddr.V4.of_string_exn "255.255.255.0" -let gw = Ipaddr.V4.of_string_exn "10.0.0.1" -let client_ip = Ipaddr.V4.of_string_exn "10.0.0.101" -let server_ip = Ipaddr.V4.of_string_exn "10.0.0.100" - -module C = Console - -type stats = { - mutable bytes: int64; - mutable packets: int64; - mutable bin_bytes:int64; - mutable bin_packets: int64; - mutable start_time: float; - mutable last_time: float; -} - -let msg = "01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890" - -let mlen = String.length msg - -let write_and_check flow buf = - S.T.write flow buf >>= function - | `Ok () -> Lwt.return_unit - | `Eof -> S.T.close flow >>= fun () -> raise (Failure "EOF while writing to TCP flow") - | `Error _ -> S.T.close flow >>= fun () -> raise (Failure "Error while writing to TCP flow") - -let tcp_connect t (ip, port) = - S.T.create_connection t (ip, port) >>= function - | `Error e -> raise (Failure (Printf.sprintf "Unable to connect to %s:%d" (Ipaddr.V4.to_string ip) port)) - | `Ok f -> Lwt.return f - -let iperfclient c s dest_ip dport = - let iperftx flow = - C.log_s c (Printf.sprintf "Iperf client: Made connection to server.%!") >>= fun () -> - let a = Cstruct.sub (Io_page.(to_cstruct (get 1))) 0 mlen in - Cstruct.blit_from_string msg 0 a 0 mlen; - let amt = 50000000 in - let rec loop = function - | 0 -> Lwt.return_unit - | n -> write_and_check flow a >>= fun () -> loop (n-1) +let (>>=) = Lwt.(>>=) + +module Test_iperf (B : Vnetif_backends.Backend) = struct + + module C = Console + module V = VNETIF_STACK (B) + + let backend = V.create_backend () + + let netmask = Ipaddr.V4.of_string_exn "255.255.255.0" + let gw = Ipaddr.V4.of_string_exn "10.0.0.1" + let client_ip = Ipaddr.V4.of_string_exn "10.0.0.101" + let server_ip = Ipaddr.V4.of_string_exn "10.0.0.100" + + type stats = { + mutable bytes: int64; + mutable packets: int64; + mutable bin_bytes:int64; + mutable bin_packets: int64; + mutable start_time: float; + mutable last_time: float; + } + + let msg = + "01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890\ + abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijk\ + lmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuv\ + wxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFG\ + HIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQR\ + STUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012\ + 34567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abc\ + defghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmn\ + opqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxy\ + zABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJ\ + KLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTU\ + VWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345\ + 67890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdef\ + ghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopq\ + rstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzAB\ + CDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLM\ + NOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWX\ + YZ01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345678\ + 90abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghi\ + jklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890" + + let mlen = String.length msg + + let err_eof () = fail "EOF while writing to TCP flow" + + let err_connect e ip port () = + let err = V.Stackv4.TCPV4.error_message e in + let ip = Ipaddr.V4.to_string ip in + fail "Unable to connect to %s:%d: %s" ip port err + + let err_write e () = + let err = V.Stackv4.TCPV4.error_message e in + fail "Error while writing to TCP flow: %s" err + + let err_read e () = + let err = V.Stackv4.TCPV4.error_message e in + fail "Error in server while reading: %s" err + + let log_s c fmt = Printf.ksprintf (C.log_s c) (fmt ^^ "%!") + + let write_and_check flow buf = + V.Stackv4.TCPV4.write flow buf >>= function + | `Ok () -> Lwt.return_unit + | `Eof -> V.Stackv4.TCPV4.close flow >>= err_eof + | `Error e -> V.Stackv4.TCPV4.close flow >>= err_write e + + let tcp_connect t (ip, port) = + V.Stackv4.TCPV4.create_connection t (ip, port) >>= function + | `Error e -> err_connect e ip port () + | `Ok f -> Lwt.return f + + let iperfclient c s amt dest_ip dport = + let iperftx flow = + log_s c "Iperf client: Made connection to server." >>= fun () -> + let a = Cstruct.sub (Io_page.(to_cstruct (get 1))) 0 mlen in + Cstruct.blit_from_string msg 0 a 0 mlen; + let rec loop = function + | 0 -> Lwt.return_unit + | n -> write_and_check flow a >>= fun () -> loop (n-1) + in + loop (amt / mlen) >>= fun () -> + let a = Cstruct.sub a 0 (amt - (mlen * (amt/mlen))) in + write_and_check flow a >>= fun () -> + V.Stackv4.TCPV4.close flow + in + log_s c "Iperf client: Attempting connection." >>= fun () -> + tcp_connect (V.Stackv4.tcpv4 s) (dest_ip, dport) >>= fun flow -> + iperftx flow >>= fun () -> + log_s c "Iperf client: Done." + + let print_data c st ts_now = + let server = ts_now -. st.start_time in + let rate = + (Int64.to_float st.bin_bytes /. (ts_now -. st.last_time)) /. 125. + in + let live_words = Gc.((stat()).live_words) in + log_s c "Iperf server: t = %.0f, rate = %.0fd KBits/s, totbytes = %Ld, \ + live_words = %d" server rate st.bytes live_words >>= fun () -> + st.last_time <- ts_now; + st.bin_bytes <- 0L; + st.bin_packets <- 0L; + Lwt.return_unit + + let iperf c s server_done_u flow = + log_s c "Iperf server: Received connection." >>= fun () -> + let t0 = Clock.time () in + let st = { + bytes=0L; packets=0L; bin_bytes=0L; bin_packets=0L; start_time = t0; + last_time = t0 + } in + let rec iperf_h flow = + V.Stackv4.TCPV4.read flow >>= fun f -> + match f with + | `Error e -> err_read e () + | `Eof -> + let ts_now = (Clock.time ()) in + st.bin_bytes <- st.bytes; + st.bin_packets <- st.packets; + st.last_time <- st.start_time; + print_data c st ts_now >>= fun () -> + V.Stackv4.TCPV4.close flow >>= fun () -> + C.log_s c "Iperf server: Done - closed connection." + | `Ok data -> + begin + let l = Cstruct.len data in + st.bytes <- (Int64.add st.bytes (Int64.of_int l)); + st.packets <- (Int64.add st.packets 1L); + st.bin_bytes <- (Int64.add st.bin_bytes (Int64.of_int l)); + st.bin_packets <- (Int64.add st.bin_packets 1L); + let ts_now = (Clock.time ()) in + (if ((ts_now -. st.last_time) >= 1.0) then + print_data c st ts_now + else + Lwt.return_unit) >>= fun () -> + iperf_h flow + end in - loop (amt / mlen) >>= fun () -> - let a = Cstruct.sub a 0 (amt - (mlen * (amt/mlen))) in - write_and_check flow a >>= fun () -> - S.T.close flow - in - OS.Time.sleep 1. >>= fun () -> - C.log_s c (Printf.sprintf "Iperf client: Attempting connection.%!") >>= fun () -> - tcp_connect (S.tcpv4 s) (dest_ip, dport) >>= fun flow -> - iperftx flow >>= fun () -> - C.log_s c (Printf.sprintf "Iperf client: Done.%!") - -let print_data c st ts_now = - C.log_s c (Printf.sprintf "Iperf server: t = %f, rate = %Ld KBits/s, totbytes = %Ld, live_words = %d%!" - (ts_now -. st.start_time) - (Int64.of_float (((Int64.to_float st.bin_bytes) /. (ts_now -. st.last_time)) /. 125.)) - st.bytes Gc.((stat()).live_words)) >>= fun () -> - st.last_time <- ts_now; - st.bin_bytes <- 0L; - st.bin_packets <- 0L; - Lwt.return_unit - -let iperf c s server_done_u flow = - C.log_s c (Printf.sprintf "Iperf server: Received connection.%!") >>= fun () -> - let t0 = Clock.time () in - let st = {bytes=0L; packets=0L; bin_bytes=0L; bin_packets=0L; start_time = t0; last_time = t0} in - let rec iperf_h flow = - S.T.read flow >>= fun f -> - match f with - | `Error _ -> raise (Failure "Unknown error in server while reading") - | `Eof -> - let ts_now = (Clock.time ()) in - st.bin_bytes <- st.bytes; - st.bin_packets <- st.packets; - st.last_time <- st.start_time; - print_data c st ts_now >>= fun () -> - S.T.close flow >>= fun () -> - C.log_s c "Iperf server: Done - closed connection." - | `Ok data -> - begin - let l = Cstruct.len data in - st.bytes <- (Int64.add st.bytes (Int64.of_int l)); - st.packets <- (Int64.add st.packets 1L); - st.bin_bytes <- (Int64.add st.bin_bytes (Int64.of_int l)); - st.bin_packets <- (Int64.add st.bin_packets 1L); - let ts_now = (Clock.time ()) in - (if ((ts_now -. st.last_time) >= 1.0) then - print_data c st ts_now - else - Lwt.return_unit) >>= fun () -> - iperf_h flow - end - in - iperf_h flow >>= fun () -> - Lwt.wakeup server_done_u (); - Lwt.return_unit - -let tcp_iperf backend () = - or_error "console" Console.connect "console" >>= fun c -> - let port = 5001 in - create_stack c backend server_ip netmask [gw] >>= fun server_s -> - create_stack c backend client_ip netmask [gw] >>= fun client_s -> - - let server_ready, server_ready_u = Lwt.wait () in - let server_done, server_done_u = Lwt.wait () in - let timeout = 30.0 in - - Lwt.pick [ - (Lwt_unix.sleep timeout >>= fun () -> (* timeout *) - fail "iperf test timed out after %f seconds" timeout) ; - - (server_ready >>= fun () -> - Lwt_unix.sleep 1.0 >>= fun() -> - C.log_s c (Printf.sprintf "I am client with IP %s, trying to connect to server @ %s:%d" (Ipaddr.V4.to_string client_ip) (Ipaddr.V4.to_string server_ip) port) >>= fun () -> - iperfclient c client_s server_ip port) ; - - (Lwt_unix.sleep 1.0 >>= fun () -> - C.log_s c (Printf.sprintf "I am server with IP %s, expecting connections on port %d" (Ipaddr.V4.to_string server_ip) port) >>= fun () -> - S.listen_tcpv4 server_s ~port (iperf c server_s server_done_u); - Lwt.wakeup server_ready_u (); - S.listen server_s) ] >>= fun () -> - C.log_s c "Waiting for server_done..." >>= fun () -> - server_done >>= fun () -> - Lwt.return_unit (* exit cleanly *) - -let test_tcp_iperf_two_stacks_basic () = - let backend = S.B.create ~use_async_readers:true ~yield:(fun() -> Lwt_main.yield () ) () in (* use_async_readers must be true with tcpip *) - tcp_iperf backend () - -let test_tcp_iperf_two_stacks_trailing_bytes () = - let backend = Vnetif_backends.Trailing_bytes.create ~use_async_readers:true ~yield:(fun() -> Lwt_main.yield () ) () in (* use_async_readers must be true with tcpip *) - tcp_iperf backend () + iperf_h flow >>= fun () -> + Lwt.wakeup server_done_u (); + Lwt.return_unit + + let tcp_iperf amt () = + or_error "console" C.connect "console" >>= fun c -> + let port = 5001 in + + let server_ready, server_ready_u = Lwt.wait () in + let server_done, server_done_u = Lwt.wait () in + let timeout = 120.0 in + + Lwt.pick [ + (Lwt_unix.sleep timeout >>= fun () -> (* timeout *) + fail "iperf test timed out after %f seconds" timeout); + + (server_ready >>= fun () -> + Lwt_unix.sleep 0.1 >>= fun() -> (* Give server 0.1 s to call listen *) + log_s c "I am client with IP %s, trying to connect to server @ %s:%d" + (Ipaddr.V4.to_string client_ip) + (Ipaddr.V4.to_string server_ip) port + >>= fun () -> + V.create_stack c backend client_ip netmask [gw] >>= fun client_s -> + iperfclient c client_s amt server_ip port); + + (log_s c "I am server with IP %s, expecting connections on port %d" + (Ipaddr.V4.to_string server_ip) port >>= fun () -> + V.create_stack c backend server_ip netmask [gw] >>= fun server_s -> + V.Stackv4.listen_tcpv4 server_s ~port (iperf c server_s server_done_u); + Lwt.wakeup server_ready_u (); + V.Stackv4.listen server_s) ] >>= fun () -> + + log_s c "Waiting for server_done..." >>= fun () -> + server_done >>= fun () -> + Lwt.return_unit (* exit cleanly *) + + let record_pcap = + V.record_pcap backend +end + +let test_tcp_iperf_two_stacks_basic amt () = + let module Test = Test_iperf (Vnetif_backends.Basic) in + Test.record_pcap + "tests/pcap/tcp_iperf_two_stacks_basic.pcap" + (Test.tcp_iperf amt) + +let test_tcp_iperf_two_stacks_trailing_bytes amt () = + let module Test = Test_iperf (Vnetif_backends.Trailing_bytes) in + Test.record_pcap + "tests/pcap/tcp_iperf_two_stacks_trailing_bytes.pcap" + (Test.tcp_iperf amt) + +let test_tcp_iperf_two_stacks_uniform_packet_loss amt () = + let module Test = Test_iperf (Vnetif_backends.Uniform_packet_loss) in + Test.record_pcap + "tests/pcap/tcp_iperf_two_stacks_uniform_packet_loss.pcap" + (Test.tcp_iperf amt) + +let amt_quick = 10_000_000 +let amt_slow = amt_quick * 100 let suite = [ - "test_tcp_iperf_two_stacks_basic" , test_tcp_iperf_two_stacks_basic; - "test_tcp_iperf_two_stacks_trailing_bytes" , test_tcp_iperf_two_stacks_trailing_bytes; + + "iperf with two stacks, basic tests", `Quick, + test_tcp_iperf_two_stacks_basic amt_quick; + + "iperf with two stacks, testing trailing_bytes", `Quick, + test_tcp_iperf_two_stacks_trailing_bytes amt_quick; + + "iperf with two stacks and uniform packet loss", `Quick, + test_tcp_iperf_two_stacks_uniform_packet_loss amt_quick; + + "iperf with two stacks, basic tests, longer", `Slow, + test_tcp_iperf_two_stacks_basic amt_slow; + + "iperf with two stacks and uniform packet loss, longer", `Slow, + test_tcp_iperf_two_stacks_uniform_packet_loss amt_slow; + ] diff --git a/lib_test/vnetif_backends.ml b/lib_test/vnetif_backends.ml index 4ea134674..f905391bd 100644 --- a/lib_test/vnetif_backends.ml +++ b/lib_test/vnetif_backends.ml @@ -14,25 +14,69 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -module Trailing_bytes = struct +module type Backend = sig + include Vnetif.BACKEND + val create : unit -> t +end + +(** This backend adds a random number of trailing bytes to each frame *) +module Trailing_bytes : Backend = struct module X = Basic_backend.Make include X - let max_bytes_to_add = Int32.of_int 512 + let max_bytes_to_add = 10 (* Just adds trailing bytes, doesn't store anything in them *) let add_random_bytes src = - let bytes_to_add = (Int32.to_int (Random.int32 max_bytes_to_add)) in + let bytes_to_add = Random.int max_bytes_to_add in let len = Cstruct.len src in let dst = Cstruct.create (len + bytes_to_add) in Cstruct.blit src 0 dst 0 len; dst + let set_listen_fn t id fn = + (* Add random bytes before returning result to real listener *) + X.set_listen_fn t id (fun buf -> + fn (add_random_bytes buf)) + + let create () = + X.create ~use_async_readers:true ~yield:(fun() -> Lwt_main.yield () ) () + +end + +(** This backend drops packets *) +module Uniform_packet_loss : Backend = struct + module X = Basic_backend.Make + include X + + let drop_p = 0.01 + let write t id buffer = - X.write t id (add_random_bytes buffer) + if Random.float 1.0 < drop_p then + begin + MProf.Trace.label "pkt_drop"; + Lwt.return_unit (* drop packet *) + end else + X.write t id buffer (* pass to real write *) let writev t id buffers = - let new_buffers = List.map (fun a -> (add_random_bytes a)) buffers in - X.writev t id new_buffers + if Random.float 1.0 < drop_p then + begin + MProf.Trace.label "pkt_drop"; + Lwt.return_unit (* drop packet *) + end else + X.writev t id buffers (* pass to real writev *) + + let create () = + X.create ~use_async_readers:true ~yield:(fun() -> Lwt_main.yield () ) () + +end + +(** This backend delivers all packets unmodified *) +module Basic : Backend = struct + module X = Basic_backend.Make + include X + let create () = + X.create ~use_async_readers:true ~yield:(fun() -> Lwt_main.yield () ) () end diff --git a/lib_test/vnetif_common.ml b/lib_test/vnetif_common.ml index cd9d38408..cfe5f05ab 100644 --- a/lib_test/vnetif_common.ml +++ b/lib_test/vnetif_common.ml @@ -17,38 +17,108 @@ open Lwt open Common +(* TODO Some of these modules and signatures could eventually be moved to mirage-vnetif *) + module Time = struct type 'a io = 'a Lwt.t include Lwt_unix end module Clock = Unix - module Console = Console_unix -module S = struct - module B = Basic_backend.Make +module type VNETIF_STACK = +sig + type backend + type buffer + type 'a io + type id + module Stackv4 : V1_LWT.STACKV4 + (** Create a new backend *) + val create_backend : unit -> backend + (** Create a new stack connected to an existing backend *) + val create_stack : Console.t -> backend -> Ipaddr.V4.t -> Ipaddr.V4.t -> Ipaddr.V4.t list -> Stackv4.t Lwt.t + (** Add a listener function to the backend *) + val create_backend_listener : backend -> (buffer -> unit io) -> id + (** Disable a listener function *) + val disable_backend_listener : backend -> id -> unit + (** Records pcap data from the backend while running the specified function. Disables the pcap recorder when the function exits. *) + val record_pcap : backend -> string -> (unit -> unit Lwt.t) -> unit Lwt.t +end + +module VNETIF_STACK ( B : Vnetif_backends.Backend) : VNETIF_STACK = struct + type backend = B.t + type buffer = B.buffer + type 'a io = 'a B.io + type id = B.id + module V = Vnetif.Make(B) module E = Ethif.Make(V) - module I = Ipv4.Make(E)(Clock)(Time) + module A = Arpv4.Make(E)(Clock)(Time) + module I = Ipv4.Make(E)(A) module U = Udp.Make(I) module T = Tcp.Flow.Make(I)(Time)(Clock)(Random) - module S = Tcpip_stack_direct.Make(Console)(Time)(Random)(V)(E)(I)(U)(T) - include S -end + module Stackv4 = Tcpip_stack_direct.Make(Console)(Time)(Random)(V)(E)(A)(I)(U)(T) -let create_stack c backend ip netmask gw = - or_error "backend" S.V.connect backend >>= fun netif -> - (* Printf.printf (Printf.sprintf "Connected to backend with mac %s" (Macaddr.to_string (S.V.mac netif))) *) - or_error "ethif" S.E.connect netif >>= fun ethif -> - or_error "ipv4" S.I.connect ethif >>= fun ipv4 -> - or_error "udpv4" S.U.connect ipv4 >>= fun udpv4 -> - or_error "tcpv4" S.T.connect ipv4 >>= fun tcpv4 -> - let config = { - V1_LWT.name = "stack"; - console = c; - interface = netif; - mode = `IPv4 (ip, netmask, gw); - } in - or_error "stack" (S.connect config ethif ipv4 udpv4) tcpv4 + let create_backend () = + B.create () + let create_stack c backend ip netmask gw = + or_error "backend" V.connect backend >>= fun netif -> + or_error "ethif" E.connect netif >>= fun ethif -> + or_error "arpv4" A.connect ethif >>= fun arpv4 -> + or_error "ipv4" (I.connect ethif) arpv4 >>= fun ipv4 -> + or_error "udpv4" U.connect ipv4 >>= fun udpv4 -> + or_error "tcpv4" T.connect ipv4 >>= fun tcpv4 -> + let config = { + V1_LWT.name = "stack"; + console = c; + interface = netif; + mode = `IPv4 (ip, netmask, gw); + } in + or_error "stack" (Stackv4.connect config ethif arpv4 ipv4 udpv4) tcpv4 + + let create_backend_listener backend listenf = + match (B.register backend) with + | `Error e -> fail "Error occured while registering to backend" + | `Ok id -> (B.set_listen_fn backend id listenf); id + + let disable_backend_listener backend id = + B.set_listen_fn backend id (fun buf -> Lwt.return_unit) + + let create_pcap_recorder backend channel = + let header_buf = Cstruct.create Pcap.sizeof_pcap_header in + Pcap.LE.set_pcap_header_magic_number header_buf Pcap.magic_number; + Pcap.LE.set_pcap_header_network header_buf Pcap.Network.(to_int32 Ethernet); + Pcap.LE.set_pcap_header_sigfigs header_buf 0l; + Pcap.LE.set_pcap_header_snaplen header_buf 0xffffl; + Pcap.LE.set_pcap_header_thiszone header_buf 0l; + Pcap.LE.set_pcap_header_version_major header_buf Pcap.major_version; + Pcap.LE.set_pcap_header_version_minor header_buf Pcap.minor_version; + Lwt_io.write channel (Cstruct.to_string header_buf) >>= fun () -> + let pcap_record channel buffer = + let pcap_buf = Cstruct.create Pcap.sizeof_pcap_packet in + let time = Unix.gettimeofday () in + Pcap.LE.set_pcap_packet_incl_len pcap_buf (Int32.of_int (Cstruct.len buffer)); + Pcap.LE.set_pcap_packet_orig_len pcap_buf (Int32.of_int (Cstruct.len buffer)); + Pcap.LE.set_pcap_packet_ts_sec pcap_buf (Int32.of_float time); + let frac = (time -. (float_of_int (truncate time))) *. 1000000.0 in + Pcap.LE.set_pcap_packet_ts_usec pcap_buf (Int32.of_float frac); + (try + Lwt_io.write channel ((Cstruct.to_string pcap_buf) ^ (Cstruct.to_string buffer)) + with + Lwt_io.Channel_closed msg -> Printf.printf "Warning: Pcap output channel already closed: %s.\n" msg; Lwt.return_unit) + >>= fun () -> + Lwt.return_unit + in + let recorder_id = create_backend_listener backend (pcap_record channel) in + Lwt.return recorder_id + + let record_pcap backend pcap_file fn = + Lwt_io.with_file ~mode:Lwt_io.output pcap_file (fun oc -> + create_pcap_recorder backend oc >>= fun recorder_id -> + fn () >>= fun () -> + disable_backend_listener backend recorder_id; + Lwt.return_unit + ) +end diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 14043d6f2..4ba37da8e 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 4f73136167cbc6b589c94b765b108e48) *) +(* DO NOT EDIT (digest: 3fb3a3f141467c256c322c0db896bbb4) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -612,14 +612,15 @@ let package_default = ("tcpip", ["lib"], []); ("tcpip_xen", ["lib"], []); ("ethif", ["lib"], []); + ("arpv4", ["lib"], []); ("ipv4", ["lib"], []); ("ipv6", ["lib"], []); ("udp", ["lib"], []); ("tcp", ["tcp"], []); - ("channel", ["channel"], []); ("dhcpv4", ["dhcp"], []); ("tcpip-stack-direct", ["lib"], []); ("ethif-unix", ["unix"], []); + ("arpv4-unix", ["unix"], []); ("ipv4-unix", ["unix"], []); ("ipv6-unix", ["unix"], []); ("udpv4-unix", ["unix"], []); @@ -647,19 +648,13 @@ let package_default = [ (OASISExpr.EBool true, S [A "-ccopt"; A "-O2"; A "-ccopt"; A "${XEN_CFLAGS}"]) - ]); - (["oasis_executable_test_byte"; "ocaml"; "link"; "byte"], - [(OASISExpr.EBool true, S [A "-g"])]); - (["oasis_executable_test_byte"; "ocaml"; "ocamldep"; "byte"], - [(OASISExpr.EBool true, S [A "-g"])]); - (["oasis_executable_test_byte"; "ocaml"; "compile"; "byte"], - [(OASISExpr.EBool true, S [A "-g"])]) + ]) ]; includes = [ - ("unix", ["channel"; "lib"; "tcp"]); + ("unix", ["lib"; "tcp"]); ("tcp", ["lib"]); - ("lib_test", ["channel"; "lib"; "tcp"]); + ("lib_test", ["lib"; "tcp"]); ("lib", ["dhcp"; "tcp"]); ("dhcp", ["lib"]) ] @@ -670,6 +665,11 @@ let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; -# 674 "myocamlbuild.ml" +# 669 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; +(* Ocamlbuild_pack.Flags.mark_tag_used "tests";; *) +let () = + flag ["ocaml"; "doc"] (A"-colorize-code"); + flag ["ocaml"; "doc"] (A"-short-functors"); + flag ["ocaml"; "doc"] (A"-short-paths") diff --git a/opam b/opam index f598d8c40..9e73e0225 100644 --- a/opam +++ b/opam @@ -9,32 +9,40 @@ authors: [ "Richard Mortier" "Nicolas Ojeda Bar" "Thomas Gazagnaire" + "Vincent Bernardoff" + "Magnus Skjegstad" + "Mindy Preston" + "Thomas Leonard" ] tags: ["org:mirage"] build: [ - ["./configure" "--prefix" prefix - "--%{mirage-flow+alcotest:enable}%-tests" - "--%{mirage-xen:enable}%-xen" - ] + ["./configure" "--prefix" prefix "--%{mirage-xen:enable}%-xen"] [make] ] -build-test: [make "test"] +build-test: [ + ["./configure" "--enable-tests"] + [make "test" "TESTFLAGS=-v"] +] + install: [make "install"] remove: ["ocamlfind" "remove" "tcpip"] depends: [ "ocamlfind" {build} "cstruct" {>= "1.0.1"} - "mirage-types" {>= "2.0.0"} + "channel" + "mirage-types" {>= "2.6.0"} "mirage-unix" {>= "1.1.0"} "mirage-console" "mirage-clock-unix" {>= "1.0.0"} "mirage-net-unix" {>= "1.1.0"} "ipaddr" {>= "2.2.0"} - "mirage-profile" + "mirage-profile" {>= "0.5"} "mirage-flow" {test} "mirage-vnetif" {test} "alcotest" {test} + "pcap-format" {test} + "lwt" {>= "2.4.7"} ] depopts: [ "mirage-xen" diff --git a/postconf.ml b/postconf.ml index 3be544b0c..1a0c32566 100644 --- a/postconf.ml +++ b/postconf.ml @@ -24,14 +24,19 @@ let () = ) done with End_of_file -> - close_in ch; + close_in ch; - let xen_cflags = - if !xen then - check_output "env PKG_CONFIG_PATH=`opam config var prefix`/lib/pkgconfig pkg-config --static mirage-xen --cflags" - else "xen_not_enabled" in + let xen_cflags = + if !xen then + try check_output "pkg-config --static mirage-xen --cflags" + with Assert_failure _ | End_of_file -> + check_output + "env PKG_CONFIG_PATH=`opam config var prefix`/lib/pkgconfig \ + pkg-config --static mirage-xen --cflags" + else "xen_not_enabled" + in - Buffer.add_string b (Printf.sprintf "XEN_CFLAGS=%S\n" xen_cflags); - let ch = open_out "setup.data" in - Buffer.output_buffer ch b; - close_out ch + Buffer.add_string b (Printf.sprintf "XEN_CFLAGS=%S\n" xen_cflags); + let ch = open_out "setup.data" in + Buffer.output_buffer ch b; + close_out ch diff --git a/setup.ml b/setup.ml index 5b015ce32..f149cac01 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.5 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 9e562aeade84671386bb2407954c696f) *) +(* DO NOT EDIT (digest: 1da3910312b5ae7779af64e068743ba1) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6809,7 +6809,7 @@ let setup_t = CustomPlugin.Test.main { CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test", []))]; + [(OASISExpr.EBool true, ("$test", ["-q"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) @@ -6824,7 +6824,7 @@ let setup_t = CustomPlugin.Test.clean { CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test", []))]; + [(OASISExpr.EBool true, ("$test", ["-q"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) @@ -6837,7 +6837,7 @@ let setup_t = CustomPlugin.Test.distclean { CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test", []))]; + [(OASISExpr.EBool true, ("$test", ["-q"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) @@ -6851,7 +6851,7 @@ let setup_t = alpha_features = []; beta_features = []; name = "tcpip"; - version = "2.4.3"; + version = "2.6.1"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -6869,7 +6869,11 @@ let setup_t = "Balraj Singh"; "Richard Mortier"; "Nicolas Ojeda Bar"; - "Thomas Gazagnaire" + "Thomas Gazagnaire"; + "Vincent Bernardoff"; + "Magnus Skjegstad"; + "Mindy Preston"; + "Thomas Leonard" ]; homepage = None; synopsis = "Ethernet, TCP/IPv4 and DHCPv4 library"; @@ -7037,6 +7041,45 @@ let setup_t = lib_findlib_name = Some "ethif"; lib_findlib_containers = [] }); + Library + ({ + cs_name = "arpv4"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "lib"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "tcpip"; + FindlibPackage ("io-page", None); + FindlibPackage ("mirage-types", None); + FindlibPackage ("ipaddr", None); + FindlibPackage ("cstruct", None); + FindlibPackage ("lwt", None); + FindlibPackage ("cstruct.syntax", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + lib_modules = ["Arpv4"; "Arpv4_wire"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "tcpip"; + lib_findlib_name = Some "arpv4"; + lib_findlib_containers = [] + }); Library ({ cs_name = "ipv4"; @@ -7068,7 +7111,7 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = ["Ipv4"; "Arpv4"]; + lib_modules = ["Ipv4"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "tcpip"; @@ -7171,7 +7214,8 @@ let setup_t = FindlibPackage ("lwt", None); InternalLibrary "tcpip"; InternalLibrary "ipv4"; - InternalLibrary "ipv6" + InternalLibrary "ipv6"; + FindlibPackage ("mirage-profile", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7196,7 +7240,9 @@ let setup_t = "Segment"; "User_buffer"; "Pcb"; - "Flow" + "Flow"; + "Stats"; + "Log" ]; lib_pack = true; lib_internal_modules = []; @@ -7206,22 +7252,24 @@ let setup_t = }); Library ({ - cs_name = "channel"; + cs_name = "dhcpv4"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "channel"; + bs_path = "dhcp"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("io-page", None); + FindlibPackage ("bytes", None); FindlibPackage ("mirage-types", None); FindlibPackage ("ipaddr", None); FindlibPackage ("cstruct", None); - FindlibPackage ("lwt", None) + FindlibPackage ("lwt", None); + InternalLibrary "udp" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7234,33 +7282,36 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = ["Channel"]; + lib_modules = ["Dhcpv4_option"; "Dhcp_clientv4"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "tcpip"; - lib_findlib_name = Some "channel"; + lib_findlib_name = Some "dhcpv4"; lib_findlib_containers = [] }); Library ({ - cs_name = "dhcpv4"; + cs_name = "tcpip-stack-direct"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "dhcp"; + bs_path = "lib"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("io-page", None); - FindlibPackage ("bytes", None); FindlibPackage ("mirage-types", None); FindlibPackage ("ipaddr", None); FindlibPackage ("cstruct", None); FindlibPackage ("lwt", None); - InternalLibrary "udp" + InternalLibrary "ethif"; + InternalLibrary "arpv4"; + InternalLibrary "udp"; + InternalLibrary "tcp"; + InternalLibrary "dhcpv4" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7273,35 +7324,30 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = ["Dhcpv4_option"; "Dhcp_clientv4"]; + lib_modules = ["Tcpip_stack_direct"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "tcpip"; - lib_findlib_name = Some "dhcpv4"; + lib_findlib_name = Some "stack-direct"; lib_findlib_containers = [] }); Library ({ - cs_name = "tcpip-stack-direct"; + cs_name = "ethif-unix"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "lib"; + bs_path = "unix"; bs_compiled_object = Best; bs_build_depends = [ - FindlibPackage ("io-page", None); - FindlibPackage ("mirage-types", None); - FindlibPackage ("ipaddr", None); - FindlibPackage ("cstruct", None); - FindlibPackage ("lwt", None); InternalLibrary "ethif"; - InternalLibrary "udp"; - InternalLibrary "tcp"; - InternalLibrary "dhcpv4" + FindlibPackage ("mirage-net-unix", None); + FindlibPackage ("lwt", None); + FindlibPackage ("lwt.unix", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7314,16 +7360,16 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = ["Tcpip_stack_direct"]; + lib_modules = ["Ethif_unix"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "tcpip"; - lib_findlib_name = Some "stack-direct"; + lib_findlib_name = Some "ethif-unix"; lib_findlib_containers = [] }); Library ({ - cs_name = "ethif-unix"; + cs_name = "arpv4-unix"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, @@ -7350,11 +7396,11 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = ["Ethif_unix"]; + lib_modules = ["Arpv4_unix"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "tcpip"; - lib_findlib_name = Some "ethif-unix"; + lib_findlib_name = Some "arpv4-unix"; lib_findlib_containers = [] }); Library @@ -7598,7 +7644,7 @@ let setup_t = [ InternalLibrary "tcp"; InternalLibrary "ipv4-unix"; - InternalLibrary "channel"; + FindlibPackage ("channel", None); FindlibPackage ("lwt", None); FindlibPackage ("lwt.unix", None); FindlibPackage ("mirage-unix", None); @@ -7640,7 +7686,7 @@ let setup_t = [ InternalLibrary "tcp"; InternalLibrary "ipv6-unix"; - InternalLibrary "channel"; + FindlibPackage ("channel", None); FindlibPackage ("lwt", None); FindlibPackage ("lwt.unix", None); FindlibPackage ("mirage-unix", None); @@ -7839,9 +7885,9 @@ let setup_t = (OASISExpr.EBool true, false); (OASISExpr.EFlag "tests", true) ]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "lib_test"; - bs_compiled_object = Byte; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "lib_test/"; + bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("alcotest", None); @@ -7849,12 +7895,14 @@ let setup_t = FindlibPackage ("lwt", None); FindlibPackage ("lwt.unix", None); FindlibPackage ("io-page.unix", None); - InternalLibrary "channel"; + FindlibPackage ("mirage-profile", None); FindlibPackage ("mirage-flow", None); FindlibPackage ("mirage-vnetif", None); FindlibPackage ("mirage-console.unix", None); + FindlibPackage ("mirage-clock-unix", None); InternalLibrary "ethif"; - InternalLibrary "tcp" + InternalLibrary "tcp"; + FindlibPackage ("pcap-format", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7863,7 +7911,7 @@ let setup_t = bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, ["-g"])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = true; exec_main_is = "test.ml"}); @@ -7875,7 +7923,8 @@ let setup_t = }, { test_type = (`Test, "custom", Some "0.4"); - test_command = [(OASISExpr.EBool true, ("$test", []))]; + test_command = + [(OASISExpr.EBool true, ("$test", ["-q"]))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; @@ -7902,7 +7951,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "\028ÚØÔÿ\019Î8>;éÀ37)]"; + oasis_digest = Some "j\128xw\129+\tÐrË!¶à\014ÅÌ"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7910,6 +7959,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7914 "setup.ml" +# 7963 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/tcp/ack.ml b/tcp/ack.ml index 1599ecc84..918ba6cf3 100644 --- a/tcp/ack.ml +++ b/tcp/ack.ml @@ -14,7 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt +open Lwt.Infix (* General signature for all the ack modules *) module type M = sig @@ -51,12 +51,12 @@ module Immediate : M = struct let receive t ack_number = match t.pushpending with - | true -> return_unit + | true -> Lwt.return_unit | false -> pushack t ack_number let transmit t _ = t.pushpending <- false; - return_unit + Lwt.return_unit end @@ -82,25 +82,22 @@ module Delayed (Time:V1_LWT.TIME) : M = struct let transmitack r ack_number = match r.pushpending with - | true -> return_unit - | false -> r.pushpending <- true; + | true -> Lwt.return_unit + | false -> + r.pushpending <- true; transmitacknow r ack_number - let ontimer r s = match r.delayed with - | false -> - Tcptimer.Stoptimer - | true -> begin - match r.delayedack = s with - | false -> - Tcptimer.Continue r.delayedack - | true -> - r.delayed <- false; - let _ = transmitack r s in - Tcptimer.Stoptimer - end - + | false -> Lwt.return Tcptimer.Stoptimer + | true -> + match r.delayedack = s with + | false -> + Lwt.return (Tcptimer.Continue r.delayedack) + | true -> + r.delayed <- false; + transmitack r s >>= fun () -> + Lwt.return Tcptimer.Stoptimer let t ~send_ack ~last : t = let pushpending = false in @@ -134,6 +131,6 @@ module Delayed (Time:V1_LWT.TIME) : M = struct let transmit t _ = t.r.delayed <- false; t.r.pushpending <- false; - return_unit + Lwt.return_unit end diff --git a/tcp/flow.ml b/tcp/flow.ml index 792b8d6af..e67857265 100644 --- a/tcp/flow.ml +++ b/tcp/flow.ml @@ -14,7 +14,13 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt +open Lwt.Infix + +(* TODO: modify V1.TCP to have a proper return type *) + +exception Refused + +let debug = Log.create "Flow" module Make(IP:V1_LWT.IP)(TM:V1_LWT.TIME)(C:V1.CLOCK)(R:V1.RANDOM) = struct @@ -35,57 +41,55 @@ module Make(IP:V1_LWT.IP)(TM:V1_LWT.TIME)(C:V1.CLOCK)(R:V1.RANDOM) = struct | `Refused ] + let err_timeout daddr dport = + Log.f debug (fun fmt -> + Log.pf fmt "Failed to connect to %a:%d\n%!" + Ipaddr.pp_hum (IP.to_uipaddr daddr) dport); + Lwt.return (`Error `Timeout) + + let err_refused daddr dport = + Log.f debug (fun fmt -> + Log.pf fmt "Refused connection to %a:%d\n%!" + Ipaddr.pp_hum (IP.to_uipaddr daddr) dport); + Lwt.return (`Error `Refused) + + let ok x = Lwt.return (`Ok x) + let error_message = function | `Unknown msg -> msg | `Timeout -> "Timeout while attempting to connect" | `Refused -> "Connection refused" - let id t = Pcb.ip t + let err_rewrite = function + | `Error (`Bad_state _) -> `Error `Refused + | `Ok () as x -> x - let get_dest t = Pcb.get_dest t + let err_raise = function + | `Error (`Bad_state _) -> Lwt.fail Refused + | `Ok () -> Lwt.return_unit + + let id = Pcb.ip + let get_dest = Pcb.get_dest + let close t = Pcb.close t + let input = Pcb.input let read t = (* TODO better error interface in Pcb *) Pcb.read t >>= function - | None -> return `Eof - | Some t -> return (`Ok t) - - let write t view = - Pcb.write t view >>= fun () -> - return (`Ok ()) - - let writev t views = - Pcb.writev t views >>= fun () -> - return (`Ok ()) + | None -> Lwt.return `Eof + | Some t -> Lwt.return (`Ok t) - let write_nodelay t view = - Pcb.write_nodelay t view - - let writev_nodelay t views = - Pcb.writev_nodelay t views - - let close t = - Pcb.close t + let write t view = Pcb.write t view >|= err_rewrite + let writev t views = Pcb.writev t views >|= err_rewrite + let write_nodelay t view = Pcb.write_nodelay t view >>= err_raise + let writev_nodelay t views = Pcb.writev_nodelay t views >>= err_raise + let connect ipv4 = ok (Pcb.create ipv4) + let disconnect _ = Lwt.return_unit let create_connection tcp (daddr, dport) = Pcb.connect tcp ~dest_ip:daddr ~dest_port:dport >>= function - | `Timeout -> - (* Printf.printf "Failed to connect to %s:%d\n%!" *) - (* (Ipaddr.V4.to_string daddr) dport; *) - return (`Error `Timeout) - | `Rst -> - (* Printf.printf "Refused connection to %s:%d\n%!" *) - (* (Ipaddr.V4.to_string daddr) dport; *) - return (`Error `Refused) - | `Ok (fl, _) -> - return (`Ok fl) - - let input t ~listeners ~src ~dst buf = - Pcb.input t ~listeners ~src ~dst buf - - let connect ipv4 = - return (`Ok (Pcb.create ipv4)) - - let disconnect _ = - return_unit + | `Timeout -> err_timeout daddr dport + | `Rst -> err_refused daddr dport + | `Ok (fl, _) -> ok fl + end diff --git a/tcp/flow.mli b/tcp/flow.mli index 61332d478..50656b2ed 100644 --- a/tcp/flow.mli +++ b/tcp/flow.mli @@ -14,6 +14,11 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +val debug: Log.t + +exception Refused +(** {b NOTE}: to be removed in favor of a proper result type in + V1.write_nodelay and V1.writev_nodelay.*) module Make (IP:V1_LWT.IP)(TM:V1_LWT.TIME)(C:V1.CLOCK)(R:V1.RANDOM) : sig include V1_LWT.TCP diff --git a/tcp/log.ml b/tcp/log.ml new file mode 100644 index 000000000..144eaeb42 --- /dev/null +++ b/tcp/log.ml @@ -0,0 +1,64 @@ +(* + * Copyright (c) 2015 Thomas Gazagnaire + * + * 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. + *) + +type section = int + +type t = { + name: string; + id : int; + mutable enabled: bool; + mutable stats: bool; +} + +let c = ref 0 + +let write pp = + let msg = Format.flush_str_formatter () in + print_endline msg; + MProf.Trace.label msg + +let f t = + if t.enabled && t.stats then + fun pp -> Format.kfprintf write Format.str_formatter ("Tcp.%s%a: %t") t.name Stats.pp Stats.singleton pp + else if t.enabled then + fun pp -> Format.kfprintf write Format.str_formatter ("Tcp.%s: %t") t.name pp + else + fun _pp -> () + +let s t str = f t (fun fmt -> Format.pp_print_string fmt str) + +let create ?(enabled=false) ?(stats=true) name = + incr c; + { name; id = !c; stats; enabled } + +let enable t = t.enabled <- true +let disable t = t.enabled <- false +let enabled t = t.enabled +let name t = t.name +let stats t = t.stats +let set_stats t b = t.stats <- b + +let rec pp_print_list ?(pp_sep = Format.pp_print_cut) pp_v ppf = function + | [] -> () + | [v] -> pp_v ppf v + | v :: vs -> + pp_v ppf v; + pp_sep ppf (); + pp_print_list ~pp_sep pp_v ppf vs + + +let ps = Format.pp_print_string +let pf = Format.fprintf diff --git a/tcp/log.mli b/tcp/log.mli new file mode 100644 index 000000000..d3743ca04 --- /dev/null +++ b/tcp/log.mli @@ -0,0 +1,65 @@ +(* + * Copyright (c) 2015 Thomas Gazagnaire + * + * 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. + *) + +(** Logging module for TCP *) + +type t +(** The type for managing logging values. *) + +val create: ?enabled:bool -> ?stats:bool -> string -> t +(** Create a new section. By default, the section is disabled and the + stats are printed. *) + +val enable: t -> unit +(** Enable a section. *) + +val disable: t -> unit +(** Disable a section. *) + +val set_stats: t -> bool -> unit +(** Display the stats on every debug line. *) + +val stats: t -> bool +(** Check if the stats are displayed. *) + +val enabled: t -> bool +(** [enabled t] is [true] iff [t] is enabled. *) + +val name: t -> string +(** [name t] is the section name. *) + +val f: t -> (Format.formatter -> unit) -> unit +(** Print a formatted entry into a logger. *) + +val s: t -> string -> unit +(** Print a string into a logger. *) + +val ps: Format.formatter -> string -> unit +(** Same as {!format.pp_print_string}. *) + +val pf: Format.formatter -> ('a, Format.formatter, unit) format -> 'a +(** Same as {!Format.fprintf}, to be used with {!f}. *) + +val pp_print_list: + ?pp_sep:(Format.formatter -> unit -> unit) -> + (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'a list -> unit) +(** [pp_print_list ?pp_sep pp_v ppf l] prints the list [l]. [pp_v] is + used on the elements of [l] and each element is separated by + a call to [pp_sep] (defaults to {!pp_print_cut}). Does nothing on + empty lists. + + @since 4.02.0 +*) diff --git a/tcp/options.ml b/tcp/options.ml index 1e69a58e1..9683f7c88 100644 --- a/tcp/options.ml +++ b/tcp/options.ml @@ -158,15 +158,21 @@ let marshal buf ts = tlen+3 | _ -> assert false -let to_string = function - | Noop -> "Noop" - | MSS m -> Printf.sprintf "MSS=%d" m - | Window_size_shift b -> Printf.sprintf "Window>>%d" b - | SACK_ok -> "SACK_ok" - | SACK x -> Printf.(sprintf "SACK=(%s)" (String.concat "," - (List.map (fun (l,r) -> sprintf "%lu,%lu" l r) x))) - | Timestamp (a,b) -> Printf.sprintf "Timestamp(%lu,%lu)" a b - | Unknown (t,_) -> Printf.sprintf "%d?" t +let pp_sack fmt x = + let pp_v fmt (l, r) = Log.pf fmt "[%lu,%lu]" l r in + Log.pp_print_list pp_v fmt x -let prettyprint s = - Printf.sprintf "[ %s ]" (String.concat "; " (List.map to_string s)) +let pp fmt = function + | Noop -> Log.ps fmt "Noop" + | MSS m -> Log.pf fmt "MSS=%d" m + | Window_size_shift b -> Log.pf fmt "Window>> %d" b + | SACK_ok -> Log.ps fmt "SACK_ok" + | SACK x -> Log.pf fmt "SACK[%a]" pp_sack x + | Timestamp (a,b) -> Log.pf fmt "Timestamp(%lu,%lu)" a b + | Unknown (t,_) -> Log.pf fmt "%d?" t + +let pps fmt = function + | [] -> Log.ps fmt "[]" + | x -> + let ppl fmt x = Log.pp_print_list pp fmt x in + Log.pf fmt "[ %a ]" ppl x diff --git a/tcp/options.mli b/tcp/options.mli index 9cb35199a..2523093e9 100644 --- a/tcp/options.mli +++ b/tcp/options.mli @@ -29,4 +29,5 @@ type t = val marshal: Cstruct.t -> t list -> int val unmarshal : Cstruct.t -> t list -val prettyprint : t list -> string +val pp : Format.formatter -> t -> unit +val pps : Format.formatter -> t list -> unit diff --git a/tcp/pcb.ml b/tcp/pcb.ml index d34b0243c..b6ebee2e1 100644 --- a/tcp/pcb.ml +++ b/tcp/pcb.ml @@ -15,8 +15,29 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt -open Printf +open Lwt.Infix + +type error = [`Bad_state of State.tcpstate] + +type 'a result = [`Ok of 'a | `Error of error] +let ok x = Lwt.return (`Ok x) +let error s = Lwt.return (`Error (`Bad_state s)) + +let (>+=) x f = + x >>= function + | `Ok x -> f x + | `Error _ as e -> Lwt.return e + +let iter_s f l = + let rec aux = function + | [] -> ok () + | h::t -> f h >+= fun () -> aux t + in + aux l + + +let debug = Log.create "PCB" +let info = Log.create ~enabled:true ~stats:false "PCB" module Tcp_wire = Wire_structs.Tcp_wire @@ -46,8 +67,6 @@ struct ack: ACK.t; (* Ack state *) state: State.t; (* Connection state *) urx: User_buffer.Rx.t; (* App rx buffer *) - urx_close_t: unit Lwt.t; (* App rx close thread *) - urx_close_u: unit Lwt.u; (* App rx connection close wakener *) utx: UTX.t; (* App tx buffer *) } @@ -67,6 +86,14 @@ struct connects: (WIRE.id, (connection_result Lwt.u * Sequence.t)) Hashtbl.t; } + let pp_stats fmt t = + Log.pf fmt "[channels=%d listens=%d connects=%d]" + (Hashtbl.length t.channels) + (Hashtbl.length t.listens) + (Hashtbl.length t.connects) + + let with_stats name t fmt = Log.pf fmt "%s: %a" name pp_stats t + let ip { ip; _ } = ip let verify_checksum _ _ _ = true @@ -100,6 +127,7 @@ struct (* Queue up an immediate close segment *) let close pcb = + Log.s debug "TX.close"; match State.state pcb.state with | State.Established | State.Close_wait -> UTX.wait_for_flushed pcb.utx >>= fun () -> @@ -107,7 +135,10 @@ struct STATE.tick pcb.state (State.Send_fin (Window.tx_nxt wnd)); TXS.output ~flags:Segment.Fin pcb.txq [] ) - | _ -> return_unit + | _ -> + Log.f debug (fun fmt -> + Log.pf fmt "TX.close: skipping, state=%a" State.pp pcb.state); + Lwt.return_unit (* Thread that transmits ACKs in response to received packets, thus telling the other side that more can be sent, and @@ -137,7 +168,6 @@ struct (* Process an incoming TCP packet that has an active PCB *) let input _t pkt (pcb,_) = - (* URG_TODO: Deal correctly with incomming RST segment *) let sequence = Sequence.of_int32 (Tcp_wire.get_tcp_sequence pkt) in let ack_number = Sequence.of_int32 (Tcp_wire.get_tcp_ack_number pkt) @@ -145,10 +175,11 @@ struct let fin = Tcp_wire.get_fin pkt in let syn = Tcp_wire.get_syn pkt in let ack = Tcp_wire.get_ack pkt in + let rst = Tcp_wire.get_rst pkt in let window = Tcp_wire.get_tcp_window pkt in let data = Wire.get_payload pkt in let seg = - RXS.segment ~sequence ~fin ~syn ~ack ~ack_number ~window ~data + RXS.segment ~sequence ~fin ~syn ~rst ~ack ~ack_number ~window ~data in let { rxq; _ } = pcb in (* Coalesce any outstanding segments and retrieve ready segments *) @@ -157,12 +188,12 @@ struct (* Thread that spools the data into an application receive buffer, and notifies the ACK subsystem that new data is here *) let thread (pcb:pcb) ~rx_data = - let { wnd; ack; urx; urx_close_u; _ } = pcb in + let { wnd; ack; urx; } = pcb in (* Thread to monitor application receive and pass it up *) let rec rx_application_t () = Lwt_mvar.take rx_data >>= fun (data, winadv) -> begin match winadv with - | None -> return_unit + | None -> Lwt.return_unit | Some winadv -> if (winadv > 0) then ( Window.rx_advance wnd winadv; @@ -175,15 +206,15 @@ struct begin match data with | None -> STATE.tick pcb.state State.Recv_fin; - Lwt.wakeup urx_close_u (); User_buffer.Rx.add_r urx None >>= fun () -> - rx_application_t () + Lwt.return_unit | Some data -> let rec queue = function + | [] -> Lwt.return_unit | hd::tl -> User_buffer.Rx.add_r urx (Some hd) >>= fun () -> queue tl - | [] -> return_unit in + in queue data >>= fun _ -> rx_application_t () end @@ -193,13 +224,16 @@ struct module Wnd = struct - let thread ~urx:_ ~utx ~wnd:_ ~tx_wnd_update = + let thread ~urx:_ ~utx ~wnd:_ ~state ~tx_wnd_update = (* Monitor our transmit window when updates are received remotely, and tell the application that new space is available when it is blocked *) let rec tx_window_t () = Lwt_mvar.take tx_wnd_update >>= fun tx_wnd -> - UTX.free utx tx_wnd >>= fun () -> + begin match State.state state with + | State.Reset -> UTX.reset utx + | _ -> UTX.free utx tx_wnd + end >>= fun () -> tx_window_t () in tx_window_t () @@ -216,19 +250,22 @@ struct let clearpcb t id tx_isn = (* TODO: add more info to log msgs *) + Log.f debug (with_stats "removing pcb from tables" t); match hashtbl_find t.channels id with | Some _ -> - (* printf "TCP: removing pcb from tables\n%!";*) - Hashtbl.remove t.channels id + Log.s debug "removed from channels!!"; + Hashtbl.remove t.channels id; + Stats.decr_channel (); | None -> match hashtbl_find t.listens id with | Some (isn, _) -> if isn = tx_isn then ( - printf "TCP: removing incomplete listen pcb\n%!"; - Hashtbl.remove t.listens id + Log.s debug "removing incomplete listen pcb"; + Hashtbl.remove t.listens id; + Stats.decr_listen (); ) | None -> - printf "TCP: error in removing pcb - no such connection\n%!" + Log.s debug "error in removing pcb - no such connection" let pcb_allocs = ref 0 let th_allocs = ref 0 @@ -282,7 +319,6 @@ struct (* The user application receive buffer and close notification *) let rx_buf_size = Window.rx_wnd wnd in let urx = User_buffer.Rx.create ~max_size:rx_buf_size ~wnd in - let urx_close_t, urx_close_u = MProf.Trace.named_task "urx_close" in (* The window handling thread *) let tx_wnd_update = MProf.Trace.named_mvar_empty "tx_wnd_update" in (* Set up transmit and receive queues *) @@ -297,34 +333,52 @@ struct (* Set up ACK module *) let ack = ACK.t ~send_ack ~last:(Sequence.incr rx_isn) in (* Construct basic PCB in Syn_received state *) - let pcb = { state; rxq; txq; wnd; id; ack; urx; urx_close_t; urx_close_u; utx } in + let pcb = { state; rxq; txq; wnd; id; ack; urx; utx } in (* Compose the overall thread from the various tx/rx threads and the main listener function *) - let th = - (Tx.thread t pcb ~send_ack ~rx_ack) - (Rx.thread pcb ~rx_data) - (Wnd.thread ~utx ~urx ~wnd ~tx_wnd_update) + let tx_thread = (Tx.thread t pcb ~send_ack ~rx_ack) in + let rx_thread = (Rx.thread pcb ~rx_data) in + let wnd_thread = (Wnd.thread ~utx ~urx ~wnd ~state ~tx_wnd_update) in + let threads = [ tx_thread; rx_thread; wnd_thread ] in + let catch_and_cancel = function + | Lwt.Canceled -> () + | ex -> + (* cancel the other threads *) + List.iter Lwt.cancel threads; + Log.s info "ERROR: thread failure; terminating threads and closing connection"; + on_close (); + !Lwt.async_exception_hook ex in + List.iter (fun t -> Lwt.on_failure t catch_and_cancel) threads; + let th = Lwt.join threads in pcb_allocs := !pcb_allocs + 1; th_allocs := !th_allocs + 1; let fnpcb = fun _ -> pcb_frees := !pcb_frees + 1 in let fnth = fun _ -> th_frees := !th_frees + 1 in Gc.finalise fnpcb pcb; Gc.finalise fnth th; - return (pcb, th, opts) + Lwt.return (pcb, th, opts) let new_server_connection t params id pushf = + Log.f debug (with_stats "new-server-connection" t); new_pcb t params id >>= fun (pcb, th, opts) -> STATE.tick pcb.state State.Passive_open; STATE.tick pcb.state (State.Send_synack params.tx_isn); (* Add the PCB to our listens table *) - Hashtbl.replace t.listens id (params.tx_isn, (pushf, (pcb, th))); + if Hashtbl.mem t.listens id then ( + Log.s info "WARNING: connection already being attempted"; + Hashtbl.remove t.listens id; + Stats.decr_listen (); + ); + Hashtbl.add t.listens id (params.tx_isn, (pushf, (pcb, th))); + Stats.incr_listen (); (* Queue a SYN ACK for transmission *) let options = Options.MSS 1460 :: opts in TXS.output ~flags:Segment.Syn ~options pcb.txq [] >>= fun () -> - return (pcb, th) + Lwt.return (pcb, th) let new_client_connection t params id ack_number = + Log.f debug (with_stats "new-client-connection" t); let tx_isn = params.tx_isn in let params = { params with tx_isn = Sequence.incr tx_isn } in new_pcb t params id >>= fun (pcb, th, _) -> @@ -332,34 +386,40 @@ struct STATE.tick pcb.state (State.Send_syn tx_isn); (* Add the PCB to our connection table *) Hashtbl.add t.channels id (pcb, th); + Stats.incr_channel (); STATE.tick pcb.state (State.Recv_synack (Sequence.of_int32 ack_number)); (* xmit ACK *) TXS.output pcb.txq [] >>= fun () -> - return (pcb, th) + Lwt.return (pcb, th) let process_reset t id = + Log.f debug (with_stats "process-reset" t); match hashtbl_find t.connects id with | Some (wakener, _) -> (* URG_TODO: check if RST ack num is valid before it is accepted *) Hashtbl.remove t.connects id; + Stats.decr_connect (); Lwt.wakeup wakener `Rst; - return_unit + Lwt.return_unit | None -> match hashtbl_find t.listens id with | Some (_, (_, (pcb, th))) -> Hashtbl.remove t.listens id; + Stats.decr_listen (); STATE.tick pcb.state State.Recv_rst; Lwt.cancel th; - return_unit + Lwt.return_unit | None -> (* Incoming RST possibly to listen port - ignore per RFC793 pg65 *) - return_unit + Lwt.return_unit let process_synack t id ~pkt ~ack_number ~sequence ~options ~syn ~fin = + Log.f debug (with_stats "process-synack" t); match hashtbl_find t.connects id with | Some (wakener, tx_isn) -> if Sequence.(to_int32 (incr tx_isn)) = ack_number then ( Hashtbl.remove t.connects id; + Stats.decr_connect (); let tx_wnd = Tcp_wire.get_tcp_window pkt in let rx_wnd = 65535 in (* TODO: fix hardcoded value - it assumes that this value was @@ -370,18 +430,19 @@ struct id ack_number >>= fun (pcb, th) -> Lwt.wakeup wakener (`Ok (pcb, th)); - return_unit + Lwt.return_unit ) else (* Normally sending a RST reply to a random pkt would be in order but here we stay quiet since we are actively trying to connect this id *) - return_unit + Lwt.return_unit | None -> (* Incomming SYN-ACK with no pending connect and no matching pcb - send RST *) Tx.send_rst t id ~sequence ~ack_number ~syn ~fin let process_syn t id ~listeners ~pkt ~ack_number ~sequence ~options ~syn ~fin = + Log.f debug (with_stats "process-syn" t); match listeners id.WIRE.local_port with | Some pushf -> let tx_isn = Sequence.of_int ((Random.int 65535) + 0x1AFE0000) in @@ -393,29 +454,32 @@ struct { tx_wnd; sequence; options; tx_isn; rx_wnd; rx_wnd_scaleoffer } id pushf >>= fun _ -> - return_unit + Lwt.return_unit | None -> Tx.send_rst t id ~sequence ~ack_number ~syn ~fin let process_ack t id ~pkt ~ack_number ~sequence ~syn ~fin = + Log.f debug (with_stats "process-ack" t); match hashtbl_find t.listens id with | Some (tx_isn, (pushf, newconn)) -> if Sequence.(to_int32 (incr tx_isn)) = ack_number then ( (* Established connection - promote to active channels *) Hashtbl.remove t.listens id; + Stats.decr_listen (); Hashtbl.add t.channels id newconn; + Stats.incr_channel (); (* Finish processing ACK, so pcb.state is correct *) Rx.input t pkt newconn >>= fun () -> (* send new connection up to listener *) pushf (fst newconn) ) else (* No RST because we are trying to connect on this id *) - return_unit + Lwt.return_unit | None -> match hashtbl_find t.connects id with | Some _ -> (* No RST because we are trying to connect on this id *) - return_unit + Lwt.return_unit | None -> (* ACK but no matching pcb and no listen - send RST *) Tx.send_rst t id ~sequence ~ack_number ~syn ~fin @@ -438,12 +502,15 @@ struct | false, true -> process_ack t id ~pkt ~ack_number ~sequence ~syn ~fin | false, false -> (* What the hell is this packet? No SYN,ACK,RST *) - return_unit + Log.s debug "input-no-pcb: unknown packet"; + Lwt.return_unit (* Main input function for TCP packets *) let input t ~listeners ~src ~dst data = match verify_checksum src dst data with - | false -> printf "RX.input: checksum error\n%!"; return_unit + | false -> + Log.s debug "RX.input: checksum error"; + Lwt.return_unit | true -> let source_port = Tcp_wire.get_tcp_src_port data in let dest_port = Tcp_wire.get_tcp_dst_port data in @@ -470,7 +537,6 @@ struct min 4000 (min (Window.tx_mss pcb.wnd) (Int32.to_int (UTX.available pcb.utx))) - (* URG_TODO: raise exception if not in Established or Close_wait state *) (* Wait for more write space *) let write_wait_for pcb sz = UTX.wait_for pcb.utx (Int32.of_int sz) @@ -484,26 +550,23 @@ struct | av_len when av_len < len -> let first_bit = Cstruct.sub data 0 av_len in let remaing_bit = Cstruct.sub data av_len (len - av_len) in - writefn pcb wfn first_bit >>= fun () -> + writefn pcb wfn first_bit >+= fun () -> writefn pcb wfn remaing_bit - | _ -> wfn [data] + | _ -> + match State.state pcb.state with + | State.Established | State.Close_wait -> wfn [data] >>= ok + | e -> error e - (* URG_TODO: raise exception when trying to write to closed connection - instead of quietly returning *) (* Blocking write on a PCB *) let write pcb data = writefn pcb (UTX.write pcb.utx) data - let writev pcb data = Lwt_list.iter_s (fun d -> write pcb d) data - + let writev pcb data = iter_s (write pcb) data let write_nodelay pcb data = writefn pcb (UTX.write_nodelay pcb.utx) data - let writev_nodelay pcb data = - Lwt_list.iter_s (fun d -> write_nodelay pcb d) data + let writev_nodelay pcb data = iter_s (write_nodelay pcb) data (* Close - no more will be written *) - let close pcb = - Tx.close pcb + let close pcb = Tx.close pcb - let get_dest pcb = - pcb.id.WIRE.dest_ip, pcb.id.WIRE.dest_port + let get_dest pcb = pcb.id.WIRE.dest_ip, pcb.id.WIRE.dest_port let getid t dest_ip dest_port = (* TODO: make this more robust and recognise when all ports are gone *) @@ -537,20 +600,19 @@ struct in Time.sleep rxtime >>= fun () -> match hashtbl_find t.connects id with + | None -> Lwt.return_unit | Some (wakener, isn) -> if isn = tx_isn then if count > 3 then ( Hashtbl.remove t.connects id; + Stats.decr_connect (); Lwt.wakeup wakener `Timeout; - return_unit + Lwt.return_unit ) else ( Tx.send_syn t id ~tx_isn ~options ~window >>= fun () -> connecttimer t id tx_isn options window (count + 1) ) - else - return_unit - | None -> - return_unit + else Lwt.return_unit let connect t ~dest_ip ~dest_port = let id = getid t dest_ip dest_port in @@ -562,16 +624,20 @@ struct in let window = 5840 in let th, wakener = MProf.Trace.named_task "TCP connect" in - if Hashtbl.mem t.connects id then - printf "WARNING: connection already being attempted\n%!"; - Hashtbl.replace t.connects id (wakener, tx_isn); + if Hashtbl.mem t.connects id then ( + Log.s info "WARNING: connection already being attempted"; + Hashtbl.remove t.connects id; + Stats.decr_connect (); + ); + Hashtbl.add t.connects id (wakener, tx_isn); + Stats.incr_connect (); Tx.send_syn t id ~tx_isn ~options ~window >>= fun () -> - let _ = connecttimer t id tx_isn options window 0 in + Lwt.async (fun () -> connecttimer t id tx_isn options window 0); th (* Construct the main TCP thread *) let create ip = - let _ = Random.self_init () in + Random.self_init (); let localport = 10000 + (Random.int 10000) in let listens = Hashtbl.create 1 in let connects = Hashtbl.create 1 in diff --git a/tcp/pcb.mli b/tcp/pcb.mli index dcbf85990..42dd39f64 100644 --- a/tcp/pcb.mli +++ b/tcp/pcb.mli @@ -14,11 +14,17 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +type error = [`Bad_state of State.tcpstate] + +type 'a result = [`Ok of 'a | `Error of error] + +val info : Log.t +val debug: Log.t + module Make(Ip:V1_LWT.IP)(Time:V1_LWT.TIME)(Clock:V1.CLOCK)(Random:V1.RANDOM) : sig (** Overall state of the TCP stack *) type t - type pcb (** State for an individual connection *) @@ -47,13 +53,13 @@ module Make(Ip:V1_LWT.IP)(Time:V1_LWT.TIME)(Clock:V1.CLOCK)(Random:V1.RANDOM) : val write_wait_for : pcb -> int -> unit Lwt.t (* write - blocks if the write buffer is full *) - val write: pcb -> Cstruct.t -> unit Lwt.t - val writev: pcb -> Cstruct.t list -> unit Lwt.t + val write: pcb -> Cstruct.t -> unit result Lwt.t + val writev: pcb -> Cstruct.t list -> unit result Lwt.t (* version of write with Nagle disabled - will block if write buffer is full *) - val write_nodelay: pcb -> Cstruct.t -> unit Lwt.t - val writev_nodelay: pcb -> Cstruct.t list -> unit Lwt.t + val write_nodelay: pcb -> Cstruct.t -> unit result Lwt.t + val writev_nodelay: pcb -> Cstruct.t list -> unit result Lwt.t val create: Ip.t -> t (* val tcpstats: t -> unit *) diff --git a/tcp/segment.ml b/tcp/segment.ml index 448d550f9..9c6485c42 100644 --- a/tcp/segment.ml +++ b/tcp/segment.ml @@ -14,16 +14,38 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Printf -open Lwt +open Lwt.Infix + +let debug = Log.create "Segment" +let info = Log.create ~enabled:true ~stats:false "Segment" + +let lwt_sequence_add_l s seq = + let (_:'a Lwt_sequence.node) = Lwt_sequence.add_l s seq in + () + +let lwt_sequence_add_r s seq = + let (_:'a Lwt_sequence.node) = Lwt_sequence.add_r s seq in + () let peek_opt_l seq = match Lwt_sequence.take_opt_l seq with | None -> None | Some s -> - let _ = Lwt_sequence.add_l s seq in + lwt_sequence_add_l s seq; Some s +let peek_l seq = + match Lwt_sequence.take_opt_l seq with + | None -> assert false + | Some s -> + let _ = Lwt_sequence.add_l s seq in + s + +let rec reset_seq segs = + match Lwt_sequence.take_opt_l segs with + | None -> () + | Some _ -> reset_seq segs + (* The receive queue stores out-of-order segments, and can coalesece them on input and pass on an ordered list up the stack to the application. @@ -43,17 +65,19 @@ module Rx(Time:V1_LWT.TIME) = struct fin: bool; syn: bool; ack: bool; + rst: bool; ack_number: Sequence.t; window: int; } - let string_of_segment seg = - sprintf "TCP: RX seg seq=%s fin=%b syn=%b ack=%b acknum=%s win=%d" - (Sequence.to_string seg.sequence) seg.fin seg.syn seg.ack - (Sequence.to_string seg.ack_number) seg.window + let pp_segment fmt seg = + Log.pf fmt + "RX seg seq=%a fin=%b syn=%b ack=%b acknum=%a win=%d" + Sequence.pp seg.sequence seg.fin seg.syn seg.ack + Sequence.pp seg.ack_number seg.window - let segment ~sequence ~fin ~syn ~ack ~ack_number ~window ~data = - { sequence; fin; syn; ack; ack_number; window; data } + let segment ~sequence ~fin ~syn ~rst ~ack ~ack_number ~window ~data = + { sequence; fin; syn; ack; rst; ack_number; window; data } let len seg = (Cstruct.len seg.data) + @@ -78,11 +102,11 @@ module Rx(Time:V1_LWT.TIME) = struct let segs = S.empty in { segs; rx_data; tx_ack; wnd; state } - let to_string t = - String.concat ", " - (List.map (fun seg -> - sprintf "%lu[%d]" (Sequence.to_int32 seg.sequence) (len seg) - ) (S.elements t.segs)) + let pp fmt t = + let pp_v fmt seg = + Log.pf fmt "%a[%d]" Sequence.pp seg.sequence (len seg) + in + Log.pp_print_list pp_v fmt (S.elements t.segs) (* If there is a FIN flag at the end of this segment set. TODO: should look for a FIN and chop off the rest of the set as they @@ -96,11 +120,6 @@ module Rx(Time:V1_LWT.TIME) = struct try (S.max_elt q).syn with Not_found -> false *) - (* Determine the transmit window, from the last segment *) - let window q = - try (S.max_elt q).window - with Not_found -> 0 - let is_empty q = S.is_empty q.segs (* Given an input segment, the window information, and a receive @@ -109,8 +128,20 @@ module Rx(Time:V1_LWT.TIME) = struct let input (q:t) seg = (* Check that the segment fits into the valid receive window *) let force_ack = ref false in - if not (Window.valid q.wnd seg.sequence) then return_unit - else + if not (Window.valid q.wnd seg.sequence) then Lwt.return_unit + else if seg.rst then ( + StateTick.tick q.state State.Recv_rst; + (* Dump all the received but out of order frames *) + q.segs <- S.empty; + (* Signal TX side *) + let txalert ack_svcd = + if not ack_svcd then Lwt.return_unit + else Lwt_mvar.put q.tx_ack (Window.ack_seq q.wnd, Window.ack_win q.wnd) + in + txalert (Window.ack_serviced q.wnd) >>= fun () -> + (* Use the fin path to inform the application of end of stream *) + Lwt_mvar.put q.rx_data (None, Some 0) + ) else (* Insert the latest segment *) let segs = S.add seg q.segs in (* Walk through the set and get a list of contiguous segments *) @@ -138,25 +169,22 @@ module Rx(Time:V1_LWT.TIME) = struct q.segs <- waiting; (* If the segment has an ACK, tell the transmit side *) let tx_ack = - if seg.ack then begin + if seg.ack && (Sequence.geq seg.ack_number (Window.ack_seq q.wnd)) then begin StateTick.tick q.state (State.Recv_ack seg.ack_number); - let win = window ready in let data_in_flight = Window.tx_inflight q.wnd in - let seq_has_changed = (Window.ack_seq q.wnd) <> seg.ack_number in - let win_has_changed = (Window.ack_win q.wnd) <> win in - if ((data_in_flight && (Window.ack_serviced q.wnd || not seq_has_changed)) || + let ack_has_advanced = (Window.ack_seq q.wnd) <> seg.ack_number in + let win_has_changed = (Window.ack_win q.wnd) <> seg.window in + if ((data_in_flight && (Window.ack_serviced q.wnd || not ack_has_advanced)) || (not data_in_flight && win_has_changed)) then begin Window.set_ack_serviced q.wnd false; - Window.set_ack_seq q.wnd seg.ack_number; - Window.set_ack_win q.wnd win; - Lwt_mvar.put q.tx_ack (seg.ack_number, win) + Window.set_ack_seq_win q.wnd seg.ack_number seg.window; + Lwt_mvar.put q.tx_ack ((Window.ack_seq q.wnd), (Window.ack_win q.wnd)) end else begin - if (Sequence.gt seg.ack_number (Window.ack_seq q.wnd)) then - Window.set_ack_seq q.wnd seg.ack_number; - Window.set_ack_win q.wnd win; - return_unit + Window.set_ack_seq_win q.wnd seg.ack_number seg.window; + Lwt.return_unit end - end else return_unit in + end else Lwt.return_unit + in (* Inform the user application of new data *) let urx_inform = (* TODO: deal with overlapping fragments *) @@ -171,9 +199,9 @@ module Rx(Time:V1_LWT.TIME) = struct window as closed and tell the application *) (if fin ready then begin if S.cardinal waiting != 0 then - printf "TCP: warning, rx closed but waiting segs != 0\n%!"; + Log.s info "warning, rx closed but waiting segs != 0"; Lwt_mvar.put q.rx_data (None, Some 0) - end else return_unit) + end else Lwt.return_unit) in tx_ack <&> urx_inform @@ -224,8 +252,8 @@ module Tx (Time:V1_LWT.TIME) (Clock:V1.CLOCK) = struct mutable dup_acks: int; (* dup ack count for re-xmits *) } -(* let string_of_seg seg = - sprintf "[%s%d]" + let pp_seg fmt seg = + Log.pf fmt "[%s%d]" (match seg.flags with | No_flags ->"" | Syn ->"SYN " @@ -233,7 +261,6 @@ module Tx (Time:V1_LWT.TIME) (Clock:V1.CLOCK) = struct | Rst -> "RST " | Psh -> "PSH ") (len seg) -*) let ack_segment _ _ = () (* Take any action to the user transmit queue due to this being @@ -246,103 +273,115 @@ module Tx (Time:V1_LWT.TIME) (Clock:V1.CLOCK) = struct | State.Syn_rcvd _ | State.Established | State.Fin_wait_1 _ | State.Close_wait | State.Last_ack _ -> begin match peek_opt_l segs with - | None -> - Tcptimer.Stoptimer + | None -> Lwt.return Tcptimer.Stoptimer | Some rexmit_seg -> match rexmit_seg.seq = seq with | false -> - (* printf "PUSHING TIMER - new time = %f, new seq = %d\n%!" - (Window.rto wnd) (Sequence.to_int rexmit_seg.seq); *) - Tcptimer.ContinueSetPeriod (Window.rto wnd, rexmit_seg.seq) + Log.f debug (fun fmt -> + Log.pf fmt "PUSHING TIMER - new time=%f, new seq=%a" + (Window.rto wnd) Sequence.pp rexmit_seg.seq); + let ret = + Tcptimer.ContinueSetPeriod (Window.rto wnd, rexmit_seg.seq) + in + Lwt.return ret | true -> if (Window.max_rexmits_done wnd) then ( (* TODO - include more in log msg like ipaddrs *) - printf "Max retransmits reached for connection - terminating\n%!"; + Log.s info "Max retransmits reached for connection - terminating"; StateTick.tick st State.Timeout; - Tcptimer.Stoptimer + Lwt.return Tcptimer.Stoptimer ) else ( let flags = rexmit_seg.flags in let options = [] in (* TODO: put the right options *) - printf "TCP retransmission on timer seq = %d\n%!" - (Sequence.to_int rexmit_seg.seq); - (* FIXME: suspicious ignore *) - let _ = xmit ~flags ~wnd ~options ~seq rexmit_seg.data in + Log.f info (fun fmt -> + Log.pf fmt "TCP retransmission on timer seq = %d" + (Sequence.to_int rexmit_seg.seq)); + Lwt.async + (fun () -> xmit ~flags ~wnd ~options ~seq rexmit_seg.data); Window.backoff_rto wnd; - (* printf "PUSHING TIMER - new time = %f, new seq = %d\n%!" - (Window.rto wnd) (Sequence.to_int rexmit_seg.seq); *) - Tcptimer.ContinueSetPeriod (Window.rto wnd, rexmit_seg.seq) + Log.f debug (fun fmt -> + Log.pf fmt "PUSHING TIMER - new time = %f, new seq = %a" + (Window.rto wnd) Sequence.pp rexmit_seg.seq); + let ret = + Tcptimer.ContinueSetPeriod (Window.rto wnd, rexmit_seg.seq) + in + Lwt.return ret ) end - | _ -> - Tcptimer.Stoptimer - - let peek_l seq = - match Lwt_sequence.take_opt_l seq with - | None -> assert false - | Some s -> - let _ = Lwt_sequence.add_l s seq in - s + | _ -> Lwt.return Tcptimer.Stoptimer + + let rec clearsegs q ack_remaining segs = + match ack_remaining > 0l with + | false -> 0l (* here we return 0l instead of ack_remaining in case + the ack was an old packet in the network *) + | true -> + match Lwt_sequence.take_opt_l segs with + | None -> + Log.s info "Dubious ACK received"; + ack_remaining + | Some s -> + let seg_len = (Int32.of_int (len s)) in + match ack_remaining < seg_len with + | true -> + Log.s info "Partial ACK received"; + (* return uncleared segment to the sequence *) + lwt_sequence_add_l s segs; + ack_remaining + | false -> + ack_segment q s; + clearsegs q (Int32.sub ack_remaining seg_len) segs let rto_t q tx_ack = (* Listen for incoming TX acks from the receive queue and ACK segments in our retransmission queue *) let rec tx_ack_t () = let serviceack dupack ack_len seq win = - let rec clearsegs ack_remaining segs = - match ack_remaining > 0l with - | false -> 0l (* here we return 0l instead of ack_remaining in case - the ack was an old packet in the network *) - | true -> - match Lwt_sequence.take_opt_l segs with - | None -> - printf "TCP: Dubious ACK received\n%!"; - ack_remaining - | Some s -> - let seg_len = (Int32.of_int (len s)) in - match ack_remaining < seg_len with - | true -> - printf "TCP: Partial ACK received\n%!"; - (* return uncleared segment to the sequence *) - let _ = Lwt_sequence.add_l s segs in - ack_remaining - | false -> - ack_segment q s; - clearsegs (Int32.sub ack_remaining seg_len) segs - in - let partleft = clearsegs (Sequence.to_int32 ack_len) q.segs in + let partleft = clearsegs q (Sequence.to_int32 ack_len) q.segs in TX.tx_ack q.wnd (Sequence.sub seq (Sequence.of_int32 partleft)) win; - match (dupack || (Window.fast_rec q.wnd)) with + match dupack || Window.fast_rec q.wnd with | true -> q.dup_acks <- q.dup_acks + 1; - if (q.dup_acks = 3) || - ((q.dup_acks > 3) && ((Sequence.to_int32 ack_len) > 0l)) then begin + if q.dup_acks = 3 || + (q.dup_acks > 3 && Sequence.to_int32 ack_len > 0l) then begin (* alert window module to fall into fast recovery *) Window.alert_fast_rexmit q.wnd seq; (* retransmit the bottom of the unacked list of packets *) let rexmit_seg = peek_l q.segs in - (* printf "TCP fast retransmission seq = %d, dupack = %d\n%!" - (Sequence.to_int rexmit_seg.seq) (Sequence.to_int seq); *) + Log.f debug (fun fmt -> + Log.pf fmt "TCP fast retransmission seq=%a, dupack=%a" + Sequence.pp rexmit_seg.seq Sequence.pp seq); let { wnd; _ } = q in let flags=rexmit_seg.flags in let options=[] in (* TODO: put the right options *) - (* XXX: suspicisous ignore *) - let _ = q.xmit ~flags ~wnd ~options ~seq rexmit_seg.data in - () - end + Lwt.async + (fun () -> q.xmit ~flags ~wnd ~options ~seq rexmit_seg.data); + Lwt.return_unit + end else + Lwt.return_unit | false -> - q.dup_acks <- 0 + q.dup_acks <- 0; + Lwt.return_unit in Lwt_mvar.take tx_ack >>= fun _ -> Window.set_ack_serviced q.wnd true; let seq = Window.ack_seq q.wnd in let win = Window.ack_win q.wnd in - let ack_len = Sequence.sub seq (Window.tx_una q.wnd) in - let dupacktest () = - 0l = Sequence.to_int32 ack_len && - Window.tx_wnd_unscaled q.wnd = Int32.of_int win && - not (Lwt_sequence.is_empty q.segs) - in - serviceack (dupacktest ()) ack_len seq win; + begin match State.state q.state with + | State.Reset -> + (* Note: This is not stricly necessary, as the PCB will be + GCed later on. However, it helps removing pressure on + the GC. *) + reset_seq q.segs; + Lwt.return_unit + | _ -> + let ack_len = Sequence.sub seq (Window.tx_una q.wnd) in + let dupacktest () = + 0l = Sequence.to_int32 ack_len && + Window.tx_wnd_unscaled q.wnd = Int32.of_int win && + not (Lwt_sequence.is_empty q.segs) + in + serviceack (dupacktest ()) ack_len seq win + end >>= fun () -> (* Inform the window thread of updates to the transmit window *) Lwt_mvar.put q.tx_wnd_update win >>= fun () -> tx_ack_t () @@ -379,9 +418,9 @@ module Tx (Time:V1_LWT.TIME) (Clock:V1.CLOCK) = struct (* Queue up segment just sent for retransmission if needed *) let q_rexmit () = match seq_len > 0 with - | false -> return_unit + | false -> Lwt.return_unit | true -> - let _ = Lwt_sequence.add_r seg q.segs in + lwt_sequence_add_r seg q.segs; let p = Window.rto q.wnd in TT.start q.rexmit_timer ~p seg.seq in diff --git a/tcp/segment.mli b/tcp/segment.mli index 1278dd91f..1475f6715 100644 --- a/tcp/segment.mli +++ b/tcp/segment.mli @@ -16,6 +16,9 @@ (** TCP segments *) +val info : Log.t +val debug : Log.t + (** The receive queue stores out-of-order segments, and can coalesece them on input and pass on an ordered list up the stack to the application. @@ -28,17 +31,17 @@ module Rx (T:V1_LWT.TIME) : sig type segment (** Individual received TCP segment *) - val string_of_segment: segment -> string + val pp_segment: Format.formatter -> segment -> unit val segment: - sequence:Sequence.t -> fin:bool -> syn:bool -> ack:bool -> + sequence:Sequence.t -> fin:bool -> syn:bool -> rst:bool -> ack:bool -> ack_number:Sequence.t -> window:int -> data:Cstruct.t -> segment type t (** Queue of receive segments *) - val to_string: t -> string + val pp: Format.formatter -> t -> unit val create: rx_data:(Cstruct.t list option * int option) Lwt_mvar.t -> diff --git a/tcp/sequence.ml b/tcp/sequence.ml index c1dffea56..f99a44d6a 100644 --- a/tcp/sequence.ml +++ b/tcp/sequence.ml @@ -43,9 +43,10 @@ let sub a b = Int32.sub a b (* a++ *) let incr a = Int32.add a 1l -let compare a b = Int32.compare a b +let compare a b = Int32.compare a b let of_int32 t = t let of_int t = Int32.of_int t let to_int32 t = t let to_int t = Int32.to_int t -let to_string t = Printf.sprintf "%lu" t + +let pp fmt t = Format.fprintf fmt "%lu" t diff --git a/tcp/sequence.mli b/tcp/sequence.mli index 451dedcb5..0d6ea54aa 100644 --- a/tcp/sequence.mli +++ b/tcp/sequence.mli @@ -45,4 +45,5 @@ val of_int32: int32 -> t val of_int: int -> t val to_int32: t -> int32 val to_int: t -> int -val to_string: t -> string + +val pp: Format.formatter -> t -> unit diff --git a/tcp/state.ml b/tcp/state.ml index 58eeae781..a78613376 100644 --- a/tcp/state.ml +++ b/tcp/state.ml @@ -14,16 +14,18 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt +open Lwt.Infix open Printf +let debug = Log.create "State" + type action = | Passive_open | Recv_rst | Recv_synack of Sequence.t | Recv_ack of Sequence.t | Recv_fin - | Recv_finack of Sequence.t + (* | Recv_finack of Sequence.t *) | Send_syn of Sequence.t | Send_synack of Sequence.t | Send_rst @@ -42,6 +44,7 @@ type tcpstate = | Fin_wait_2 of int | Closing of Sequence.t | Time_wait + | Reset type close_cb = unit -> unit @@ -55,34 +58,34 @@ let t ~on_close = let state t = t.state -let string_of_action = function - | Passive_open -> "Passive_open" - | Recv_rst -> "Recv_rst" - | Recv_synack x -> "Recv_synack " ^ (Sequence.to_string x) - | Recv_ack x -> "Recv_ack " ^ (Sequence.to_string x) - | Recv_fin -> "Recv_fin" - | Recv_finack x -> "Recv_finack " ^ (Sequence.to_string x) - | Send_syn x -> "Send_syn " ^ (Sequence.to_string x) - | Send_synack x -> "Send_synack " ^ (Sequence.to_string x) - | Send_rst -> "Send_rst" - | Send_fin x -> "Send_fin " ^ (Sequence.to_string x) - | Timeout -> "Timeout" - -let string_of_tcpstate = function - | Closed -> "Closed" - | Listen -> "Listen" - | Syn_rcvd x -> "Syn_rcvd " ^ (Sequence.to_string x) - | Syn_sent x -> "Syn_sent " ^ (Sequence.to_string x) - | Established -> "Established" - | Close_wait -> "Close_wait" - | Last_ack x -> "Last_ack " ^ (Sequence.to_string x) - | Fin_wait_1 x -> "Fin_wait_1 " ^ (Sequence.to_string x) - | Fin_wait_2 i -> "Fin_wait_2 " ^ (string_of_int i) - | Closing x -> "Closing " ^ (Sequence.to_string x) - | Time_wait -> "Time_wait" - -let to_string t = - sprintf "{ %s }" (string_of_tcpstate t.state) +let pp_action fmt = function + | Passive_open -> Log.ps fmt "Passive_open" + | Recv_rst -> Log.ps fmt "Recv_rst" + | Recv_synack x -> Log.pf fmt "Recv_synack(%a)" Sequence.pp x + | Recv_ack x -> Log.pf fmt "Recv_ack(%a)" Sequence.pp x + | Recv_fin -> Log.ps fmt "Recv_fin" + (* | Recv_finack x -> pf fmt "Recv_finack(%a)" Sequence.pp x *) + | Send_syn x -> Log.pf fmt "Send_syn(%a)" Sequence.pp x + | Send_synack x -> Log.pf fmt "Send_synack(%a)" Sequence.pp x + | Send_rst -> Log.ps fmt "Send_rst" + | Send_fin x -> Log.pf fmt "Send_fin(%a)" Sequence.pp x + | Timeout -> Log.ps fmt "Timeout" + +let pp_tcpstate fmt = function + | Closed -> Log.ps fmt "Closed" + | Listen -> Log.ps fmt "Listen" + | Syn_rcvd x -> Log.pf fmt "Syn_rcvd(%a)" Sequence.pp x + | Syn_sent x -> Log.pf fmt "Syn_sent(%a)" Sequence.pp x + | Established -> Log.ps fmt "Established" + | Close_wait -> Log.ps fmt "Close_wait" + | Last_ack x -> Log.pf fmt "Last_ack(%a)" Sequence.pp x + | Fin_wait_1 x -> Log.pf fmt "Fin_wait_1(%a)" Sequence.pp x + | Fin_wait_2 i -> Log.pf fmt "Fin_wait_2(%d)" i + | Closing x -> Log.pf fmt "Closing(%a)" Sequence.pp x + | Time_wait -> Log.ps fmt "Time_wait" + | Reset -> Log.ps fmt "Reset" + +let pp fmt t = Log.pf fmt "{ %a }" pp_tcpstate t.state module Make(Time:V1_LWT.TIME) = struct @@ -90,29 +93,31 @@ module Make(Time:V1_LWT.TIME) = struct let time_wait_time = (* 30. *) 2. let rec finwait2timer t count timeout = - Time.sleep timeout - >>= fun () -> + Log.f debug (fun fmt -> Log.pf fmt "finwait2timer %.02f" timeout); + Time.sleep timeout >>= fun () -> match t.state with | Fin_wait_2 i -> + Log.s debug "finwait2timer: Fin_wait_2"; if i = count then begin t.state <- Closed; t.on_close (); - return_unit + Lwt.return_unit end else begin finwait2timer t i timeout end - | _ -> - return_unit + | s -> + Log.f debug (fun fmt -> Log.pf fmt "finwait2timer: %a" pp_tcpstate s); + Lwt.return_unit let timewait t twomsl = - Time.sleep twomsl - >>= fun () -> + Log.f debug (fun fmt -> Log.pf fmt "timewait %.02f" twomsl); + Time.sleep twomsl >>= fun () -> t.state <- Closed; + Log.s debug "timewait on_close"; t.on_close (); - return_unit + Lwt.return_unit let tick t (i:action) = - (* printf "%s - %s -> " (to_string t) (action_to_string i); *) let diffone x y = Sequence.incr y = x in let tstr s (i:action) = match s, i with @@ -127,27 +132,40 @@ module Make(Time:V1_LWT.TIME) = struct | Established, Recv_ack _ -> Established | Established, Send_fin a -> Fin_wait_1 a | Established, Recv_fin -> Close_wait - | Established, Timeout -> t.on_close (); Closed + | Established, Timeout -> t.on_close (); Closed + | Established, Recv_rst -> t.on_close (); Reset | Fin_wait_1 a, Recv_ack b -> if diffone b a then let count = 0 in - let _ = finwait2timer t count fin_wait_2_time in + Lwt.async (fun () -> finwait2timer t count fin_wait_2_time); Fin_wait_2 count else Fin_wait_1 a | Fin_wait_1 a, Recv_fin -> Closing a - | Fin_wait_1 a, Recv_finack b -> if diffone b a then Time_wait else Fin_wait_1 a | Fin_wait_1 _, Timeout -> t.on_close (); Closed + | Fin_wait_1 _, Recv_rst -> t.on_close (); Reset | Fin_wait_2 i, Recv_ack _ -> Fin_wait_2 (i + 1) - | Fin_wait_2 _, Recv_fin -> let _ = timewait t time_wait_time in Time_wait + | Fin_wait_2 _, Recv_rst -> t.on_close (); Reset + | Fin_wait_2 _, Recv_fin -> + Lwt.async (fun () -> timewait t time_wait_time); + Time_wait | Closing a, Recv_ack b -> if diffone b a then Time_wait else Closing a + | Closing _, Timeout -> t.on_close (); Closed + | Closing _, Recv_rst -> t.on_close (); Reset | Time_wait, Timeout -> t.on_close (); Closed | Close_wait, Send_fin a -> Last_ack a | Close_wait, Timeout -> t.on_close (); Closed + | Close_wait, Recv_rst -> t.on_close (); Reset | Last_ack a, Recv_ack b -> if diffone b a then (t.on_close (); Closed) else Last_ack a | Last_ack _, Timeout -> t.on_close (); Closed + | Last_ack _, Recv_rst -> t.on_close (); Reset | x, _ -> x in - t.state <- tstr t.state i - (* ; printf "%s\n%!" (to_string t) *) + let old_state = t.state in + let new_state = tstr t.state i in + Log.f debug (fun fmt -> + Log.pf fmt "%a - %a -> %a" + pp_tcpstate old_state pp_action i pp_tcpstate new_state); + t.state <- new_state; + end diff --git a/tcp/state.mli b/tcp/state.mli index 83b7886ac..fb5842f32 100644 --- a/tcp/state.mli +++ b/tcp/state.mli @@ -14,20 +14,22 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +val debug: Log.t + type action = | Passive_open | Recv_rst | Recv_synack of Sequence.t | Recv_ack of Sequence.t | Recv_fin - | Recv_finack of Sequence.t + (* | Recv_finack of Sequence.t *) | Send_syn of Sequence.t | Send_synack of Sequence.t | Send_rst | Send_fin of Sequence.t | Timeout -val string_of_action: action -> string +val pp_action: Format.formatter -> action -> unit type tcpstate = | Closed @@ -41,8 +43,9 @@ type tcpstate = | Fin_wait_2 of int | Closing of Sequence.t | Time_wait + | Reset -val string_of_tcpstate : tcpstate -> string +val pp_tcpstate : Format.formatter -> tcpstate -> unit type close_cb = unit -> unit @@ -55,7 +58,7 @@ type t = { val state : t -> tcpstate val t : on_close:close_cb -> t -val to_string: t -> string +val pp: Format.formatter -> t -> unit module Make(Time : V1_LWT.TIME) : sig val fin_wait_2_time : float diff --git a/tcp/stats.ml b/tcp/stats.ml new file mode 100644 index 000000000..818482869 --- /dev/null +++ b/tcp/stats.ml @@ -0,0 +1,89 @@ +(* + * Copyright (c) 2015 Thomas Gazagnaire + * + * 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. + *) + +module Gc = struct + + let gc = ref false + let enable () = gc := true + let disable () = gc := false + + let full = ref false + let full_major b = full := b + + let words () = + let t = Gc.stat () in + t.Gc.live_words / 1_000 + + let run_full_major () = if !full then Gc.full_major () + + let pp fmt () = + match !gc with + | false -> () + | true -> + run_full_major (); + Format.fprintf fmt "|%dk" (words ()) + +end + +type counter = MProf.Counter.t + +let value = MProf.Counter.value + +let pp_counter fmt t = Format.fprintf fmt "%d" (value t) + +type t = { + tcp_flows : counter; + tcp_listens : counter; + tcp_channels: counter; + tcp_connects: counter; + tcp_timers : counter; +} + +let pp fmt t = Format.fprintf fmt "[%a|%a|%a|%a%a]" + pp_counter t.tcp_timers + pp_counter t.tcp_listens + pp_counter t.tcp_channels + pp_counter t.tcp_connects + Gc.pp () + +let incr r = MProf.Counter.increase r 1 +let decr r = MProf.Counter.increase r (-1) + +let singleton = + let make name = MProf.Counter.create ~name () in + { + tcp_flows = make "Tcp.flows"; + tcp_listens = make "Tcp.listens"; + tcp_channels = make "Tcp.channels"; + tcp_connects = make "Tcp.connects"; + tcp_timers = make "Tcp.timers"; + } + +let incr_flow () = incr singleton.tcp_flows +let decr_flow () = decr singleton.tcp_flows + +let incr_listen () = incr singleton.tcp_listens +let decr_listen () = decr singleton.tcp_listens + +let incr_channel () = incr singleton.tcp_channels +let decr_channel () = decr singleton.tcp_channels + +let incr_connect () = incr singleton.tcp_connects +let decr_connect () = decr singleton.tcp_connects + +let incr_timer () = incr singleton.tcp_timers +let decr_timer () = decr singleton.tcp_timers + diff --git a/tcp/stats.mli b/tcp/stats.mli new file mode 100644 index 000000000..2335e3ca6 --- /dev/null +++ b/tcp/stats.mli @@ -0,0 +1,69 @@ +(* + * Copyright (c) 2015 Thomas Gazagnaire + * + * 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. + *) + +(** TCP Statistics *) + +type counter +(** The type for counters. *) + +val value: counter -> int +(** The counter value. [value t] is [{!incr} t] - [{!decrs} t].*) + +type t = { + tcp_flows : counter; + tcp_listens : counter; + tcp_channels: counter; + tcp_connects: counter; + tcp_timers : counter; +} + +val pp: Format.formatter -> t -> unit + +val incr_flow: unit -> unit +val decr_flow: unit -> unit + +val incr_listen: unit -> unit +val decr_listen: unit -> unit + +val incr_channel: unit -> unit +val decr_channel: unit -> unit + +val incr_connect: unit -> unit +val decr_connect: unit -> unit + +val incr_timer: unit -> unit +val decr_timer: unit -> unit + +val singleton: t + +module Gc: sig + (** Show GC stats *) + + val enable: unit -> unit + (** Show live works (in k) on every debug line. *) + + val disable: unit -> unit + + val full_major: bool -> unit + (** [full_major true] runs a [Gc.full_major] before printing any + debug statement. Quite expensive but can sometimes be useful. By + default, it is set to [false]. + + {b Note:} This is very slow, use it if you really need it! + + *) + +end diff --git a/tcp/tcp.mlpack b/tcp/tcp.mlpack index 7a605cd00..7d25cd8f2 100644 --- a/tcp/tcp.mlpack +++ b/tcp/tcp.mlpack @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: a1d3c8591e91c674b25051803a310a2d) +# DO NOT EDIT (digest: 195c2067e8367d1d5113b00734c29168) Options Wire State @@ -11,4 +11,6 @@ Segment User_buffer Pcb Flow +Stats +Log # OASIS_STOP diff --git a/tcp/tcptimer.ml b/tcp/tcptimer.ml index dcdbffe3c..aea1eca0d 100644 --- a/tcp/tcptimer.ml +++ b/tcp/tcptimer.ml @@ -14,7 +14,9 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt +open Lwt.Infix + +let debug = Log.create "TCP.Tcptimer" type tr = | Stoptimer @@ -22,7 +24,7 @@ type tr = | ContinueSetPeriod of (float * Sequence.t) type t = { - expire: (Sequence.t -> tr); + expire: (Sequence.t -> tr Lwt.t); mutable period: float; mutable running: bool; } @@ -32,17 +34,26 @@ module Make(Time:V1_LWT.TIME) = struct let running = false in {period; expire; running} - let rec timerloop t s = - Time.sleep t.period >>= fun () -> - match t.expire s with - | Stoptimer -> - t.running <- false; - return_unit - | Continue d -> - timerloop t d - | ContinueSetPeriod (p, d) -> - t.period <- p; - timerloop t d + let timerloop t s = + Log.s debug "timerloop"; + Stats.incr_timer (); + let rec aux t s = + Time.sleep t.period >>= fun () -> + t.expire s >>= function + | Stoptimer -> + Stats.decr_timer (); + t.running <- false; + Log.s debug "timerloop: stoptimer"; + Lwt.return_unit + | Continue d -> + Log.s debug "timerloop: continuer"; + aux t d + | ContinueSetPeriod (p, d) -> + Log.s debug "timerloop: coontinuesetperiod"; + t.period <- p; + aux t d + in + aux t s let period t = t.period @@ -50,8 +61,8 @@ module Make(Time:V1_LWT.TIME) = struct if not t.running then begin t.period <- p; t.running <- true; - let _ = timerloop t s in - return_unit + Lwt.async (fun () -> timerloop t s); + Lwt.return_unit end else - return_unit + Lwt.return_unit end diff --git a/tcp/tcptimer.mli b/tcp/tcptimer.mli index 36fc9e4f2..0bdb4e2f5 100644 --- a/tcp/tcptimer.mli +++ b/tcp/tcptimer.mli @@ -14,7 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -type t +type t type tr = | Stoptimer @@ -22,7 +22,9 @@ type tr = | ContinueSetPeriod of (float * Sequence.t) module Make(T:V1_LWT.TIME) : sig - val t : period: float -> expire: (Sequence.t -> tr) -> t + val t : period: float -> expire: (Sequence.t -> tr Lwt.t) -> t val start : t -> ?p:float -> Sequence.t -> unit Lwt.t end + +val debug: Log.t diff --git a/tcp/user_buffer.ml b/tcp/user_buffer.ml index 0525becbc..5824d8d5e 100644 --- a/tcp/user_buffer.ml +++ b/tcp/user_buffer.ml @@ -15,13 +15,20 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt +open Lwt.Infix + +let lwt_sequence_add_l s seq = + let (_:'a Lwt_sequence.node) = Lwt_sequence.add_l s seq in + () (* A bounded queue to receive data segments and let readers block on receiving them. Also supports a monitor that is informed when the queue size changes *) module Rx = struct + (* TODO: check that flow control works on the rx side - ie if the application + stops taking data the window closes so the other side stops sending *) + type t = { q: Cstruct.t option Lwt_sequence.t; wnd: Window.t; @@ -44,7 +51,7 @@ module Rx = struct let rx_wnd = max 0l (Int32.sub t.max_size t.cur_size) in Window.set_rx_wnd t.wnd rx_wnd; match t.watcher with - |None -> return_unit + |None -> Lwt.return_unit |Some w -> Lwt_mvar.put w t.cur_size let seglen s = @@ -62,14 +69,14 @@ module Rx = struct notify_size_watcher t >>= fun () -> th >>= fun () -> ignore(Lwt_sequence.add_r s t.q); - return_unit + Lwt.return_unit else match Lwt_sequence.take_opt_l t.readers with | None -> t.cur_size <- Int32.(add t.cur_size (of_int (seglen s))); ignore(Lwt_sequence.add_r s t.q); notify_size_watcher t | Some u -> - return (Lwt.wakeup u s) + Lwt.return (Lwt.wakeup u s) let take_l t = if Lwt_sequence.is_empty t.q then begin @@ -86,7 +93,7 @@ module Rx = struct |None -> () |Some w -> Lwt.wakeup w () end; - return s + Lwt.return s end let cur_size t = t.cur_size @@ -144,7 +151,7 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) = struct (* Wait until at least sz bytes are available in the window *) let rec wait_for t sz = if (available t) >= sz then begin - return_unit + Lwt.return_unit end else begin let th,u = MProf.Trace.named_task "User_buffer.wait_for" in @@ -172,7 +179,7 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) = struct (* Wait until the user buffer is flushed *) let rec wait_for_flushed t = if Lwt_sequence.is_empty t.buffer then begin - return_unit + Lwt.return_unit end else begin let th,u = MProf.Trace.named_task "User_buffer.wait_for_flushed" in @@ -185,15 +192,12 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) = struct let rec clear_buffer t = let rec addon_more curr_data l = match Lwt_sequence.take_opt_l t.buffer with - | None -> - (* printf "out at 1\n%!";*) - List.rev curr_data + | None -> List.rev curr_data | Some s -> let s_len = len s in match s_len > l with | true -> - (*printf "out at 2 %lu %lu\n%!" s_len l;*) - let _ = Lwt_sequence.add_l s t.buffer in + lwt_sequence_add_l s t.buffer; List.rev curr_data | false -> t.bufbytes <- Int32.sub t.bufbytes s_len; @@ -207,12 +211,12 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) = struct | true -> begin match avail_len with |0l -> (* return pkt to buffer *) - let _ = Lwt_sequence.add_l s t.buffer in + lwt_sequence_add_l s t.buffer; None |_ -> (* split buffer into a partial write *) let to_send,remaining = Cstruct.split s (Int32.to_int avail_len) in (* queue remaining view *) - let _ = Lwt_sequence.add_l remaining t.buffer in + lwt_sequence_add_l remaining t.buffer; t.bufbytes <- Int32.sub t.bufbytes avail_len; Some [to_send] end @@ -226,10 +230,10 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) = struct Some [s] in match Lwt_sequence.is_empty t.buffer with - | true -> return_unit + | true -> Lwt.return_unit | false -> match get_pkt_to_send () with - | None -> return_unit + | None -> Lwt.return_unit | Some pkt -> let b = compactbufs pkt in TXS.output ~flags:Segment.Psh t.txq b >>= fun () -> @@ -245,7 +249,7 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) = struct match datav with |[] -> begin match acc with - |[] -> return_unit + |[] -> Lwt.return_unit |_ -> transmit acc end |hd::tl -> @@ -269,7 +273,7 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) = struct t.bufbytes <- Int32.add t.bufbytes l; List.iter (fun data -> ignore(Lwt_sequence.add_r data t.buffer)) datav; if t.bufbytes < mss then - return_unit + Lwt.return_unit else clear_buffer t | true -> @@ -278,7 +282,7 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) = struct | true -> t.bufbytes <- Int32.add t.bufbytes l; List.iter (fun data -> ignore(Lwt_sequence.add_r data t.buffer)) datav; - return_unit + Lwt.return_unit | false -> let max_size = Window.tx_mss t.wnd in transmit_segments ~mss:max_size ~txq:t.txq datav @@ -289,14 +293,14 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) = struct | false -> t.bufbytes <- Int32.add t.bufbytes l; List.iter (fun data -> ignore(Lwt_sequence.add_r data t.buffer)) datav; - return_unit + Lwt.return_unit | true -> let avail_len = available_cwnd t in match avail_len < l with | true -> t.bufbytes <- Int32.add t.bufbytes l; List.iter (fun data -> ignore(Lwt_sequence.add_r data t.buffer)) datav; - return_unit + Lwt.return_unit | false -> let max_size = Window.tx_mss t.wnd in transmit_segments ~mss:max_size ~txq:t.txq datav @@ -304,10 +308,11 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) = struct let inform_app t = match Lwt_sequence.take_opt_l t.writers with - | None -> return_unit + | None -> Lwt.return_unit | Some w -> Lwt.wakeup w (); - return_unit + (* TODO: check if this should wake all writers not just one *) + Lwt.return_unit (* Indicate that more bytes are available for waiting writers. Note that sz does not take window scaling into account, and so @@ -317,4 +322,14 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) = struct clear_buffer t >>= fun () -> inform_app t + (* FIXME: duplicated code with Segment.reset_seq *) + let rec reset_seq segs = + match Lwt_sequence.take_opt_l segs with + | None -> () + | Some s -> reset_seq segs + + let reset t = + reset_seq t.buffer; + inform_app t + end diff --git a/tcp/user_buffer.mli b/tcp/user_buffer.mli index d1916ef86..5a16ce8bd 100644 --- a/tcp/user_buffer.mli +++ b/tcp/user_buffer.mli @@ -43,4 +43,5 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) : sig val write: t -> Cstruct.t list -> unit Lwt.t val write_nodelay: t -> Cstruct.t list -> unit Lwt.t val free: t -> int -> unit Lwt.t + val reset: t -> unit Lwt.t end diff --git a/tcp/window.ml b/tcp/window.ml index 9ff05b282..652f5ed3c 100644 --- a/tcp/window.ml +++ b/tcp/window.ml @@ -14,7 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Printf +let debug = Log.create "Window" type t = { tx_mss: int; @@ -61,12 +61,14 @@ let alpha = 0.125 (* see RFC 2988 *) let beta = 0.25 (* see RFC 2988 *) (* To string for debugging *) -let to_string t = - sprintf "rx_nxt=%s rx_nxt_inseq=%s tx_nxt=%s rx_wnd=%lu tx_wnd=%lu snd_una=%s" - (Sequence.to_string t.rx_nxt) - (Sequence.to_string t.rx_nxt_inseq) - (Sequence.to_string t.tx_nxt) - t.rx_wnd t.tx_wnd (Sequence.to_string t.snd_una) +let pp fmt t = + Log.pf fmt + "rx_nxt=%a rx_nxt_inseq=%a tx_nxt=%a rx_wnd=%lu tx_wnd=%lu snd_una=%a" + Sequence.pp t.rx_nxt + Sequence.pp t.rx_nxt_inseq + Sequence.pp t.tx_nxt + t.rx_wnd t.tx_wnd + Sequence.pp t.snd_una (* Initialise the sequence space *) let t ~rx_wnd_scale ~tx_wnd_scale ~rx_wnd ~tx_wnd ~rx_isn ~tx_mss ~tx_isn = @@ -111,8 +113,9 @@ let valid t seq = let redge = Sequence.(add t.rx_nxt (of_int32 t.rx_wnd)) in let ledge = Sequence.(sub t.rx_nxt (of_int32 t.max_rx_wnd)) in let r = Sequence.between seq ledge redge in - (* printf "TCP_window: valid check for seq=%s for range %s[%lu] res=%b\n%!" - (Sequence.to_string seq) (Sequence.to_string t.rx_nxt) t.rx_wnd r; *) + (* PERF: ~5% perf degradation if commenting out that line + Log.f debug "valid: seq=%a range=%a[%lu] res=%b" + Sequence.pp seq Sequence.pp t.rx_nxt t.rx_wnd r; *) r (* Advance received packet sequence number *) @@ -134,10 +137,10 @@ let ack_seq t = t.ack_seq let ack_win t = t.ack_win let set_ack_serviced t v = t.ack_serviced <- v -let set_ack_seq t s = +let set_ack_seq_win t s w = MProf.Counter.increase count_ackd_segs (Sequence.(sub s t.ack_seq |> to_int)); - t.ack_seq <- s -let set_ack_win t w = t.ack_win <- w + t.ack_seq <- s; + t.ack_win <- w (* TODO: scale the window down so we can advertise it correctly with window scaling on the wire *) @@ -170,7 +173,7 @@ module Make(Clock:V1.CLOCK) = struct if Sequence.gt r t.snd_una then t.snd_una <- r; if Sequence.geq r t.fast_rec_th then begin - (* printf "EXITING fast recovery\n%!"; *) + Log.s debug "EXITING fast recovery"; t.cwnd <- t.ssthresh; t.fast_recovery <- false; end else begin @@ -224,14 +227,10 @@ let alert_fast_rexmit t _ = let inflight = Sequence.to_int32 (Sequence.sub t.tx_nxt t.snd_una) in let newssthresh = max (Int32.div inflight 2l) (Int32.of_int (t.tx_mss * 2)) in let newcwnd = Int32.add newssthresh (Int32.of_int (t.tx_mss * 2)) in - (* - printf "ENTERING fast recovery inflight=%d, ssthresh=%d -> %d, cwnd=%d -> %d\n%!" - (Int32.to_int inflight) - (Int32.to_int t.ssthresh) - (Int32.to_int newssthresh) - (Int32.to_int t.cwnd) - (Int32.to_int newcwnd); - *) + Log.f debug (fun fmt -> + Log.pf fmt "ENTERING fast recovery inflight=%ld, ssthresh=%ld -> %ld, \ + cwnd=%ld -> %ld" + inflight t.ssthresh newssthresh t.cwnd newcwnd); t.fast_recovery <- true; t.fast_rec_th <- t.tx_nxt; t.ssthresh <- newssthresh; diff --git a/tcp/window.mli b/tcp/window.mli index 47f9405d4..2edff9990 100644 --- a/tcp/window.mli +++ b/tcp/window.mli @@ -14,10 +14,11 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +val debug: Log.t type t -val to_string: t -> string +val pp: Format.formatter -> t -> unit val t : rx_wnd_scale:int -> tx_wnd_scale:int -> rx_wnd:int -> tx_wnd:int -> rx_isn:Sequence.t -> tx_mss:int option -> tx_isn:Sequence.t -> t @@ -44,8 +45,7 @@ val ack_seq : t -> Sequence.t val ack_win : t -> int val set_ack_serviced : t -> bool -> unit -val set_ack_seq : t -> Sequence.t -> unit -val set_ack_win : t -> int -> unit +val set_ack_seq_win : t -> Sequence.t -> int -> unit (* rx_wnd: number of bytes we are willing to accept *) val rx_wnd : t -> int32 diff --git a/tcp/wire.ml b/tcp/wire.ml index 3844607af..6159585fd 100644 --- a/tcp/wire.ml +++ b/tcp/wire.ml @@ -14,7 +14,9 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Lwt +open Lwt.Infix + +let debug = Log.create "Wire" module Tcp_wire = Wire_structs.Tcp_wire @@ -75,13 +77,17 @@ module Make (Ip:V1_LWT.IP) = struct Tcp_wire.set_tcp_urg_ptr tcp_frame 0; let checksum = Ip.checksum frame (tcp_frame :: datav) in Tcp_wire.set_tcp_checksum tcp_frame checksum; - (* printf "TCP.xmit checksum %04x %s.%d->%s.%d rst %b syn %b fin %b psh %b seq - %lu ack %lu %s datalen %d datafrag %d dataoff %d olen %d\n%!" checksum - (ipv4_addr_to_string id.local_ip) id.local_port - (ipv4_addr_to_string id.dest_ip) id.dest_port - rst syn fin psh sequence ack_number (Options.prettyprint options) - (Cstruct.lenv datav) (List.length datav) data_off options_len; - *) - MProf.Counter.increase count_tcp_to_ip (Cstruct.lenv datav); + (* PERF: uncommenting the next expression results in ~10% perf degradation + Log.f debug (fun fmt -> + Log.pf fmt + "xmit checksum=%04x %a.%d->%a.%d rst=%b syn=%b fin=%b psh=%b \ + seq=%lu ack=%lu options=%a datalen=%d datafrag=%d dataoff=%d olen=%d" + checksum + Ipaddr.pp_hum (Ip.to_uipaddr id.local_ip) id.local_port + Ipaddr.pp_hum (Ip.to_uipaddr id.dest_ip) id.dest_port + rst syn fin psh sequence ack_number Options.pps options + (Cstruct.lenv datav) (List.length datav) data_off options_len); *) + MProf.Counter.increase count_tcp_to_ip (Cstruct.lenv datav + (if syn then 1 else 0)); Ip.writev ip frame datav + end diff --git a/tcp/wire.mli b/tcp/wire.mli index ef9332e2c..9eea7693f 100644 --- a/tcp/wire.mli +++ b/tcp/wire.mli @@ -14,6 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +val debug: Log.t val get_options : Cstruct.t -> Options.t list val set_options : Cstruct.t -> Options.t list -> int val get_payload : Cstruct.t -> Cstruct.t diff --git a/tests/pcap/.gitignore b/tests/pcap/.gitignore new file mode 100644 index 000000000..84650ba70 --- /dev/null +++ b/tests/pcap/.gitignore @@ -0,0 +1 @@ +*.pcap diff --git a/unix/arpv4-unix.mldylib b/unix/arpv4-unix.mldylib new file mode 100644 index 000000000..74037a99c --- /dev/null +++ b/unix/arpv4-unix.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: bd276d9e614e181a8fa43a28216c8494) +Arpv4_unix +# OASIS_STOP diff --git a/unix/arpv4-unix.mllib b/unix/arpv4-unix.mllib new file mode 100644 index 000000000..74037a99c --- /dev/null +++ b/unix/arpv4-unix.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: bd276d9e614e181a8fa43a28216c8494) +Arpv4_unix +# OASIS_STOP diff --git a/unix/arpv4_unix.ml b/unix/arpv4_unix.ml new file mode 100644 index 000000000..a278ebec5 --- /dev/null +++ b/unix/arpv4_unix.ml @@ -0,0 +1,2 @@ +module Arpv4 = Arpv4.Make(Ethif_unix)(Clock)(OS.Time) +include Arpv4 diff --git a/unix/ipv4_unix.ml b/unix/ipv4_unix.ml index 81ac6964b..9394c4d77 100644 --- a/unix/ipv4_unix.ml +++ b/unix/ipv4_unix.ml @@ -1 +1 @@ -include Ipv4.Make(Ethif_unix)(Clock)(OS.Time) +include Ipv4.Make(Ethif_unix)(Arpv4_unix) diff --git a/unix/tcpip_stack_unix.ml b/unix/tcpip_stack_unix.ml index a4aec8450..34f9c1f9f 100644 --- a/unix/tcpip_stack_unix.ml +++ b/unix/tcpip_stack_unix.ml @@ -14,12 +14,15 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +(* module Arpv4_unix = Arpv4.Make(Ethif_unix)(Clock)(OS.Time) *) + include Tcpip_stack_direct.Make (Console_unix) (OS.Time) (Random) (Netif) (Ethif_unix) + (Arpv4_unix) (Ipv4_unix) (Udpv4_unix) (Tcpv4_unix.Flow)