[ { "path": ".github/dependabot.yml", "content": "version: 2\nupdates:\n - package-ecosystem: github-actions\n directory: /\n schedule:\n interval: weekly\n" }, { "path": ".github/workflows/main.yml", "content": "name: Builds, tests & co\n\non:\n pull_request:\n push:\n schedule:\n # Prime the caches every Monday\n - cron: 0 1 * * MON\n\npermissions: read-all\n\njobs:\n build:\n strategy:\n fail-fast: false\n matrix:\n os:\n - macos-latest\n - ubuntu-latest\n ocaml-compiler:\n # NOTE: use just \"5\" when bisect_ppx becomes compatible with ocaml >= 5.4\n - 5.3\n - 4\n\n runs-on: ${{ matrix.os }}\n\n steps:\n - name: Checkout tree\n uses: actions/checkout@v4\n\n - name: Set-up OCaml\n uses: ocaml/setup-ocaml@v3\n with:\n ocaml-compiler: ${{ matrix.ocaml-compiler }}\n\n - run: opam install . --deps-only --with-test\n\n - run: opam exec -- dune build\n\n - run: opam exec -- dune runtest\n\n unikernel-example:\n strategy:\n fail-fast: false\n matrix:\n mode:\n - qubes\n - unix\n - virtio\n\n defaults:\n run:\n working-directory: examples/unikernel\n\n runs-on: ubuntu-latest\n\n steps:\n - name: Checkout tree\n uses: actions/checkout@v4\n\n - name: Set-up OCaml\n uses: ocaml/setup-ocaml@v3\n with:\n ocaml-compiler: 4\n opam-pin: false\n\n - run: opam install mirage\n - run: opam exec -- mirage configure -t ${{ matrix.mode }}\n - run: opam exec -- make depend\n - run: opam exec -- make\n" }, { "path": ".gitignore", "content": "_build\n.merlin\n*.install\n" }, { "path": "CHANGES.md", "content": "### v9.0.1 (2025-04-15)\n\n* Unix: avoid spurious warnings when the fd is scheduled to be closed (#527\n @hannesm, review by @djs55 @reynir)\n* Unix: if recvfrom (UDP sockets) returns 0 (signalling EOF), do not try to read\n again (avoids busy loops) (#528 @hannesm, review by @reynir)\n\n### v9.0.0 (2025-02-06)\n\n* Adapt to mirage-crypto-rng 1.2.0 API (#526 @hannesm)\n* Use dune variants instead of functors for TIME, MCLOCK, PCLOCK\n -- now using mirage-sleep and mirage-mtime (#526 @hannesm)\n\n### v8.2.0 (2024-08-22)\n\n* Use `mirage-crypto.1.0` & `randomconv.0.2` (@hannesm, #521)\n* Update unikernels to `mirage.4.6.0` (@hannesm, @reynir, @smorimoto, #522)\n* Update our CI system (@samoht, @smorimoto, #519, #520)\n\n### v8.1.0 (2024-05-29)\n\n* adapt to mirage-vnetif 0.6.2 changes (#517 @hannesm)\n* Add `type prefix = Ipaddr.Prefix.t` and `IP.configured_ips : t -> prefix`\n to the IP layers (#516 @hannesm)\n* Mark `get_ips` as deprecated, use `configured_ips` instead (#516 @hannesm)\n\n### v8.0.2 (2024-05-08)\n\n* remove mirage-random-test dependency (#514 @hannesm)\n* remove calls to mirage-profile in tests, now support mirage-vnetif 0.6.1\n (#514 @hannesm)\n\n### v8.0.1 (2024-03-26)\n\n* TCP: add `src : flow -> ipaddr * int`, implemented by `getsockname` on unix\n (#511 @hannesm)\n* TCP unix stack: increase TCP buffer size (was 4096, is now 65536)\n (#510 @edwintorok)\n* TCP: adapt to mirage-flow 4.0:\n add ``val shutdown : flow -> [ `read | `write | `read_write ] -> unit Lwt.t``\n (#512 @hannesm, review by @djs55)\n\n### v8.0.0 (2023-03-17)\n\n* TCP: add ID for PCB for connection tracking (#495 @TheLortex)\n* Unix stack, UDP: copy buffer before passing it to client (#502 @reynir)\n\n* API renamings (due to ppx_cstruct removal): accessors such as\n Icmpv4_wire.get_icmpv4_ty are now Icmpv4_wire.get_ty (\"_icmpv4\" is removed)\n (#505)\n\n* API change: remove deprecated V4-only and V6-only stack\n The module types Stack.V4 and Stack.V6 no longer exist\n The bindings Stack.V4V6.listen_udp and listen_tcp have been removed\n (#494 @hannesm)\n\n* Use Cstruct.to_string instead of deprecated Cstruct.copy (#506 @hannesm)\n* Remove ppx_cstruct dependency (#505 @hannesm)\n* Remove mirage-profile dependency (#504 @hannesm)\n* Remove Mirage3 cross-compilation runes (#507 @hannesm)\n* opam: add lower bounds for cmdliner and alcotest (#506 @hannesm)\n\n### v7.1.2 (2022-07-27)\n\n* TCP: fix memory leaks on connection close in three scenarios (#489 @TheLortex)\n - simultanous close: set up the timewait timer in the `Closing(1) - Recv_ack(2) -> Time_wait` \n state transition\n - client sends a RST instead of a FIN: enable sending a challenge ACK even when the reception\n thread is stopped\n - client doesn't ACK server's FIN: enable the retransmit timer in the `Closing(_)` state\n\n### v7.1.1 (2022-05-24)\n\n* Ndpv6: demote more logs to debug level (#480 @reynir)\n* Ndpv6: set RS opt header (#482 @reynir)\n* Icmpv6: add redirect parsing (#481 @reynir)\n* Improve log messages of connect and disconnect of various layers and stacks:\n separate IP addresses with \", \" (#485 @hannesm)\n* TCP log sources: prefix \"tcp\" to distinguish them (#484 @reynir)\n\n### v7.1.0 (2022-03-23)\n\n* Work with MSVC compiler (@jonahbeckford, #476)\n* Skip `Lwt_bytes` UDP tests on Windows (@MisterDA, #469)\n* Run `PKG_CONFIG_PATH` through cypath (@MisterDA, #469)\n* Add Windows CI via GitHub Action (@MisterDA, #469)\n* Remove `which` command and replace it by `command -v` (@hannesm, #472)\n* Fix some typos (@MisterDA, #471)\n* Update binaries to `cmdliner.1.1.0` (@dinosaure, #475)\n* Be able to extract via _functor_/`functoria` the TCP/IP stack (@dinosaure, #474)\n* Remove missing deprecated usage of `Cstruct.len` (@dinosaure, #477)\n\n### v7.0.1 (2021-12-17)\n\n* Fix cancellation of Unix socket when we don't use `Stack.connect` (@dinosaure, @hannesm, #466)\n\n### v7.0.0 (2021-12-10)\n\n* Fix memory leak in processing RST packets (#460 @balrajsingh, reported in\n #456 by @dinosaure)\n* Move module types (IP, UDP, TCP, STACK, ICMP) into tcpip core library\n (#463 @hannesm)\n* API breakage: `Tcpip_checksum` is now part of tcpip.checksum (used to be\n part of tcpip #463 @hannesm)\n* API breakage: tcpip.unix has been removed (#463 @hannesm)\n* Use Lwt.pause instead of deprecated `Lwt_{unix,main}.yield` (#461 @dinosaure)\n\n### v6.4.0 (2021-11-11)\n\n* Adapt to mirage-protocols 6.0.0 API (#457 @hannesm)\n* TCP and UDP now have a listen and unlisten function (fixes #452)\n* type ipinput (in TCP and UDP) and listener (in TCP) have been removed\n\n### v6.3.0 (2021-10-25)\n\n* Use Cstruct.length instead of deprecated Cstruct.len (#454 @hannesm)\n* Avoid deprecated Fmt functions (#455 @hannesm)\n* Remove rresult dependency (#455 @hannesm)\n* Require OCaml 4.08\n* Record TCP statistics via metrics library (#455 @hannesm)\n\n### v6.2.0 (2021-07-19)\n\n* This allows to listen on the same port as sending via UDP in the dual socket\n stack, and avoids file descriptor leaks in the socket stack.\n* Socket stack: avoid file descriptor leaks (remember opened file descriptors in\n data structure, close them in disconnect)\n (#449 @reynir @hannesm, fixes #446 #450)\n* Socket stack: convert an incoming packet on a dual socket to v4 source IP if\n received via IPv4 (#451 @reynir @hannesm)\n* Allow freestanding compilation without opam (#447 @sternenseemann)\n* Adapt to alcotest 1.4.0 breaking change (#448 @CraigFE)\n\n### v6.1.0 (2021-03-17)\n\n* checksum stubs: Drop `caml_` from their name (@hannesm, #445)\n* Add cancellation on `tcpip.stack-socket` (@dinosaure, @talex5, @hannesm, #443)\n* Ensure that listen really binds the given socket before\n creating a task on `tcpip.stack-socket` (@dinosaure, @hannesm, #439)\n* Add `ppx_cstruct` as a dependency (@hannesm, @dinosaure, #439)\n* Upgrade to ocamlformat.0.17.0 (@dinosaure, #442)\n* Drop the support of OCaml 4.08.0 (@dinosaure, #442)\n* Use the usual layout to compile freestanding C stubs and link them to\n a Solo5 unikernel (@dinosaure, @hannesm, #441)\n **breaking changes**\n C stubs are prepended by `mirage_`. Symbols such as checksum's\n symbols are `caml_mirage_tcpip_*` instead of `caml_tcpip_*`\n `tcpip.unix` is a fake sub-package and user does not it anymore, he can\n safely remove it from its project.\n* Conflict with `< ocaml-freestanding.0.4.1` (@hannesm, #441)\n\n### v6.0.0 (2020-11-30)\n\n* Dual IPv4 and IPv6 socket and direct stack support, now requires\n mirage-stack 2.2.0 and mirage-protocols 5.0.0 (#433 @hannesm)\n* The above change also unified arguments passed to connect functions which\n are API-breaking changes\n* IPv6 waits for timeout after sending neighbour advertisement (for duplicate\n address detection)\n* Remove Xen cross-compilation runes, with mirage-xen 6.0.0 they're provided\n by mirage-xen (#434 @hannesm)\n* Move to dune 2.7.0 (and bisect instrumentation if desired) (#436 @hannesm)\n\n### v5.0.1 (2020-09-22)\n\n* Assorted IPv6 improvements (#428 #431 #432 @MagnusS @hannesm)\n - set length in packets to be sent\n - preserve updated ctx from Ndv6.handle\n - fix ICMP checksum computation\n - implement Mirage_stack.V6 signature\n - add connect, mtu, iperf tests\n - fix DAD protocol implementation (and test it)\n - avoid out of bounds accesses of IPv6 packets (check length before accessing)\n* Fix 32 bit issues (@MagnusS)\n* Implement stack-direct and tcp disconnect: tear down existing connections (#429 @hannesm)\n* Treat broadcast address of network as broadcast as well (#430 @hannesm, reported in #427)\n\n### v5.0.0 (2020-06-19)\n\n* Static_ipv4.connect API change: takes a cidr:Ipaddr.V4.Prefix.t instead of\n ip:Ipaddr.V4.t and network:Ipaddr.V4.Prefix.t (#426 @hannesm)\n* Adapt to ipaddr 5.0.0 API changes (#426 @hannesm)\n\n### v4.1.0 (2020-02-08)\n\n* Revert \"Ipv4.Fragments use a Lru.M.t instead of Lru.F.t\" (#423 by @hannesm)\n A Lru.M.t allocates a Hashtbl.t of size = capacity (= 256 * 1024 in our case),\n this leads to excessive ~2MB memory consumption for each Fragment cache,\n reported by @xaki23 in mirage/qubes-mirage-firewall#93\n* use SOCK_RAW for an ICMP socket in the unix sockets API (previously used\n SOCK_DGRAM which did not work)\n reported by @justinc1 in #358, fixed in #424 by @hannesm\n* tcp is now compatible with lwt >= 5.0.0 (where Lwt.async requires a function\n of (unit -> unit Lwt.t) (#370 #425 @cfcs @hannesm, issue #392 @emillon)\n* Add a dependency on dune-configurator to support dune 2.0.0 (#421 @avsm)\n\n### v4.0.0 (2019-11-01)\n\n* Adapt to mirage-protocols 4.0.0, mirage-net 3.0.0, mirage-time 2.0.0,\n mirage-clock 3.0.0, mirage-stack 2.0.0 interface changes (#420 @hannesm)\n* Revise Static_ipv4.connect signature (for more safety):\n val connect : ip:(Ipaddr.V4.Prefix.t * Ipaddr.V4.t) -> ?gateway:Ipaddr.V4.t ->\n ?fragment_cache_size:int -> E.t -> A.t -> t Lwt.t\n it used to be:\n val connect : ?ip:Ipaddr.V4.t -> ?network:Ipaddr.V4.Prefix.t ->\n ?gateway:Ipaddr.V4.t option -> C.t -> E.t -> A.t -> t Lwt.t\n The clock `C.t` is gone (due to mirage-clock 3.0.0), `~ip` and `~network` are\n now required and passed as pair `~ip`. The optional argument `?gateway` is\n of type Ipaddr.V4.t. The new optional labeled argument `~fragment_cache_size`\n specifies the byte size of the IPv4 fragment cache (#420 @hannesm)\n\n### v3.7.9 (2019-10-15)\n\n* Add ?ttl:int parameter to Udp and Icmp write (#416 @phaer)\n* Ipv4.Fragments use a Lru.M.t instead of Lru.F.t (#418 @hannesm)\n* Adapt to mirage-protocols 3.1.0 changes (#419 @hannesm)\n - removed IP.set_ip\n - added `Would_fragment to Ip.error\n\n### v3.7.8 (2019-08-12)\n\n* provide Fragments.fragment for the write side of fragmentation, use in Static_ipv4 (#415, @hannesm)\n\n### v3.7.7 (2019-07-16)\n\n* support ipaddr/macaddr.4.0.0 interfaces (@avsm)\n* remove extraneous debug messages from Ipv4.Fragments (@hannesm, #410)\n\n### v3.7.6 (2019-07-08)\n\n* opam: ensure Xen bindings are built with right mirage-xen-ocaml CFLAGS (@avsm)\n* opam: correctly register mirage-xen-ocaml as a depopt (@avsm)\n* use mirage-protocols-3.0 interface for ipaddr printing (#408 @yomimono @linse)\n* remove dependency on configurator and use dune's builtin one instead (@avsm)\n\n### v3.7.5 (2019-05-03)\n\n* drop IPv4 packets which destination address is not us or broadcast (#407 by @hannesm)\n\n### v3.7.4 (2019-04-11)\n\n* ipv4 reassembly requires lru 0.3.0 now (#406 by @hannesm)\n* ICMP test maintenance (#405 by @yomimono @linse)\n* remove usage of Cstruct.set_len (use Cstruct.sub with offset 0 instead) (#403 by @hannesm)\n\n### v3.7.3 (2019-04-06)\n\n* fix ICMPv4 checksum calculation (#401 by @yomimono)\n\n### v3.7.2 (2019-03-29)\n\n* add Ipv4_packet.Unmarshal.header_of_cstruct (#397 by @linse)\n* require cstruct version 3.2.0 (#398 by @hannesm)\n\n### v3.7.1 (2019-02-25)\n\n* Adjust to mirage-protocols 2.0.0 changes (#394 by @hannesm)\n* Ethif is now Ethernet (#394 by @hannesm)\n* IPv4 write now fragments if payload exceeds MTU (and the optional labeled\n fragment argument is not false) (#394 by @hannesm)\n\n### v3.7.0 (2019-02-02)\n\n* Use `Lwt_dllist` instead of `Lwt_sequence`, due to the latter being deprecated\n upstream in Lwt (ocsigen/lwt#361) (#388 by @avsm).\n* Remove arpv4 and ethif sublibraries, now provided by ethernet and arp-mirage\n opam packages (#380 by @hannesm).\n* Upgrade from jbuilder to dune (#391 @avsm)\n* Switch from topkg to dune-release (#391 @avsm)\n\n### v3.6.0 (2019-01-04)\n\n* The IPv4 implementation now supports reassembly of IPv4 fragments (#375 by @hannesm)\n - using a LRU cache using up to 256KB memory\n - out of order fragments are supported\n - maximum number of fragments is 16\n - timeout between first and last fragment is 10s\n - overlapping fragments are dropped\n\n* IPv6: use correct timeout value after first NS message (#334 @djs55)\n\n* Use `Ipaddr.pp` instead of `Ipaddr.pp_hum` due to upstream\n interface changes (#385 @hannesm).\n\n### v3.5.1 (2018-11-16)\n\n* socket stack (tcp/udp): catch exception in recv_from and accept (#376 @hannesm)\n* use mirage-random-test for testing (Stdlibrandom got removed from mirage-random>1.2.0, #377 @hannesm)\n\n### v3.5.0 (2018-09-16)\n\n* Ipv4: require Mirage_random.C, used for generating IPv4 identifier instead of using OCaml's stdlib Random directly (#371 @hannesm)\n* Tcp: use entire 32 bits at random for the initial sequence number, thanks to Spencer Michaels and Jeff Dileo of NCC Group for reporting (#371 @hannesm)\n* adjust to mirage-protocols 1.4.0 and mirage-stack 1.3.0 changes (#371 @hannesm)\n Arp no longer contains the type alias ethif\n Ethif no longer contains the type alias netif\n Static_ipv4 no longer contains the type alias ethif and prefix\n Ipv6 no longer contains the type alias ethif and prefix\n Mirage_protocols_lwt.IPV4 no longer contains the type alias ethif\n Mirage_protocols_lwt.UDPV4 and TCPV4 no longer contain the type alias ip\n* remove unused types: 'a config, netif, and id from socket and direct stack (#371 @hannesm)\n* remove usage of Result, depending on OCaml >= 4.03.0 (#372 @hannesm)\n\n### v3.4.2 (2018-06-15)\n\nNote the use of the new TCP keep-alive feature can cause excessive amounts\nof memory to be used in some circumstances, see\n https://github.com/mirage/mirage-tcpip/issues/367\n\n* Ensure a zero UDP checksum is sent as 0xffff, not 0x0000 (#359 @stedolan)\n* Avoid leaking a file descriptor in the socket stack if the connection fails (#363 @hannesm)\n* Avoid raising an exception with `Lwt.fail` when `write` fails in the socket stack (#363 @hannesm)\n* Ignore `EBADF` errors in `close` in the socket stack (#366 @hannesm)\n* Emit a warning when TCP keep-alives are used (#368 @djs55)\n\n### v3.4.1 (2018-03-09)\n\n* expose tcp_socket_options in the socket stack, fixing downstream builds (#356 @yomimono)\n* add missing dependencies and constraints (#354 @yomimono, #353 @rgrinberg)\n* remove leftover ocamlbuild files (#353 @rgrinberg)\n\n### v3.4.0 (2018-02-15)\n\n* Add support for TCP keepalives (#338 @djs55)\n* Fix TCP deadlock (#343 @mfp)\n* Update the CI to test OCaml 4.04, 4.05, 4.06 (#344 @yomimono)\n\n### v3.3.1 (2017-11-07)\n\n* Add an example for user-space `ping`, and some socket ICMPv4 fixes (#336 @djs55)\n* Make tcpip safe-string-safe (and buildable by default on OCaml 4.06.0) (#341 @djs55)\n\n### v3.3.0 (2017-08-08)\n\n* Test with current mirage-www master (#323 @yomimono)\n* Improve the Tcp.Wire API (#325 @samoht)\n* Add dependency from stack-unix to io-page-unix (@avsm)\n* Replace dependency on cstruct.lwt with cstruct-lwt (#322 @yomimono)\n* Update to lwt 3.0 (#326 @samoht)\n* Replace oUnit with alcotest (#329 @samoht)\n* Fix stub linking on Xen (#332 @djs55)\n* Add support for ICMP sockets on Windows (#333 @djs55)\n\n### v3.2.0 (2017-06-26)\n\n* port to jbuilder. Build time is now roughly 4-5x faster than the old oasis-based build system.\n* packs have been replaced by module aliases.\n\n### v3.1.4 (2017-06-12)\n\n* avoid linking to cstruct.ppx in the compiled library and only use it at build time (#316 @djs55)\n* use improved packet size support in `mirage-vnetif>=0.4.0` to test the MTU fixes in #313.\n\n### v3.1.3 (2017-05-23)\n\n* involve the IP layer's MTU in the TCP MSS calculation (hopefully correctly) (#313, by @yomimono)\n\n### v3.1.2 (2017-05-14)\n\n* impose a maximum TCP MSS of 1460 to avoid sending over-large datagrams on 1500 MTU links\n (#309, by @hannesm)\n\n### v3.1.1 (2017-05-14)\n\n* fix parsing 20-byte cstructs as ipv4 packets (#307, by @yomimono)\n* udp: payload length parse fix (#307, by @yomimono)\n* support lwt >= 2.7.0 (#308, by @djs55)\n\n### v3.1.0 (2017-03-14)\n\n* implement MTU setting and querying in the Ethernet module (compatibility with mirage-protocols version 1.1.0), and use this value to inform TCP's MSS. (#288, by @djs55)\n* rename the ~payload argument of TCP/UDP marshallers to `~payload_len`, in an attempt to clarify that the payload will not be copied to the Cstruct.t returned by these functions (#301, by @talex5)\n* functorize ipv6 over a random implementation (#298, by @olleolleolle and @hannesm)\n* add tests for sending and receiving UDP packets over IPv6 (#300, by @mattgray)\n* avoid float in TCP RTO calculations. (#295, by @olleolleolle and @mattgray)\n* numerous bugfixes in header marshallers and unmarshallers (#301, by @talex5 and @yomimono)\n* replace polymorphic equality in `_packet.equals` functions (#302, by @yomimono)\n\n### v3.0.0 (2017-02-23)\n\n* adapt to MirageOS 3 API changes (*many* PRs, from @hannesm, @samoht, and @yomimono):\n - replace error polyvars in many functions with result types\n - define and use error types\n - `connect` in various modules now returns the device directly or raises an exception\n - refer to mirage-protocols and mirage-stacks, rather than mirage-types\n* if no UDP source port is given to UDP.write, choose a random one (#272, by @hannesm)\n* remove `Ipv4.Routing.No_route_to_destination_address` exception; treat routing failures as normal packet loss in TCP (#269, by @yomimono)\n* Ipv6.connect takes a list of IPs (#268, by @yomimono)\n* remove exception \"Refused\" in TCP (#267, by @yomimono)\n* remove DHCP module. Users may be interested in the replacement charrua-core (#260, by @yomimono)\n* move Ipv4 to Static\\_ipv4, which can be used by other IPv4 modules with their own configuration logic (#260, by @yomimono)\n* remove `mode` from STACKV4 record and configuration; Ipv4.connect now requires address parameters and the module exposes no methods for modifying them. (#260, by @yomimono)\n* remove unused `id` types no longer required by mirage-types (#255, by @yomimono)\n* overhaul how `random` is used and handled (#254 and others, by @hannesm)\n* fix redundant `memset` that zeroed out options in Tcp\\_packet.Marshal.into\\_cstruct (#250, by @balrajsingh)\n* add vnetif backend for triggering fast retransmit in iperf tests (#248, by @magnuss)\n* fixes for incorrect timer values (#247, by @balrajsingh)\n* add vnetif backend that drops packets with no payload (#246, by @magnuss)\n* fix a race when closing test pcap files (#246, by @magnuss)\n\n### v2.8.1 (2016-09-12)\n\n* Set the TCP congestion window correctly when going into fast-recovery mode. (#244, by @balrajsingh)\n* When TCP packet loss is discovered by timeout, allow transition into fast-recovery mode. (#244, by @balrajsingh) \n\n### v2.8.0 (2016-04-04)\n\n* Provide an implementation for the ICMPV4 module type defined in mirage-types 2.8.0. Remove default ICMP handling from the IPv4 module, but preserve it in tcpip-stack-direct. (#195 by @yomimono)\n* Explicitly require the use of an OCaml compiler >= 4.02.3 . (#195 by @yomimono)\n* Explicitly depend on `result`. (#195 by @yomimono)\n\n### v2.7.0 (2016-03-20)\n\n* Raise Invalid\\_argument if given an invalid port number in listen_{tcp,udp}v4\n (#173 by @matildah and #175 by @hannesm)\n* Improve TCP options marshalling/unmarshalling (#174 by @yomimono)\n* Add state tests and fixes for closure conditions (#177 #176 by @yomimono)\n* Remove bogus warning (#178 by @talex5)\n* Clean up IPv6 stack (#179 by @nojb)\n* RST checking from RFC5961 (#182 by @ppolv)\n* Transform EPIPE exceptions into `Eof (#183 by @djs55)\n* Improve error strings in IPv4 (#184 by @yomimono)\n* Replace use of cstruct.syntax with cstruct.ppx (#188 by @djs55)\n* Make the Unix subpackages optional, so the core builds on Win32\n (#191 by @djs55)\n\n### v2.6.1 (2015-09-15)\n\n* Add optional arguments for settings in ip v6 and v4 connects (#170, by @Drup)\n* Expose `Ipv4.Routing.No_route_to_destination_address` (#166, by @yomimono)\n\n### v2.6.0 (2015-07-29)\n\n* ARP now handles ARP frames, not Ethernet frames with ARP payload\n (#164, by @hannesm)\n* Check length of received ethernet frame to avoid cstruct exceptions\n (#117, by @hannesm)\n* Pull arpv4 module out of ipv4. Also add unit-tests for the newly created\n ARP library (#155, by @yomimono)\n\n### v2.5.1 (2015-07-07)\n\n* Fix regression introduced in 2.5.0 where packet loss could lead to the\n connection to become very slow (#157, MagnusS, @talex5, @yomimono and\n @balrajsingh)\n* Improve the tests: more logging, more tracing and compile to native code when\n available, etc (@MagnusS and @talex5)\n* Do not raise `Invalid_argument(\"Lwt.wakeup_result\")` every time a connection\n is closed. Also now pass the raised exceptions to `Lwt.async_exception_hook`\n instead of ignoring them transparently, so the user can decide to shutdown\n its application if something wrong happens (#153, #156, @yomomino and @talex5)\n* The `channel` library now lives in a separate repository and is released\n separately (#159, @samoht)\n\n### v2.5.0 (2015-06-10)\n\n* The test runs now produce `.pcap` files (#141, by @MagnusS)\n* Strip trailing bytes from network packets (#145, by @talex5)\n* Add tests for uniform packet loss (#147, by @MagnusS)\n* fixed bug where in case of out of order packets the ack and window were set\n incorrectly (#140, #146)\n* Properly handle RST packets (#107, #148)\n* Add a `Log` module to control at runtime the debug statements which are\n displayed (#142)\n* Writing in a PCB which does not have the right state now returns an error\n instead of blocking (#150)\n\n### v2.4.3 (2015-05-05)\n\n* Fix infinite loop in `Channel.read_line` when the line does not contain a CRLF\n sequence (#131)\n\n### v2.4.2 (2015-04-29)\n\n* Fix a memory leak in `Channel` (#119, by @yomimono)\n* Add basic unit-test for channels (#119, by @yomimono)\n* Add alcotest testing templates\n* Modernize Travis CI scripts\n\n### v2.4.1 (2015-04-21)\n\n* Merge between 2.4.0 and 2.3.1\n\n### v2.4.0 (2015-03-24)\n\n* ARP improvements (#118)\n\n### v2.3.1 (2015-03-31)\n\n* Do not raise an assertion if an IP frame has extra trailing bytes (#221).\n\n### v2.3.0 (2015-03-09)\n\n* Fix `STACKV4` for the `DEVICE` signature which has `connect` removed\n (in Mirage types 2.3+).\n\n### v2.2.3 (2015-03-09)\n\n* Add ICMPv6 error reporting functions (#101)\n* Add universal IP address converters (#108)\n* Add `error_message` functions for human-readable errors (#98)\n* Improve debug logging for ICMP Destination Unreachable packets.\n* Filter incoming frames by MAC address to stop sending unnecessary RSTs. (#114)\n* Unhook unused modules `Sliding_window` and `Profiler` from the build. (#112)\n* Add an explicit `connect` method to the signatures. (#100)\n\n### v2.2.2 (2015-01-11)\n\n* Readded tracing and ARP fixes which got accidentally reverted in the IPv6\n merge. (#96)\n\n### v2.2.1 (2014-12-20)\n\n* Use `Bytes` instead of `String` to begin the `-safe-string` migration in OCaml\n 4.02.0 (#93).\n* Remove dependency on `uint` to avoid the need for a C stub (#92).\n\n### v2.2.0 (2014-12-18)\n\nAdd IPv6 support. This changeset minimises interface changes to the existing\n`STACKV4` interfaces to facilitate a progressive merge. The only visible\ninterface changes are:\n\n* `IPV4.set_ipv4_*` functions have been renamed `IPV4.set_ip_*` because they\n are shared between IPV4 and IPV6.\n* `IPV4.get_ipv4` and `get_ipv4_netmask` now return a `list` of `Ipaddr.V4.t`\n (again because this is the common semantics with IPV6.)\n* Several types that had `v4` in their names (like `IPV4.ipv4addr`) have lost\n that particle.\n\n### v2.1.1 (2014-12-12)\n\n* Improve console printing for the DHCP client to output line\n breaks properly on Xen consoles.\n\n### v2.1.0 (2014-12-07)\n\n* Build Xen stubs separately, with `CFLAGS` from `mirage-xen` 2.1.0+.\n This allows us to use the red zone under x86_64 Unix again.\n* Adding tracing labels and counters, which introduces a new dependency on the\n `mirage-profile` package.\n\n### v2.0.3 (2014-12-05)\n\n* Fixed race waiting for ARP response (#86).\n* Move the the code that configures IPv4 address, netmask and gateways\n after receiving a successful lease out of the `Dhcp_clientv4` module\n and into `Stackv4` (#87)\n\n### v2.0.2 (2014-12-01)\n\n* Add IPv4 multicast to MAC address mapping in IPv4 output processing\n (#81 from Luke Dunstan).\n* Improve formatting of DHCP console logging, including printing out options\n (#83).\n* Build with -mno-red-zone on x86_64 to avoid stack corruption on Xen (#80).\n\n### v2.0.1 (2014-11-04)\n\n* Fixed race condition in the signalling between the rx/tx threads under load.\n* Experimentally switch to immediate ACKs in TCPv4 by default instead of delayed ones.\n\n### v2.0.0 (2014-11-02)\n\n* Moved 1s complement checksum C code here from mirage-platform.\n* Depend on `Console_unix` and `Console_xen` instead of `Console`.\n* [socket] Do not return an `Eof` when writing 0-length buffer (#76).\n* [socket] Accept callbacks now run in async threads instead of being serialised\n (#75).\n\n### v1.1.6 (2014-07-20)\n\n* Quieten down the stack logging rate by not announcing IPv6 packet discards.\n* Raise exception `Bad_option` for unparsable or invalid TCPv4 options (#57).\n* Fix linking error with module `Tcp_checksum` by lifting it into top library\n (#60).\n* Add `opam` file to permit easier local pinning, and fix Travis to use this.\n\n### v1.1.5 (2014-06-18)\n\n* Ensure that DHCP completes before the application is started, so that\n unikernels that establish outgoing connections can do so without a race.\n (fix from Mindy Preston in #53, followup in #55)\n* Add `echo`, `chargen` and `discard` services into the `examples/`\n directory. (from Mindy Preston in #52).\n\n### v1.1.4 (2014-06-03)\n\n* [tcp] Fully process the last `ACK` in a 3-way handshake for server connections.\n This ensures that a `FIN` is correctly transmitted upon application-initiated\n connection close. (fix from Mindy Preston in #51).\n\n### v1.1.3 (2014-03-01)\n\n* Expose IPV4 through the STACKV4 interface.\n\n### v1.1.2 (2014-03-27)\n\n* Fix DHCP variable length option parsing for MTU responses, which\n in turns improves robustness on Amazon EC2 (fix from @yomimono\n via mirage/mirage-tcpip#48)\n\n### v1.1.1 (2014-02-21)\n\n* Catch and ignore top-level socket exceptions (#219).\n* Set `SO_REUSEADDR` on listening sockets for Unix (#218).\n* Adapt the Stack interfaces to the v1.1.1 mirage-types interface\n (see mirage/mirage#226 for details).\n\n### v1.1.0 (2014-02-03)\n\n* Rewrite of the library as a set of functors that parameterize the\n stack across the `V1_LWT` module types from Mirage 1.1.x. This removes\n the need to compile separate Xen and Unix versions of the stack.\n\n### v0.9.5 (2013-12-08)\n\n* Build for either Xen or Unix, depending on the value of the `OS` envvar.\n* Shift to the `mirage-types` 0.5.0+ interfaces, which breaks the\n socket backend (temporarily).\n* Port the direct stack to the new interfaces.\n* Add Travis CI scripts.\n\n### v0.9.4 (2013-08-09)\n\n* Use the `Ipaddr` external library and remove the Homebrew\n equivalents in `Nettypes`.\n\n### v0.9.3 (2013-07-18)\n\n* Changes in module Manager: Removed some functions from the `.mli\n (plug/unplug) and added some modifications in the way the Manager\n interacts with the underlying module Netif. The Netif.create function\n does not take a callback anymore.\n\n### v0.9.2 (2013-07-09)\n\n* Improve TCP state machine for connection teardown.\n* Limit fragment number to 8, and coalesce buffers if it goes higher.\n* Adapt to mirage-platform-0.9.2 API changes.\n\n### v0.9.1 (2013-06-12)\n\n* Depend on mirage-platform-0.9.1 direct tuntap interfaces.\n* Version bump to catch up with mirage-platform.\n\n### v0.5.2 (2013-02-08)\n\n* Encourage scatter-gather I/O all the time, rather than playing tricks\n with packet header buffers. This simplifies the output path considerably\n and cuts minor heap allocations down.\n* Install the packed `cmx` along with the `cmxa` to ensure that the\n compiler can do cross-module optimization (this is not a fatal error,\n but will impact performance if the `cmx` file is not present).\n\n### v0.5.1 (2012-12-20)\n\n* Update socket stack to use Cstruct 0.6.0 API\n\n### v0.5.0 (2012-12-20)\n\n* Update Cstruct API to 0.6.0\n* [tcp] write now blocks if the write buffer and write window are full\n\n### v0.4.1 (2012-12-14)\n\n* Add iperf self-test that creates two VIFs and transmits across\n them. This is a useful local test which stresses the bridge\n code using just one VM.\n* Add support for attaching existing devices when initialising the\n network manager, via an optional `attached` parameter.\n* Constrain TCP connect to be a `unit Lwt.t` instead of a polymorphic\n return value.\n* Expose IPv4 netmask function.\n* Reduce ARP verbosity to the console.\n* Fix TCP fast recovery to wait until all in-flight packets are\n acked, rather then exiting early.\n\n### v0.4.0 (2012-12-11)\n\n* Require OCaml-4.00.0 or higher, and add relevant build fixes\n to deal with module packing.\n\n### v0.3.1 (2012-12-10)\n\n* Fix the DHCP client marshalling for IPv4 addresses.\n* Expose the interface MAC address in the Manager signature.\n* Tweak TCP ISN calculation to be more friendly on a 32-bit host.\n* Add Manager.create ?devs to control the number of Netif devices\n constructed by default.\n* Add Ethif.set/disable_promiscuous to permit directly tapping\n a network interface.\n\n### v0.3.0 (2012-09-04)\n\n* Initial public release.\n" }, { "path": "LICENSE.md", "content": "Copyright (c) Anil Madhavapeddy \nCopyright (c) Balraj Singh \nCopyright (c) Citrix Inc\nCopyright (c) David Scott \nCopyright (c) Docker Inc\nCopyright (c) Drup \nCopyright (c) Gabor Pali \nCopyright (c) Hannes Mehnert \nCopyright (c) Haris Rotsos \nCopyright (c) Kia \nCopyright (c) Luke Dunstan \nCopyright (c) Magnus Skjegstad \nCopyright (c) Mindy Preston \nCopyright (c) Nicolas Ojeda Bar \nCopyright (c) Pablo Polvorin \nCopyright (c) Richard Mortier \nCopyright (c) Thomas Gazagnaire \nCopyright (c) Thomas Leonard \nCopyright (c) Tim Cuthbertson \nCopyright (c) Vincent Bernardoff \nCopyright (c) lnmx \nCopyright (c) pqwy \n\nPermission to use, copy, modify, and distribute this software for any\npurpose with or without fee is hereby granted, provided that the above\ncopyright notice and this permission notice appear in all copies.\n\nTHE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\nWITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\nMERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\nANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\nWHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\nACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\nOR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n" }, { "path": "Makefile", "content": "\n.PHONY: build clean test\n\nbuild:\n\tdune build\n\ntest:\n\tdune runtest\n\ninstall:\n\tdune install\n\nuninstall:\n\tdune uninstall\n\nclean:\n\tdune clean\n" }, { "path": "README.md", "content": "# mirage-tcpip - an OCaml TCP/IP networking stack\n\n`mirage-tcpip` provides a networking stack for the [Mirage operating\nsystem](https://mirage.io). It provides implementations for the following module types\n(which correspond with the similarly-named protocols):\n\n* IP (via the IPv4 and IPv6 modules)\n* ICMP\n* UDP\n* TCP\n\n## Implementations\n\nThere are two implementations of the IP, ICMP, UDP, and TCP module types -\nthe `socket` stack, and the `direct` stack.\n\n### The `socket` stack\n\nThe `socket` stack uses socket calls to a traditional operating system to\nprovide the functionality described in the module types.\n\nSee the [`src/stack-unix/`](./src/stack-unix/) directory for the modules used as implementations of the\n`socket` stack. \n\nThe `socket` stack is used for testing or other applications which do not\nexpect to run as unikernels.\n\n### The `direct` stack\n\nThe `direct` stack expects to write to a device implementing the `NETIF` module\ntype defined for MirageOS.\n\nSee the [`src/`](./src/) directory for the modules used as implementations of the\n`direct` stack, which is the expected stack for most MirageOS applications.\n\nThe `direct` stack is the only usable set of implementations for\napplications which will run as unikernels on a hypervisor target.\n\n## Community\n\n* WWW: \n* E-mail: \n* Issues: \n* API docs: \n\n## License\n\n`mirage-tcpip` is distributed under the ISC license.\n" }, { "path": "dune-project", "content": "(lang dune 2.7)\n(name tcpip)\n(formatting disabled)\n" }, { "path": "examples/ping/dune", "content": "(executables\n (names ping)\n (libraries cmdliner logs logs.fmt tcpip.icmpv4-socket tcpip))\n" }, { "path": "examples/ping/ping.ml", "content": "\nlet src =\n let src = Logs.Src.create \"ping\" ~doc:\"Mirage ping\" in\n Logs.Src.set_level src (Some Logs.Info);\n src\n\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\n(* Construct a payload buffer of a given size *)\nlet make_payload ~size () =\n let buf = Cstruct.create size in\n let pattern = \"plz reply i'm so lonely\" in\n for i = 0 to Cstruct.length buf - 1 do\n Cstruct.set_char buf i pattern.[i mod (String.length pattern)]\n done;\n buf\n\nlet seq_no_to_send_time = Hashtbl.create 7\nlet nr_transmitted = ref 0\nlet nr_received = ref 0\n\nlet min_ms = ref max_float\nlet max_ms = ref 0.\n(* to compute the standard deviation, we store the sum and the sum of squares *)\nlet sum_ms = ref 0.\nlet sum_ms_2 = ref 0.\n\n(* Send ICMP ECHO_REQUEST packets forever *)\nlet send_echo_requests ~stack ~payload ~dst () =\n let rec send seq_no =\n let open Lwt.Infix in\n let id_no = 0x1234 in\n let req = Icmpv4_packet.({code = 0x00; ty = Icmpv4_wire.Echo_request;\n subheader = Id_and_seq (id_no, seq_no)}) in\n let header = Icmpv4_packet.Marshal.make_cstruct req ~payload in\n let echo_request = Cstruct.concat [ header; payload ] in\n Log.debug (fun f -> f \"Sending ECHO_REQUEST id_no=%d seq_no=%d to %s\" id_no seq_no (Ipaddr.V4.to_string dst));\n Icmpv4_socket.write stack ~dst echo_request\n >>= function\n | Ok () ->\n Hashtbl.replace seq_no_to_send_time seq_no (Unix.gettimeofday ());\n incr nr_transmitted;\n Lwt_unix.sleep 1.\n >>= fun () ->\n send (seq_no + 1)\n | Error e ->\n Log.err (fun f -> f \"Error sending ICMP to %s: %a\" (Ipaddr.V4.to_string dst) Icmpv4_socket.pp_error e);\n Lwt.return_unit in\n send 0\n\n(* Return a thread and a receiver callback. The thread is woken up when we have\n received [count] packets *)\nlet make_receiver ~count ~payload () =\n let finished_t, finished_u = Lwt.task () in\n let callback buf =\n Log.debug (fun f -> f \"Received IP %a\" Cstruct.hexdump_pp buf);\n match Ipv4_packet.Unmarshal.of_cstruct buf with\n | Error msg ->\n Log.err (fun f -> f \"Error unmarshalling IP datagram: %s\" msg);\n Lwt.return_unit\n | Ok (ip, ip_payload) ->\n match Icmpv4_packet.Unmarshal.of_cstruct ip_payload with\n | Error msg ->\n Log.err (fun f -> f \"Error unmarshalling ICMP message: %s\" msg);\n Lwt.return_unit\n | Ok (reply, received_payload) ->\n let open Icmpv4_packet in\n begin match reply.subheader with\n | Next_hop_mtu _ | Pointer _ | Address _ | Unused ->\n Log.err (fun f -> f \"received an ICMP message which wasn't an echo-request or reply\");\n Lwt.return_unit\n | Id_and_seq (_id, seq) ->\n if reply.code <> 0\n then Log.err (fun f -> f \"received an ICMP ECHO_REQUEST with reply.code=%d\" reply.code);\n if not(Cstruct.equal payload received_payload)\n then Log.err (fun f -> f \"received an ICMP ECHO_REQUEST with an unexpected payload\");\n if not(Hashtbl.mem seq_no_to_send_time seq)\n then Log.err (fun f -> f \"received an ICMP ECHO_REQUEST with an unexpected sequence number\")\n else begin\n let secs = Unix.gettimeofday () -. (Hashtbl.find seq_no_to_send_time seq) in\n Hashtbl.remove seq_no_to_send_time seq;\n let ms = secs *. 1000.0 in\n Printf.printf \"%d bytes from %s: icmp_seq=%d ttl=%d time=%f ms\\n%!\"\n (Cstruct.length payload) (Ipaddr.V4.to_string ip.Ipv4_packet.src) seq ip.Ipv4_packet.ttl ms;\n incr nr_received;\n min_ms := min !min_ms ms;\n max_ms := max !max_ms ms;\n sum_ms := !sum_ms +. ms;\n sum_ms_2 := !sum_ms_2 +. (ms *. ms);\n if Some !nr_received = count then begin\n Log.debug (fun f -> f \"Finished after %d packets received\" !nr_received);\n Lwt.wakeup_later finished_u ();\n end\n end;\n Lwt.return_unit\n end in\n finished_t, callback\n\nlet ping (count:int option) (size:int) (timeout:int option) dst =\n let dst = Ipaddr.V4.of_string_exn dst in\n Lwt_main.run begin\n let open Lwt.Infix in\n let payload = make_payload ~size () in\n Icmpv4_socket.connect ()\n >>= fun stack ->\n let finished, on_icmp_receive = make_receiver ~count ~payload () in\n let me = Ipaddr.V4.any in\n let listener = Icmpv4_socket.listen stack me on_icmp_receive in\n let timeout = match timeout with\n | None ->\n let forever, _ = Lwt.task () in\n forever\n | Some t ->\n Lwt_unix.sleep (float_of_int t)\n >>= fun () ->\n Log.debug (fun f -> f \"Timed-out\");\n Lwt.return_unit in\n let sender = send_echo_requests ~stack ~payload ~dst () in\n let interrupted, interrupted_u = Lwt.task () in\n ignore(Lwt_unix.on_signal Sys.sigint (fun _ -> Lwt.wakeup_later interrupted_u ()));\n Lwt.pick [\n finished;\n timeout;\n interrupted;\n listener;\n sender;\n ]\n >>= fun () ->\n Printf.printf \"--- %s ping statistics ---\\n\" (Ipaddr.V4.to_string dst);\n let n = float_of_int (!nr_received) in\n let percent_loss = 100. *. (float_of_int (!nr_transmitted) -. n) /. (float_of_int (!nr_transmitted)) in\n Printf.printf \"%d packets transmitted, %d packets received, %0.0f%% packet loss\\n\"\n !nr_transmitted !nr_received percent_loss;\n let avg_ms = !sum_ms /. n in\n let variance_ms = 1. /. (n -. 1.) *. (!sum_ms_2) -. 1. /. (n *. (n -. 1.)) *. (!sum_ms) *. (!sum_ms) in\n let stddev_ms = sqrt variance_ms in\n Printf.printf \"round-trip min/avg/max/stddev = %.03f/%.03f/%.03f/%.03f ms\\n\"\n !min_ms avg_ms !max_ms stddev_ms;\n Lwt.return (`Ok ())\n end\n\nopen Cmdliner\n\nlet exit_after_success =\n let doc = \"Exit successfully after receiving one reply packet.\" in\n Arg.(value & flag & info [ \"o\" ] ~doc)\n\nlet count =\n let doc = \"Stop after sending (and receiving) count ECHO_RESPONSE packets. If not specified, ping will continue until interrupted.\" in\n Arg.(value & opt (some int) None & info [ \"c\" ] ~doc)\n\nlet size =\n let doc = \"Specify the number of data bytes to be sent.\" in\n Arg.(value & opt int 56 & info [ \"s\" ] ~doc)\n\nlet timeout =\n let doc = \"Specify a timeout, before ping exits regardless of how many packets have been received.\" in\n Arg.(value & opt (some int) None & info [ \"t\" ] ~doc)\n\nlet destination =\n let doc =\"Hostname or IP address of destination host\" in\n Arg.(value & pos 0 string \"\" & info [] ~doc)\n\nlet cmd =\n let doc = \"Send ICMP ECHO_REQUEST packets and listen for ECHO_RESPONSES\" in\n let man = [\n `S \"DESCRIPTION\";\n `P \"Send a sequence of ICMP ECHO_REQUEST packets to a network host and count the responses. When the program exits, display some statistics.\";\n ] in\n Cmd.v (Cmd.info \"ping\" ~doc ~man) (Term.(ret(const ping $ count $ size $ timeout $ destination)))\n\nlet _ =\n Logs.set_reporter (Logs_fmt.reporter ());\n exit (Cmd.eval cmd)\n" }, { "path": "examples/unikernel/config.ml", "content": "(* mirage >= 4.6.0 & < 4.11.0 *)\n\nopen Mirage\n\nlet main =\n let packages = [ package ~min:\"2.9.0\" \"ipaddr\" ] in\n main ~packages \"Services.Main\" (stackv4v6 @-> job)\n\nlet stack = generic_stackv4v6 default_network\n\nlet () = register \"services\" [ main $ stack ]\n" }, { "path": "examples/unikernel/services.ml", "content": "open Lwt.Infix\n\nmodule Main (S: Tcpip.Stack.V4V6) = struct\n let report_and_close flow pp e message =\n let ip, port = S.TCP.dst flow in\n Logs.warn\n (fun m -> m \"closing connection from %a:%d due to error %a while %s\"\n Ipaddr.pp ip port pp e message);\n S.TCP.close flow\n\n let rec chargen flow how_many start_at =\n let charpool =\n \"!\\\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~ \"\n in\n let make_chars how_many start_at =\n let output = (String.sub (charpool ^ charpool) start_at how_many) ^ \"\\n\" in\n Cstruct.of_string output\n in\n\n S.TCP.write flow (make_chars how_many start_at) >>= function\n | Ok () ->\n chargen flow how_many ((start_at + 1) mod (String.length charpool))\n | Error e -> report_and_close flow S.TCP.pp_write_error e \"writing in Chargen\"\n\n let rec discard flow =\n S.TCP.read flow >>= fun result -> (\n match result with\n | Error e -> report_and_close flow S.TCP.pp_error e \"reading in Discard\"\n | Ok `Eof -> report_and_close flow Fmt.string \"end of file\" \"reading in Discard\"\n | Ok (`Data _) -> discard flow\n )\n\n\n let rec echo flow =\n S.TCP.read flow >>= function\n | Error e -> report_and_close flow S.TCP.pp_error e \"reading in Echo\"\n | Ok `Eof -> report_and_close flow Fmt.string \"end of file\" \"reading in Echo\"\n | Ok (`Data buf) ->\n S.TCP.write flow buf >>= function\n | Ok () -> echo flow\n | Error e -> report_and_close flow S.TCP.pp_write_error e \"writing in Echo\"\n\n let start s =\n (* RFC 862 - read payloads and repeat them back *)\n S.TCP.listen (S.tcp s) ~port:7 echo;\n\n (* RFC 863 - discard all incoming data and never write a payload *)\n S.TCP.listen (S.tcp s) ~port:9 discard;\n\n (* RFC 864 - write data without regard for input *)\n S.TCP.listen (S.tcp s) ~port:19 (fun flow -> chargen flow 75 0);\n\n S.listen s\n\nend\n" }, { "path": "src/core/dune", "content": "(library\n (name tcpip)\n (public_name tcpip)\n (instrumentation\n (backend bisect_ppx))\n (libraries cstruct lwt fmt ipaddr mirage-flow duration))\n" }, { "path": "src/core/ip.ml", "content": "type error = [\n | `No_route of string (** can't send a message to that destination *)\n | `Would_fragment\n]\nlet pp_error ppf = function\n | `No_route s -> Fmt.pf ppf \"no route to destination: %s\" s\n | `Would_fragment -> Fmt.string ppf \"would fragment\"\n\ntype proto = [ `TCP | `UDP | `ICMP ]\nlet pp_proto ppf = function\n | `TCP -> Fmt.string ppf \"TCP\"\n | `UDP -> Fmt.string ppf \"UDP\"\n | `ICMP -> Fmt.string ppf \"ICMP\"\n\nmodule type S = sig\n type nonrec error = private [> error]\n val pp_error: error Fmt.t\n type ipaddr\n val pp_ipaddr : ipaddr Fmt.t\n type prefix\n val pp_prefix : prefix Fmt.t\n type t\n val disconnect : t -> unit Lwt.t\n type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\n val input:\n t ->\n tcp:callback -> udp:callback -> default:(proto:int -> callback) ->\n Cstruct.t -> unit Lwt.t\n val write: t -> ?fragment:bool -> ?ttl:int ->\n ?src:ipaddr -> ipaddr -> proto -> ?size:int -> (Cstruct.t -> int) ->\n Cstruct.t list -> (unit, error) result Lwt.t\n val pseudoheader : t -> ?src:ipaddr -> ipaddr -> proto -> int -> Cstruct.t\n val src: t -> dst:ipaddr -> ipaddr\n val get_ip: t -> ipaddr list\n [@@ocaml.deprecated \"this function will be removed soon, use [configured_ips] instead.\"]\n val configured_ips: t -> prefix list\n val mtu: t -> dst:ipaddr -> int\nend\n" }, { "path": "src/core/ip.mli", "content": "(** {2 IP layer} *)\n\n(** IP errors and protocols. *)\ntype error = [\n | `No_route of string (** can't send a message to that destination *)\n | `Would_fragment (** would need to fragment, but fragmentation is disabled *)\n]\n\nval pp_error : error Fmt.t\n\ntype proto = [ `TCP | `UDP | `ICMP ]\nval pp_proto: proto Fmt.t\n\n(** An Internet Protocol (IP) layer reassembles IP fragments into packets,\n removes the IP header, and on the sending side fragments overlong payload\n and inserts IP headers. *)\nmodule type S = sig\n\n type nonrec error = private [> error]\n (** The type for IP errors. *)\n\n val pp_error: error Fmt.t\n (** [pp_error] is the pretty-printer for errors. *)\n\n type ipaddr\n (** The type for IP addresses. *)\n\n val pp_ipaddr : ipaddr Fmt.t\n (** [pp_ipaddr] is the pretty-printer for IP addresses. *)\n\n type prefix\n (** The type for the IP address and netmask. *)\n\n val pp_prefix : prefix Fmt.t\n (** [pp_prefix] is the pretty-printer for the prefix. *)\n\n type t\n (** The type representing the internal state of the IP layer. *)\n\n val disconnect: t -> unit Lwt.t\n (** Disconnect from the IP layer. While this might take some time to\n complete, it can never result in an error. *)\n\n type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\n (** An input continuation used by the parsing functions to pass on\n an input packet down the stack.\n\n [callback ~src ~dst buf] will be called with [src] and [dst]\n containing the source and destination IP address respectively,\n and [buf] will be a buffer pointing at the start of the IP\n payload. *)\n\n val input:\n t ->\n tcp:callback -> udp:callback -> default:(proto:int -> callback) ->\n Cstruct.t -> unit Lwt.t\n (** [input ~tcp ~udp ~default ip buf] demultiplexes an incoming\n [buffer] that contains an IP frame. It examines the protocol\n header and passes the result onto either the [tcp] or [udp]\n function, or the [default] function for unknown IP protocols. *)\n\n val write: t -> ?fragment:bool -> ?ttl:int ->\n ?src:ipaddr -> ipaddr -> proto -> ?size:int -> (Cstruct.t -> int) ->\n Cstruct.t list -> (unit, error) result Lwt.t\n (** [write t ~fragment ~ttl ~src dst proto ~size headerf payload] allocates a\n buffer, writes the IP header, and calls the headerf function. This may\n write to the provided buffer of [size] (default 0). If [size + ip header]\n exceeds the maximum transfer unit, an error is returned. The [payload] is\n appended. The optional [fragment] argument defaults to [true], in which\n case multiple IP-fragmented frames are sent if the payload is too big for a\n single frame. When it is [false], the don't fragment bit is set and if the\n payload and header would exceed the maximum transfer unit, an error is\n returned. *)\n\n val pseudoheader : t -> ?src:ipaddr -> ipaddr -> proto -> int -> Cstruct.t\n (** [pseudoheader t ~src dst proto len] gives a pseudoheader suitable for use in\n TCP or UDP checksum calculation based on [t]. *)\n\n val src: t -> dst:ipaddr -> ipaddr\n (** [src ip ~dst] is the source address to be used to send a\n packet to [dst]. In the case of IPv4, this will always return\n the same IP, which is the only one set. *)\n\n val get_ip: t -> ipaddr list\n [@@ocaml.deprecated \"this function will be removed soon, use [configured_ips] instead.\"]\n (** Get the IP addresses associated with this interface. For IPv4, only\n one IP address can be set at a time, so the list will always be of\n length 1 (and may be the default value, [[10.0.0.2]]). *)\n\n val configured_ips: t -> prefix list\n (** Get the prefix associated with this interface. For IPv4, only\n one prefix can be set at a time, so the list will always be of\n length 1, e.g. [[10.0.0.2/24]]. *)\n\n val mtu: t -> dst:ipaddr -> int\n (** [mtu ~dst ip] is the Maximum Transmission Unit of the [ip] i.e. the\n maximum size of the payload, not including the IP header. *)\nend\n" }, { "path": "src/core/stack.ml", "content": "module type V4V6 = sig\n type t\n (** The type representing the internal state of the dual IPv4 and IPv6 stack. *)\n\n val disconnect: t -> unit Lwt.t\n (** Disconnect from the dual IPv4 and IPv6 stack. While this might take some\n time to complete, it can never result in an error. *)\n\n module UDP: Udp.S with type ipaddr = Ipaddr.t\n\n module TCP: Tcp.S with type ipaddr = Ipaddr.t\n\n module IP: Ip.S with type ipaddr = Ipaddr.t and type prefix = Ipaddr.Prefix.t\n\n val udp: t -> UDP.t\n (** [udp t] obtains a descriptor for use with the [UDP] module,\n usually to transmit traffic. *)\n\n val tcp: t -> TCP.t\n (** [tcp t] obtains a descriptor for use with the [TCP] module,\n usually to initiate outgoing connections. *)\n\n val ip: t -> IP.t\n (** [ip t] obtains a descriptor for use with the [IP] module,\n which can handle raw IPv4 and IPv6 frames, or manipulate IP address\n configuration on the stack interface. *)\n\n val listen: t -> unit Lwt.t\n (** [listen t] requests that the stack listen for traffic on the\n network interface associated with the stack, and demultiplex\n traffic to the appropriate callbacks. *)\nend\n" }, { "path": "src/core/tcp.ml", "content": "type error = [ `Timeout | `Refused]\ntype write_error = [ error | Mirage_flow.write_error]\n\nlet pp_error ppf = function\n | `Timeout -> Fmt.string ppf \"connection attempt timed out\"\n | `Refused -> Fmt.string ppf \"connection attempt was refused\"\n\nlet pp_write_error ppf = function\n | #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e\n | #error as e -> pp_error ppf e\n\nmodule Keepalive = struct\n type t = {\n after: Duration.t;\n interval: Duration.t;\n probes: int;\n }\nend\n\nmodule type S = sig\n type nonrec error = private [> error]\n type nonrec write_error = private [> write_error]\n type ipaddr\n type flow\n type t\n val disconnect : t -> unit Lwt.t\n include Mirage_flow.S with\n type flow := flow\n and type error := error\n and type write_error := write_error\n\n val dst: flow -> ipaddr * int\n val src: flow -> ipaddr * int\n val write_nodelay: flow -> Cstruct.t -> (unit, write_error) result Lwt.t\n val writev_nodelay: flow -> Cstruct.t list -> (unit, write_error) result Lwt.t\n val create_connection: ?keepalive:Keepalive.t -> t -> ipaddr * int -> (flow, error) result Lwt.t\n val listen : t -> port:int -> ?keepalive:Keepalive.t -> (flow -> unit Lwt.t) -> unit\n val unlisten : t -> port:int -> unit\n val input: t -> src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\nend\n" }, { "path": "src/core/tcp.mli", "content": "type error = [ `Timeout | `Refused]\ntype write_error = [ error | Mirage_flow.write_error ]\n\nval pp_error : error Fmt.t\nval pp_write_error : write_error Fmt.t\n\n(** Configuration for TCP keep-alives.\n Keep-alive messages are probes sent on an idle connection. If no traffic\n is received after a certain number of probes are sent, then the connection\n is assumed to have been lost. *)\nmodule Keepalive: sig\n type t = {\n after: Duration.t; (** initial delay before sending probes on an idle\n connection *)\n interval: Duration.t; (** interval between successive probes *)\n probes: int; (** total number of probes to send before assuming\n that, if the connection is still idle it has\n been lost *)\n }\n (** Configuration for TCP keep-alives *)\nend\n\n(** Transmission Control Protocol layer: reliable ordered streaming\n communication. *)\nmodule type S = sig\n\n type nonrec error = private [> error]\n (** The type for TCP errors. *)\n\n type nonrec write_error = private [> write_error]\n (** The type for TCP write errors. *)\n\n type ipaddr\n (** The type for IP address representations. *)\n\n type flow\n (** A flow represents the state of a single TCP stream that is connected\n to an endpoint. *)\n\n type t\n (** The type representing the internal state of the TCP layer. *)\n\n val disconnect: t -> unit Lwt.t\n (** Disconnect from the TCP layer. While this might take some time to\n complete, it can never result in an error. *)\n\n include Mirage_flow.S with\n type flow := flow\n and type error := error\n and type write_error := write_error\n\n val dst: flow -> ipaddr * int\n (** Get the destination IP address and destination port that a\n flow is currently connected to. *)\n\n val src : flow -> ipaddr * int\n (** Get the source IP address and source port that a flow is currently\n connected to. *)\n\n val write_nodelay: flow -> Cstruct.t -> (unit, write_error) result Lwt.t\n (** [write_nodelay flow buffer] writes the contents of [buffer]\n to the flow. The thread blocks until all data has been successfully\n transmitted to the remote endpoint.\n Buffering within the layer is minimized in this mode.\n Note that this API will change in a future revision to be a\n per-flow attribute instead of a separately exposed function. *)\n\n val writev_nodelay: flow -> Cstruct.t list -> (unit, write_error) result Lwt.t\n (** [writev_nodelay flow buffers] writes the contents of [buffers]\n to the flow. The thread blocks until all data has been successfully\n transmitted to the remote endpoint.\n Buffering within the layer is minimized in this mode.\n Note that this API will change in a future revision to be a\n per-flow attribute instead of a separately exposed function. *)\n\n val create_connection: ?keepalive:Keepalive.t -> t -> ipaddr * int -> (flow, error) result Lwt.t\n (** [create_connection ~keepalive t (addr,port)] opens a TCP connection\n to the specified endpoint.\n\n If the optional argument [?keepalive] is provided then TCP keep-alive\n messages will be sent to the server when the connection is idle. If\n no responses are received then eventually the connection will be disconnected:\n [read] will return [Ok `Eof] and write will return [Error `Closed] *)\n\n val listen : t -> port:int -> ?keepalive:Keepalive.t -> (flow -> unit Lwt.t) -> unit\n (** [listen t ~port ~keepalive callback] listens on [port]. The [callback] is\n executed for each flow that was established. If [keepalive] is provided,\n this configuration will be applied before calling [callback].\n\n @raise Invalid_argument if [port < 0] or [port > 65535]\n *)\n\n val unlisten : t -> port:int -> unit\n (** [unlisten t ~port] stops any listener on [port]. *)\n\n val input: t -> src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\n (** [input t] returns an input function continuation to be\n passed to the underlying {!IP} layer. *)\nend\n" }, { "path": "src/core/udp.ml", "content": "module type S = sig\n type error\n val pp_error: error Fmt.t\n type ipaddr\n type t\n val disconnect : t -> unit Lwt.t\n type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t\n val listen : t -> port:int -> callback -> unit\n val unlisten : t -> port:int -> unit\n val input: t -> src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\n val write: ?src:ipaddr -> ?src_port:int -> ?ttl:int -> dst:ipaddr -> dst_port:int -> t -> Cstruct.t ->\n (unit, error) result Lwt.t\nend\n" }, { "path": "src/core/udp.mli", "content": "(** User datagram protocol layer: connectionless message-oriented\n communication. *)\nmodule type S = sig\n\n type error (* entirely abstract since we expose none in a Udp module *)\n (** The type for UDP errors. *)\n\n val pp_error: error Fmt.t\n (** [pp] is the pretty-printer for errors. *)\n\n type ipaddr\n (** The type for an IP address representations. *)\n\n type t\n (** The type representing the internal state of the UDP layer. *)\n\n val disconnect: t -> unit Lwt.t\n (** Disconnect from the UDP layer. While this might take some time to\n complete, it can never result in an error. *)\n\n type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t\n (** The type for callback functions that adds the UDP metadata for\n [src] and [dst] IP addresses, the [src_port] of the\n connection and the [buffer] payload of the datagram. *)\n\n val listen : t -> port:int -> callback -> unit\n (** [listen t ~port callback] executes [callback] for each packet received\n on [port].\n\n @raise Invalid_argument if [port < 0] or [port > 65535] *)\n\n val unlisten : t -> port:int -> unit\n (** [unlisten t ~port] stops any listeners on [port]. *)\n\n val input: t -> src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\n (** [input t] demultiplexes incoming datagrams based on\n their destination port. *)\n\n val write: ?src:ipaddr -> ?src_port:int -> ?ttl:int -> dst:ipaddr ->\n dst_port:int -> t -> Cstruct.t -> (unit, error) result Lwt.t\n (** [write ~src ~src_port ~ttl ~dst ~dst_port udp data] is a task\n that writes [data] from an optional [src] and [src_port] to a [dst]\n and [dst_port] IP address pair. An optional time-to-live ([ttl]) is passed\n through to the IP layer. *)\n\nend\n" }, { "path": "src/icmp/dune", "content": "(library\n (name tcpip_icmpv4)\n (public_name tcpip.icmpv4)\n (instrumentation\n (backend bisect_ppx))\n (libraries logs tcpip ipaddr tcpip.checksum)\n (wrapped false))\n" }, { "path": "src/icmp/icmpv4.ml", "content": "module type S = sig\n type t\n val disconnect : t -> unit Lwt.t\n type ipaddr = Ipaddr.V4.t\n type error\n val pp_error: error Fmt.t\n val input : t -> src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\n val write : t -> ?src:ipaddr -> dst:ipaddr -> ?ttl:int -> Cstruct.t -> (unit, error) result Lwt.t\nend\n\nopen Lwt.Infix\n\nlet src = Logs.Src.create \"icmpv4\" ~doc:\"Mirage ICMPv4\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nmodule Make (IP : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) = struct\n\n type ipaddr = Ipaddr.V4.t\n\n type t = {\n ip : IP.t;\n echo_reply : bool;\n }\n\n type error = [ `Ip of IP.error ]\n let pp_error ppf (`Ip e) = IP.pp_error ppf e\n\n let connect ip =\n let t = { ip; echo_reply = true } in\n Lwt.return t\n\n let disconnect _ = Lwt.return_unit\n\n let writev t ?src ~dst ?ttl bufs =\n IP.write t.ip ?src dst ?ttl `ICMP (fun _ -> 0) bufs >|= function\n | Ok () -> Ok ()\n | Error e ->\n Log.warn (fun f -> f \"Error sending IP packet: %a\" IP.pp_error e);\n Error (`Ip e)\n\n let write t ?src ~dst ?ttl buf = writev t ?src ~dst ?ttl [buf]\n\n let input t ~src ~dst:_ buf =\n let open Icmpv4_packet in\n match Unmarshal.of_cstruct buf with\n | Error s ->\n Log.info (fun f ->\n f \"ICMP: error parsing message from %a: %s\" Ipaddr.V4.pp src s);\n Lwt.return_unit\n | Ok (message, payload) ->\n match message.ty, message.subheader with\n | Echo_reply, _ ->\n Log.info (fun f ->\n f \"ICMP: discarding echo reply from %a\" Ipaddr.V4.pp src);\n Lwt.return_unit\n | Destination_unreachable, _ ->\n Log.info (fun f ->\n f \"ICMP: destination unreachable from %a\" Ipaddr.V4.pp src);\n Lwt.return_unit\n | Echo_request, Id_and_seq (id, seq) ->\n Log.debug (fun f ->\n f \"ICMP echo-request received: %a (payload %a)\"\n Icmpv4_packet.pp message Cstruct.hexdump_pp payload);\n if t.echo_reply then begin\n let icmp = {\n code = 0x00;\n ty = Echo_reply;\n subheader = Id_and_seq (id, seq);\n } in\n writev t ~dst:src [ Marshal.make_cstruct icmp ~payload; payload ]\n >|= function\n | Ok () -> ()\n | Error (`Ip e) ->\n Log.warn (fun f -> f \"Unable to send ICMP echo-reply: %a\" IP.pp_error e); ()\n end else Lwt.return_unit\n | ty, _ ->\n Log.info (fun f ->\n f \"ICMP unknown ty %s from %a\"\n (Icmpv4_wire.ty_to_string ty) Ipaddr.V4.pp src);\n Lwt.return_unit\n\nend\n" }, { "path": "src/icmp/icmpv4.mli", "content": "(** {2 ICMP layer} *)\n\n(** Internet Control Message Protocol: error messages and operational\n information. *)\nmodule type S = sig\n\n type t\n (** The type representing the internal state of the ICMP layer. *)\n\n val disconnect: t -> unit Lwt.t\n (** Disconnect from the ICMP layer. While this might take some time to\n complete, it can never result in an error. *)\n\n type ipaddr = Ipaddr.V4.t\n (** The type for IP addresses. *)\n\n type error (* entirely abstract since we expose none in an Icmp module *)\n (** The type for ICMP errors. *)\n\n val pp_error: error Fmt.t\n (** [pp_error] is the pretty-printer for errors. *)\n\n val input : t -> src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\n (** [input t src dst buffer] reacts to the ICMP message in\n [buffer]. *)\n\n val write : t -> ?src:ipaddr -> dst:ipaddr -> ?ttl:int -> Cstruct.t -> (unit, error) result Lwt.t\n (** [write t ~src ~dst ~ttl buffer] sends the ICMP message in [buffer] to [dst]\n over IP. Passes the time-to-live ([ttl]) to the IP stack if given. *)\nend\n\nmodule Make (I : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) : sig\n include S\n\n val connect : I.t -> t Lwt.t\nend\n" }, { "path": "src/icmp/icmpv4_packet.ml", "content": "open Icmpv4_wire\n\n(* second 4 bytes of the message have varying interpretations *)\ntype subheader =\n | Id_and_seq of Cstruct.uint16 * Cstruct.uint16\n | Next_hop_mtu of Cstruct.uint16\n | Pointer of Cstruct.uint8\n | Address of Ipaddr.V4.t\n | Unused\n\ntype t = {\n code : Cstruct.uint8;\n ty : ty;\n subheader : subheader;\n}\n\nlet pp fmt t =\n let say = Format.fprintf in\n let pp_subheader fmt = function\n | Id_and_seq (id, seq) -> say fmt \"subheader: id: %d, sequence %d\" id seq\n | Next_hop_mtu mtu -> say fmt \"subheader: MTU %d\" mtu\n | Pointer pt -> say fmt \"subheader: pointer to byte %d\" pt\n | Address addr -> say fmt \"subheader: ip %a\" Ipaddr.V4.pp addr\n | Unused -> ()\n in\n say fmt \"ICMP type %s, code %d, subheader [%a]\" (ty_to_string t.ty)\n t.code pp_subheader t.subheader\n\nlet subheader_eq = function\n | Unused, Unused -> true\n | Id_and_seq (a, b), Id_and_seq (p, q) -> a = p && b = q\n | Next_hop_mtu a, Next_hop_mtu b-> a = b\n | Pointer a, Pointer b -> a = b\n | Address a, Address b -> Ipaddr.V4.compare a b = 0\n | _ -> false\n\nlet equal {code; ty; subheader} q =\n code = q.code &&\n ty = q.ty &&\n subheader_eq (subheader, q.subheader)\n\nlet ( let* ) = Result.bind\n\nmodule Unmarshal = struct\n\n type error = string\n\n let subheader_of_cstruct ty buf =\n let open Cstruct.BE in\n match ty with\n | Echo_request | Echo_reply\n | Timestamp_request | Timestamp_reply\n | Information_request | Information_reply ->\n Id_and_seq (get_uint16 buf 0, get_uint16 buf 2)\n | Destination_unreachable -> Next_hop_mtu (get_uint16 buf 2)\n | Time_exceeded\n | Source_quench -> Unused\n | Redirect -> Address (Ipaddr.V4.of_int32 (get_uint32 buf 0))\n | Parameter_problem -> Pointer (Cstruct.get_uint8 buf 0)\n\n let of_cstruct buf =\n let check_len () =\n if Cstruct.length buf < sizeof_icmpv4 then\n Error \"packet too short for ICMPv4 header\"\n else Ok () in\n let check_ty () =\n match int_to_ty (get_ty buf) with\n | None -> Error \"unrecognized ICMPv4 type\"\n | Some ty -> Ok ty\n in\n (* TODO: check checksum as well, and return an error if it's invalid *)\n let* () = check_len () in\n let* ty = check_ty () in\n let code = get_code buf in\n let subheader = subheader_of_cstruct ty (Cstruct.shift buf 4) in\n let payload = Cstruct.shift buf sizeof_icmpv4 in\n Ok ({ code; ty; subheader}, payload)\nend\n\nmodule Marshal = struct\n\n type error = string\n\n let subheader_into_cstruct ~buf sh =\n let open Cstruct.BE in\n match sh with\n | Id_and_seq (id, seq) -> set_uint16 buf 0 id; set_uint16 buf 2 seq\n | Next_hop_mtu mtu -> set_uint16 buf 0 0; set_uint16 buf 2 mtu\n | Pointer byte -> set_uint32 buf 0 Int32.zero; Cstruct.set_uint8 buf 0 byte;\n | Address addr -> set_uint32 buf 0 (Ipaddr.V4.to_int32 addr)\n | Unused -> set_uint32 buf 0 Int32.zero\n\n let unsafe_fill {ty; code; subheader} buf ~payload =\n set_ty buf (ty_to_int ty);\n set_code buf code;\n set_checksum buf 0x0000;\n subheader_into_cstruct ~buf:(Cstruct.shift buf 4) subheader;\n let packets = [(Cstruct.sub buf 0 sizeof_icmpv4); payload] in\n set_checksum buf (Tcpip_checksum.ones_complement_list packets)\n\n let check_len buf =\n if Cstruct.length buf < sizeof_icmpv4 then\n Error \"Not enough space for ICMP header\"\n else Ok ()\n\n let into_cstruct t buf ~payload =\n let* () = check_len buf in\n unsafe_fill t buf ~payload;\n Ok ()\n\n let make_cstruct t ~payload =\n let buf = Cstruct.create sizeof_icmpv4 in\n unsafe_fill t buf ~payload;\n buf\nend\n" }, { "path": "src/icmp/icmpv4_packet.mli", "content": "type subheader =\n | Id_and_seq of Cstruct.uint16 * Cstruct.uint16\n | Next_hop_mtu of Cstruct.uint16\n | Pointer of Cstruct.uint8\n | Address of Ipaddr.V4.t\n | Unused\n\ntype t = {\n code : Cstruct.uint8;\n ty : Icmpv4_wire.ty;\n subheader : subheader;\n}\n\nval pp : Format.formatter -> t -> unit\nval equal : t -> t -> bool\n\nmodule Unmarshal : sig\n type error = string\n\n val subheader_of_cstruct : Icmpv4_wire.ty -> Cstruct.t -> subheader\n\n val of_cstruct : Cstruct.t -> (t * Cstruct.t, error) result\nend\nmodule Marshal : sig\n type error = string\n\n (** [into_cstruct t buf ~payload] generates an ICMPv4 header from [t] and\n writes it into [buf] at offset 0. [payload] is used to calculate the ICMPv4 header\n checksum, but is not included in the generated buffer. [into_cstruct] may\n fail if the buffer is of insufficient size. *)\n val into_cstruct : t -> Cstruct.t -> payload:Cstruct.t -> (unit, error) result\n\n (** [make_cstruct t ~payload] allocates, fills, and returns a Cstruct.t with the header\n information from [t]. The payload is used to calculate the ICMPv4 header\n checksum, but is not included in the generated buffer. [make_cstruct] allocates\n 8 bytes for the ICMPv4 header. *)\n val make_cstruct : t -> payload:Cstruct.t -> Cstruct.t\nend\n" }, { "path": "src/icmp/icmpv4_wire.ml", "content": "type ty =\n | Echo_reply\n | Destination_unreachable\n | Source_quench\n | Redirect\n | Echo_request\n | Time_exceeded\n | Parameter_problem\n | Timestamp_request\n | Timestamp_reply\n | Information_request\n | Information_reply\n\nlet ty_to_string = function\n | Echo_reply -> \"echo reply\"\n | Destination_unreachable -> \"destination unreachable\"\n | Source_quench -> \"source quench\"\n | Redirect -> \"redirect\"\n | Echo_request -> \"echo request\"\n | Time_exceeded -> \"time exceeded\"\n | Parameter_problem -> \"parameter problem\"\n | Timestamp_request -> \"timestamp request\"\n | Timestamp_reply -> \"timestamp reply\"\n | Information_request -> \"information request\"\n | Information_reply -> \"information reply\"\n\nlet int_to_ty = function\n | 0 -> Some Echo_reply\n | 3 -> Some Destination_unreachable\n | 4 -> Some Source_quench\n | 5 -> Some Redirect\n | 8 -> Some Echo_request\n | 11 -> Some Time_exceeded\n | 12 -> Some Parameter_problem\n | 13 -> Some Timestamp_request\n | 14 -> Some Timestamp_reply\n | 15 -> Some Information_request\n | 16 -> Some Information_reply\n | _ -> None\n\nlet ty_to_int = function\n | Echo_reply -> 0\n | Destination_unreachable -> 3\n | Source_quench -> 4\n | Redirect -> 5\n | Echo_request -> 8\n | Time_exceeded -> 11\n | Parameter_problem -> 12\n | Timestamp_request -> 13\n | Timestamp_reply -> 14\n | Information_request -> 15\n | Information_reply -> 16\n\ntype unreachable_reason =\n | Network_unreachable\n | Host_unreachable\n | Protocol_unreachable\n | Port_unreachable\n | Would_fragment\n | Source_route_failed\n | Destination_network_unknown\n | Destination_host_unknown\n | Source_host_isolated\n | Destination_net_prohibited\n | Destination_host_prohibited\n | TOS_network_unreachable\n | TOS_host_unreachable\n | Communication_prohibited\n | Host_precedence_violation\n | Precedence_insufficient\n\nlet unreachable_reason_to_int = function\n | Network_unreachable -> 0\n | Host_unreachable -> 1\n | Protocol_unreachable -> 2\n | Port_unreachable -> 3\n | Would_fragment -> 4\n | Source_route_failed -> 5\n | Destination_network_unknown -> 6\n | Destination_host_unknown -> 7\n | Source_host_isolated -> 8\n | Destination_net_prohibited -> 9\n | Destination_host_prohibited -> 10\n | TOS_network_unreachable -> 11\n | TOS_host_unreachable -> 12\n | Communication_prohibited -> 13\n | Host_precedence_violation -> 14\n | Precedence_insufficient -> 15\n\nlet sizeof_icmpv4 = 8\n\nlet ty_off = 0\nlet code_off = 1\nlet csum_off = 2\n\nlet get_ty buf = Cstruct.get_uint8 buf ty_off\nlet set_ty buf value = Cstruct.set_uint8 buf ty_off value\n\nlet get_code buf = Cstruct.get_uint8 buf code_off\nlet set_code buf value = Cstruct.set_uint8 buf code_off value\n\nlet get_checksum buf = Cstruct.BE.get_uint16 buf csum_off\nlet set_checksum buf value = Cstruct.BE.set_uint16 buf csum_off value\n" }, { "path": "src/icmp/icmpv4_wire.mli", "content": "type ty =\n | Echo_reply\n | Destination_unreachable\n | Source_quench\n | Redirect\n | Echo_request\n | Time_exceeded\n | Parameter_problem\n | Timestamp_request\n | Timestamp_reply\n | Information_request\n | Information_reply\n\nval ty_to_string : ty -> string\nval int_to_ty : int -> ty option\nval ty_to_int : ty -> int\n\ntype unreachable_reason =\n | Network_unreachable\n | Host_unreachable\n | Protocol_unreachable\n | Port_unreachable\n | Would_fragment\n | Source_route_failed\n | Destination_network_unknown\n | Destination_host_unknown\n | Source_host_isolated\n | Destination_net_prohibited\n | Destination_host_prohibited\n | TOS_network_unreachable\n | TOS_host_unreachable\n | Communication_prohibited\n | Host_precedence_violation\n | Precedence_insufficient\n\nval unreachable_reason_to_int : unreachable_reason -> int\n\nval sizeof_icmpv4 : int\n\nval get_ty : Cstruct.t -> int\nval set_ty : Cstruct.t -> int -> unit\n\nval get_code : Cstruct.t -> int\nval set_code : Cstruct.t -> int -> unit\n\nval get_checksum : Cstruct.t -> int\nval set_checksum : Cstruct.t -> int -> unit\n" }, { "path": "src/ipv4/dune", "content": "(library\n (name tcpip_ipv4)\n (public_name tcpip.ipv4)\n (instrumentation\n (backend bisect_ppx))\n (libraries logs ipaddr cstruct tcpip tcpip.udp tcpip.checksum\n mirage-crypto-rng mirage-mtime randomconv lru arp.mirage ethernet)\n (wrapped false))\n" }, { "path": "src/ipv4/fragments.ml", "content": "(*\n * Copyright (c) 2018 Hannes Mehnert \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nlet src = Logs.Src.create \"ipv4-fragments\" ~doc:\"IPv4 fragmentation\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\n(* TODO:\ncurrent state:\n\n lifetime is 10s max between first and last fragment\n size is 1MB hardcoded\n max 16 fragments for each \"flow\" (source ip, destrination ip, protocol, ipv4 identifier)\n inserted into sorted list, checks overlaps and holes on reassembly (triggered once a fragment without \"more fragments\" has been received)\n\nthis has some issues:\n\n anyone can spam (with a constant stream of fragmented packets - needs to fill 1MB in 10s) the fragment cache, leading to resource exhaustion of the cache (\"valid\" fragments are dropped if they're incoming too slowly)\n insertion into linked list is O(n) (with n is maximal 16)\n ping -s 65535 isn't answered with MTU=1500 (doesn't fit into 16 fragments)\n\nwhat we could do instead\n\n maximum storage per source ip\n use a bitmask or tree data structure for the segments (offset is on 8byte boundaries)\n may lead to verification of overlaps at insertion time --> can drop immediately\n*)\n\n(* IP Fragmentation using a LRU cache:\n\n The key of our cache is source ip * destination ip * protocol * identifier.\n The value is a quintuple consisting of first segment received. IP options\n (which are usually sent only in the first IP segment), \"last segment\n received\" (i.e. an IPv4 segment without the more fragment bit set), a counter\n of the length of items, and a list of pairs, which contain an offset and\n payload. The list is sorted by offset in descending order. *)\n\nmodule V = struct\n type t = int64 * Cstruct.t * bool * int * (int * Cstruct.t) list\n\n let weight (_, _, _, _, v) = Cstruct.lenv (List.map snd v)\nend\n\nmodule K = struct\n type t = Ipaddr.V4.t * Ipaddr.V4.t * int * int\n\n let compare (src, dst, proto, id) (src', dst', proto', id') =\n let (&&&) a b = match a with 0 -> b | x -> x in\n let int_cmp : int -> int -> int = compare in\n Ipaddr.V4.compare src src' &&&\n Ipaddr.V4.compare dst dst' &&&\n int_cmp proto proto' &&&\n int_cmp id id'\nend\n\nmodule Cache = Lru.F.Make(K)(V)\n\n(* insert_sorted inserts a fragment in a list, sort is by frag_start, descending *)\nlet rec insert_sorted ((frag_start, _) as frag) = function\n | [] -> [ frag ]\n | ((frag'_start, _) as frag')::tl ->\n if frag'_start <= frag_start\n then frag::frag'::tl\n else frag'::insert_sorted frag tl\n\n(* attempt_reassemble takes a list of fragments, and returns either\n - Ok payload when the payload was completed\n - Error Hole if some fragment is still missing\n - Error Bad if the list of fragments was bad: it contains overlapping\n segments. This is an indication for malicious activity, and we drop the\n IP fragment\n\nThere are various attacks (and DoS) on IP reassembly, most prominent use\noverlapping segments (and selection thereof), we just drop overlapping segments\n(similar as Linux does since https://git.kernel.org/pub/scm/linux/kernel/git/davem/net-next.git/commit/?id=c30f1fc041b74ecdb072dd44f858750414b8b19f).\n*)\n\ntype r = Bad | Hole\n\nlet attempt_reassemble fragments =\n Log.debug (fun m -> m \"reassemble %a\"\n Fmt.(list ~sep:(any \"; \") (pair ~sep:(any \", len \") int int))\n (List.map (fun (off, data) -> off, Cstruct.length data) fragments)) ;\n (* input: list of (offset, fragment) with decreasing offset *)\n (* output: maybe a cstruct.t if there are no gaps *)\n let len =\n (* List.hd is safe here, since we are never called with an empty list *)\n let off, data = List.hd fragments in\n off + Cstruct.length data\n in\n let rec check until = function\n | [] -> if until = 0 then Ok () else Error Hole\n | (start, d)::tl ->\n let until' = start + (Cstruct.length d) in\n if until = until'\n then check start tl\n else if until' > until\n then Error Bad\n else Error Hole\n in\n Result.bind\n (check len fragments)\n (fun () ->\n let buf = Cstruct.create_unsafe len in\n List.iter (fun (off, data) ->\n Cstruct.blit data 0 buf off (Cstruct.length data))\n fragments ;\n Ok buf)\n\nlet max_number_of_fragments = 16\n\nlet max_duration = Duration.of_sec 10\n\nlet process cache ts (packet : Ipv4_packet.t) payload =\n let add_trim key value cache =\n let cache' = Cache.add key value cache in\n Cache.trim cache'\n in\n if packet.off land 0x3FFF = 0 then (* ignore reserved and don't fragment *)\n (* fastpath *)\n cache, Some (packet, payload)\n else\n let offset, more =\n (packet.off land 0x1FFF) lsl 3, (* of 8 byte blocks *)\n packet.off land 0x2000 = 0x2000\n and key = (packet.src, packet.dst, packet.proto, packet.id)\n in\n let v = (ts, packet.options, not more, 1, [(offset, payload)]) in\n match Cache.find key cache with\n | None ->\n Log.debug (fun m -> m \"%a none found, inserting into cache\" Ipv4_packet.pp packet) ;\n add_trim key v cache, None\n | Some (ts', options, finished, cnt, frags) ->\n if Int64.sub ts ts' >= max_duration then begin\n Log.warn (fun m -> m \"%a found some, but timestamp exceeded duration %a, dropping old segments and inserting new segment into cache\" Ipv4_packet.pp packet Duration.pp max_duration) ;\n add_trim key v cache, None\n end else\n let cache' = Cache.promote key cache in\n let all_frags = insert_sorted (offset, payload) frags\n and try_reassemble = finished || not more\n and options' = if offset = 0 then packet.options else options\n in\n Log.debug (fun m -> m \"%d found, finished %b more %b try_reassemble %b\"\n cnt finished more try_reassemble) ;\n let maybe_add_to_cache c =\n if cnt < max_number_of_fragments then\n add_trim key (ts', options', try_reassemble, succ cnt, all_frags) c\n else\n (Log.warn (fun m -> m \"%a dropping from cache, maximum number of fragments exceeded\"\n Ipv4_packet.pp packet) ;\n Cache.remove key c)\n in\n if try_reassemble then\n match attempt_reassemble all_frags with\n | Ok p ->\n Log.debug (fun m -> m \"%a reassembled to payload %d\" Ipv4_packet.pp packet (Cstruct.length p)) ;\n let packet' = { packet with options = options' ; off = 0 } in\n Cache.remove key cache', Some (packet', p)\n | Error Bad ->\n Log.warn (fun m -> m \"%a dropping from cache, bad fragments (%a)\"\n Ipv4_packet.pp packet\n Fmt.(list ~sep:(any \"; \") (pair ~sep:(any \", \") int int))\n (List.map (fun (s, d) -> (s, Cstruct.length d)) all_frags)) ;\n Log.debug (fun m -> m \"full fragments: %a\"\n Fmt.(list ~sep:(any \"@.\") Cstruct.hexdump_pp)\n (List.map snd all_frags)) ;\n Cache.remove key cache', None\n | Error Hole -> maybe_add_to_cache cache', None\n else\n maybe_add_to_cache cache', None\n\n(* TODO hdr.options is a Cstruct.t atm, but instead we need to parse all the\n options, and distinguish based on the first bit -- only these with the bit\n set should be copied into all fragments (see RFC 791, 3.1, page 15) *)\nlet fragment ~mtu hdr payload =\n let rec frag1 acc hdr hdr_buf offset data_size payload =\n let more = Cstruct.length payload > data_size in\n let hdr' =\n (* off is 16 bit of IPv4 header, 0x2000 sets the more fragments bit *)\n let off = (offset / 8) lor (if more then 0x2000 else 0) in\n { hdr with Ipv4_packet.off }\n in\n let this_payload, rest =\n if more then Cstruct.split payload data_size else payload, Cstruct.empty\n in\n let payload_len = Cstruct.length this_payload in\n Ipv4_wire.set_checksum hdr_buf 0;\n (match Ipv4_packet.Marshal.into_cstruct ~payload_len hdr' hdr_buf with\n (* hdr_buf is allocated with hdr_size (computed below) bytes, thus\n into_cstruct will never return an error! *)\n | Error msg -> invalid_arg msg\n | Ok () -> ());\n let acc' = Cstruct.append hdr_buf this_payload :: acc in\n if more then\n let offset = offset + data_size in\n (frag1[@tailcall]) acc' hdr hdr_buf offset data_size rest\n else\n acc'\n in\n let hdr_size =\n (* padded to 4 byte boundary *)\n let opt_size = (Cstruct.length hdr.Ipv4_packet.options + 3) / 4 * 4 in\n opt_size + Ipv4_wire.sizeof_ipv4\n in\n let data_size =\n let full = mtu - hdr_size in\n (full / 8) * 8\n in\n if data_size <= 0 then\n []\n else\n List.rev (frag1 [] hdr (Cstruct.create hdr_size) data_size data_size payload)\n" }, { "path": "src/ipv4/fragments.mli", "content": "(*\n * Copyright (c) 2018 Hannes Mehnert \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\n(** IPv4 Fragmentation and reassembly\n\n An IPv4 packet may exceed the maximum transferable unit (MTU) of a link, and\n thus may be fragmented into multiple packets. Since the MTU depends on the\n underlying link, fragmentation and reassembly may happen in gateways as well\n as endpoints. Starting at byte 6, 16 bit in the IPv4 header are used for\n fragmentation. The first bit is reserved, the second signals if set to never\n fragment this packet - instead if it needs to be fragmented, an ICMP error\n must be returned (used for path MTU discovery). The third bit indicates\n whether this is the last fragment or more are following. The remaining 13\n bits are the offset of this fragment in the reassembled packet, divided by\n 8. All fragments of one reassembled packet use the same 16 bit IPv4\n identifier (byte offset 4). The IPv4 header is repeated in each fragment,\n apart from those options which highest bit is cleared. Fragments may be\n received in any order.\n\n This module implements a reassembly cache, using a least recently used (LRU)\n cache underneath. For security reasons, only non-overlapping fragments are\n accepted. To avoid denial of service attacks, the maximum number of segments\n is limited to 16 - with a common MTU of 1500, this means that packets\n exceeding 24000 bytes will be dropped. The arrival time of the first and last\n fragment may not exceed 10 seconds. There is no per-source IP limit of\n fragment data to keep, only the total amount of fragmented data can be\n limited by the choice of the size of the LRU.\n\n Any received packet may be the last needed for a successful reassembly (due\n to receiving them out-of-order). When the last fragment (which has the more\n fragments bit cleared) for a quadruple source IP, destination IP, IP\n identifier, and protocol ID, is received, reassembly is attempted - also on\n subsequent packets with the same quadruple. *)\n\nmodule V : sig\n type t = int64 * Cstruct.t * bool * int * (int * Cstruct.t) list\n (** The type of values in the fragment cache: a timestamp of the first\n received one, IP options (of the first fragment), whether or not the last\n fragment was received (the one with more fragments cleared), amount of\n received fragments, and a list of pairs of offset and fragment. *)\n\n val weight : t -> int\n (** [weight t] is the data length of the received fragments. *)\nend\n\nmodule K : sig\n type t = Ipaddr.V4.t * Ipaddr.V4.t * int * int\n (** The type of keys in the fragment cache: source IP address, destination\n IP address, protocol type, and IP identifier. *)\n\n val compare : t -> t -> int\nend\n\nmodule Cache : sig\n include Lru.F.S with type k = K.t and type v = V.t\nend\n\nval max_duration : int64\n(** [max_duration] is the maximum delta between first and last received\n fragment, in nanoseconds. At the moment it is 10 seconds. *)\n\nval process : Cache.t -> int64 -> Ipv4_packet.t -> Cstruct.t -> Cache.t *\n (Ipv4_packet.t * Cstruct.t) option (** [process t timestamp hdr payload] is\n [t'], a new cache, and maybe a fully reassembled IPv4 packet. If reassembly\n fails, e.g. too many fragments, delta between receive timestamp of first and\n last packet exceeds {!max_duration}, overlapping packets, these packets\n will be dropped from the cache. The IPv4 header options are always taken from\n the first fragment (where offset is 0). If the provided IPv4 header has an\n fragmentation offset of 0, and the more fragments bit is not set, the given\n header and payload is directly returned. Handles out-of-order fragments\n gracefully. *)\n\nval fragment : mtu:int -> Ipv4_packet.t -> Cstruct.t -> Cstruct.t list\n(** [fragment ~mtu hdr payload] is called with the IPv4 header of the first\n fragment and the remaining payload (which did not fit into the first\n fragment). The [data_length = ((mtu - header_length hdr) / 8) * 8] is used\n for each fragment (and it is assumed that the first fragment contains\n exactly that much data). The number of packets returned is\n [len payload / data_len]. If [data_len <= 0], the empty list is returned. *)\n" }, { "path": "src/ipv4/ipv4_packet.ml", "content": "type t = {\n src : Ipaddr.V4.t;\n dst : Ipaddr.V4.t;\n id : Cstruct.uint16;\n off : Cstruct.uint16;\n ttl : Cstruct.uint8;\n proto : Cstruct.uint8;\n options : Cstruct.t;\n}\n\ntype protocol = [\n | `ICMP\n | `TCP\n | `UDP ]\n\nlet pp fmt t =\n Format.fprintf fmt \"IPv4 packet %a -> %a: id %04x, off %d proto %d, ttl %d, options %a\"\n Ipaddr.V4.pp t.src Ipaddr.V4.pp t.dst t.id t.off t.proto t.ttl Cstruct.hexdump_pp t.options\n\nlet equal {src; dst; id; off; ttl; proto; options} q =\n src = q.src &&\n dst = q.dst &&\n id = q.id &&\n off = q.off &&\n ttl = q.ttl &&\n proto = q.proto &&\n Cstruct.equal options q.options\n\nmodule Marshal = struct\n open Ipv4_wire\n\n type error = string\n\n let protocol_to_int = function\n | `ICMP -> 1\n | `TCP -> 6\n | `UDP -> 17\n\n let pseudoheader ~src ~dst ~proto len =\n (* should we do sth about id or off (assert false?) *)\n let proto = protocol_to_int proto in\n let ph = Cstruct.create 12 in\n let numify = Ipaddr.V4.to_int32 in\n Cstruct.BE.set_uint32 ph 0 (numify src);\n Cstruct.BE.set_uint32 ph 4 (numify dst);\n Cstruct.set_uint8 ph 8 0;\n Cstruct.set_uint8 ph 9 proto;\n Cstruct.BE.set_uint16 ph 10 len;\n ph\n\n let unsafe_fill ~payload_len t buf =\n let nearest_4 n = match n mod 4 with\n | 0 -> n\n | k -> (4 - k) + n\n in\n let options_len = nearest_4 @@ Cstruct.length t.options in\n set_hlen_version buf ((4 lsl 4) + 5 + (options_len / 4));\n set_id buf t.id;\n set_off buf t.off;\n set_ttl buf t.ttl;\n set_proto buf t.proto;\n set_src buf t.src;\n set_dst buf t.dst;\n Cstruct.blit t.options 0 buf sizeof_ipv4 (Cstruct.length t.options);\n set_len buf (sizeof_ipv4 + options_len + payload_len);\n let checksum = Tcpip_checksum.ones_complement @@ Cstruct.sub buf 0 (20 + options_len) in\n set_checksum buf checksum\n\n\n let into_cstruct ~payload_len t buf =\n if Cstruct.length buf < (sizeof_ipv4 + Cstruct.length t.options) then\n Error \"Not enough space for IPv4 header\"\n else\n Ok (unsafe_fill ~payload_len t buf)\n\n let make_cstruct ~payload_len t =\n let nearest_4 n = match n mod 4 with\n | 0 -> n\n | k -> (4 - k) + n\n in\n let options_len = nearest_4 @@ Cstruct.length t.options in\n let buf = Cstruct.create (sizeof_ipv4 + options_len) in\n Cstruct.memset buf 0x00; (* should be removable in the future *)\n unsafe_fill ~payload_len t buf;\n buf\nend\nmodule Unmarshal = struct\n type error = string\n\n let int_to_protocol = function\n | 1 -> Some `ICMP\n | 6 -> Some `TCP\n | 17 -> Some `UDP\n | _ -> None\n\n let ( let* ) = Result.bind\n\n let header_of_cstruct buf =\n let open Ipv4_wire in\n let check_version buf =\n let version n = (n land 0xf0) in\n match get_hlen_version buf |> version with\n | 0x40 -> Ok ()\n | n -> Error (Printf.sprintf \"IPv4 presented with a packet that claims a different IP version: %x\" n)\n in\n let size_check buf =\n if (Cstruct.length buf < sizeof_ipv4) then Error \"buffer sent to IPv4 parser had size < 20\"\n else Ok ()\n in\n let get_header_length buf =\n let length_of_hlen_version n = (n land 0x0f) * 4 in\n let hlen = get_hlen_version buf |> length_of_hlen_version in\n let len = get_len buf in\n if len < sizeof_ipv4 then\n Error (Printf.sprintf\n \"total length %d is smaller than minimum header length\" len)\n else if len < hlen then\n Error (Printf.sprintf\n \"total length %d is smaller than stated header length %d\"\n len hlen)\n else if hlen < sizeof_ipv4 then\n Error (Printf.sprintf \"IPv4 header claimed to have size < 20: %d\" hlen)\n else if Cstruct.length buf < hlen then\n Error (Printf.sprintf \"IPv4 packet w/length %d claimed to have header of size %d\" (Cstruct.length buf) hlen)\n else Ok hlen\n in\n let parse buf options_end =\n let src = get_src buf\n and dst = get_dst buf\n and id = get_id buf\n and off = get_off buf\n and ttl = get_ttl buf\n and proto = get_proto buf\n in\n let options =\n if options_end > sizeof_ipv4 then (Cstruct.sub buf sizeof_ipv4 (options_end - sizeof_ipv4))\n else (Cstruct.create 0)\n in\n Ok ({src; dst; id; off; ttl; proto; options;}, options_end)\n in\n let* () = size_check buf in\n let* () = check_version buf in\n let* hl = get_header_length buf in\n parse buf hl\n\n let of_cstruct buf =\n let parse buf options_end =\n let payload_len = Ipv4_wire.get_len buf - options_end in\n let payload_available = Cstruct.length buf - options_end in\n if payload_available < payload_len then (\n Error (Printf.sprintf \"Payload buffer (%d bytes) too small to contain payload (of size %d from header)\" payload_available payload_len)\n ) else (\n let payload = Cstruct.sub buf options_end payload_len in\n Ok payload\n )\n in\n let* header, options_end = header_of_cstruct buf in\n let* payload = parse buf options_end in\n Ok (header, payload)\n\n let verify_transport_checksum ~proto ~ipv4_header ~transport_packet =\n (* note: it's not necessary to ensure padding to integral number of 16-bit fields here; ones_complement_list does this for us *)\n let check ~proto ipv4_header len =\n try\n let ph = Marshal.pseudoheader ~src:ipv4_header.src ~dst:ipv4_header.dst ~proto len in\n let calculated_checksum = Tcpip_checksum.ones_complement_list [ph ; transport_packet] in\n 0 = compare 0x0000 calculated_checksum\n with\n | Invalid_argument _ -> false\n in\n match proto with\n | `TCP -> (* checksum isn't optional in tcp, but pkt must be long enough *)\n check ipv4_header ~proto (Cstruct.length transport_packet)\n | `UDP ->\n match Udp_wire.get_checksum transport_packet with\n | n when (=) 0 @@ compare n 0x0000 -> true (* no checksum supplied, so the check trivially passes *)\n | _ ->\n check ipv4_header ~proto (Cstruct.length transport_packet)\n\nend\n" }, { "path": "src/ipv4/ipv4_packet.mli", "content": "type t = {\n src : Ipaddr.V4.t;\n dst : Ipaddr.V4.t;\n id : Cstruct.uint16;\n off : Cstruct.uint16;\n ttl : Cstruct.uint8;\n proto : Cstruct.uint8;\n options : Cstruct.t;\n}\n\nval pp : Format.formatter -> t -> unit\nval equal : t -> t -> bool\n\ntype protocol = [\n | `ICMP\n | `TCP\n | `UDP ]\n\nmodule Unmarshal : sig\n type error = string\n\n val int_to_protocol : int -> protocol option\n\n val of_cstruct : Cstruct.t -> (t * Cstruct.t, error) result\n val header_of_cstruct : Cstruct.t -> ((t * int), error) result\n(** [header_of_cstruct buf] attempts to return [t, offset] where [offset]\n is the first byte of the payload in [buf]. *)\n\n val verify_transport_checksum : proto:([`TCP | `UDP]) -> ipv4_header:t ->\n transport_packet:Cstruct.t -> bool\nend\n\nmodule Marshal : sig\n type error = string\n\n val protocol_to_int : protocol -> Cstruct.uint16\n\n val pseudoheader : src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> proto:protocol\n -> int -> Cstruct.t\n (** [pseudoheader src dst proto len] constructs a pseudoheader, suitable for inclusion in transport-layer checksum calculations, including the information supplied. [len] should be the total length of the transport-layer header and payload. *)\n\n(** [into_cstruct ~payload_len t buf] attempts to write a header representing [t] (including\n [t.options]) into [buf] at offset 0.\n If there is insufficient space to represent [t], an error will be returned. *)\n val into_cstruct : payload_len:int -> t -> Cstruct.t -> (unit, error) result\n\n (** [make_cstruct ~payload_len t] allocates, fills, and returns a buffer\n representing the IPV4 header corresponding to [t].\n If [t.options] is non-empty, [t.options] will be\n concatenated onto the result. A variable amount of memory (at least 20 bytes\n for a zero-length options field) will be allocated.\n Note: no space is allocated for the payload. *)\n val make_cstruct : payload_len:int -> t -> Cstruct.t\nend\n" }, { "path": "src/ipv4/ipv4_wire.ml", "content": "let sizeof_ipv4 = 20\n\nlet hlen_version_off = 0\nlet tos_off = 1\nlet len_off = 2\nlet id_off = 4\nlet off_off = 6\nlet ttl_off = 8\nlet proto_off = 9\nlet csum_off = 10\nlet src_off = 12\nlet dst_off = 16\n\nlet get_hlen_version buf = Cstruct.get_uint8 buf hlen_version_off\nlet set_hlen_version buf v = Cstruct.set_uint8 buf hlen_version_off v\n\nlet get_tos buf = Cstruct.get_uint8 buf tos_off\nlet set_tos buf v = Cstruct.set_uint8 buf tos_off v\n\nlet get_len buf = Cstruct.BE.get_uint16 buf len_off\nlet set_len buf v = Cstruct.BE.set_uint16 buf len_off v\n\nlet get_id buf = Cstruct.BE.get_uint16 buf id_off\nlet set_id buf v = Cstruct.BE.set_uint16 buf id_off v\n\nlet get_off buf = Cstruct.BE.get_uint16 buf off_off\nlet set_off buf v = Cstruct.BE.set_uint16 buf off_off v\n\nlet get_ttl buf = Cstruct.get_uint8 buf ttl_off\nlet set_ttl buf v = Cstruct.set_uint8 buf ttl_off v\n\nlet get_proto buf = Cstruct.get_uint8 buf proto_off\nlet set_proto buf v = Cstruct.set_uint8 buf proto_off v\n\nlet get_checksum buf = Cstruct.BE.get_uint16 buf csum_off\nlet set_checksum buf value = Cstruct.BE.set_uint16 buf csum_off value\n\nlet get_src buf = Ipaddr.V4.of_int32 (Cstruct.BE.get_uint32 buf src_off)\nlet set_src buf v = Cstruct.BE.set_uint32 buf src_off (Ipaddr.V4.to_int32 v)\n\nlet get_dst buf = Ipaddr.V4.of_int32 (Cstruct.BE.get_uint32 buf dst_off)\nlet set_dst buf v = Cstruct.BE.set_uint32 buf dst_off (Ipaddr.V4.to_int32 v)\n" }, { "path": "src/ipv4/ipv4_wire.mli", "content": "val sizeof_ipv4 : int\n\nval get_hlen_version : Cstruct.t -> int\nval set_hlen_version : Cstruct.t -> int -> unit\n\nval get_tos : Cstruct.t -> int\nval set_tos : Cstruct.t -> int -> unit\n\nval get_len : Cstruct.t -> int\nval set_len : Cstruct.t -> int -> unit\n\nval get_id : Cstruct.t -> int\nval set_id : Cstruct.t -> int -> unit\n\nval get_off : Cstruct.t -> int\nval set_off : Cstruct.t -> int -> unit\n\nval get_ttl : Cstruct.t -> int\nval set_ttl : Cstruct.t -> int -> unit\n\nval get_proto : Cstruct.t -> int\nval set_proto : Cstruct.t -> int -> unit\n\nval get_checksum : Cstruct.t -> int\nval set_checksum : Cstruct.t -> int -> unit\n\nval get_src : Cstruct.t -> Ipaddr.V4.t\nval set_src : Cstruct.t -> Ipaddr.V4.t -> unit\n\nval get_dst : Cstruct.t -> Ipaddr.V4.t\nval set_dst : Cstruct.t -> Ipaddr.V4.t -> unit\n" }, { "path": "src/ipv4/routing.ml", "content": "(* RFC 1112: 01-00-5E-00-00-00 ORed with lower 23 bits of the ip address *)\nlet mac_of_multicast ip =\n let ipb = Ipaddr.V4.to_octets ip in\n let macb = Bytes.create 6 in\n Bytes.set macb 0 (Char.chr 0x01);\n Bytes.set macb 1 (Char.chr 0x00);\n Bytes.set macb 2 (Char.chr 0x5E);\n Bytes.set macb 3 (Char.chr ((Char.code ipb.[1]) land 0x7F));\n Bytes.set macb 4 (String.get ipb 2);\n Bytes.set macb 5 (String.get ipb 3);\n Macaddr.of_octets_exn (Bytes.to_string macb)\n\ntype routing_error = [ `Local | `Gateway ]\n\nmodule Make(Log : Logs.LOG) (A : Arp.S) = struct\n\n open Lwt.Infix\n\n let destination_mac network gateway arp = function\n |ip when Ipaddr.V4.(compare ip broadcast) = 0\n || Ipaddr.V4.(compare ip any) = 0\n || Ipaddr.V4.(compare (Prefix.broadcast network) ip) = 0 -> (* Broadcast *)\n Lwt.return @@ Ok Macaddr.broadcast\n |ip when Ipaddr.V4.is_multicast ip ->\n Lwt.return @@ Ok (mac_of_multicast ip)\n |ip when Ipaddr.V4.Prefix.mem ip network -> (* Local *)\n A.query arp ip >|= begin function\n | Ok mac -> Ok mac\n | Error `Timeout ->\n Log.info (fun f ->\n f \"IP.output: could not determine link-layer address for local \\\n network (%a) ip %a\" Ipaddr.V4.Prefix.pp network\n Ipaddr.V4.pp ip);\n Error `Local\n | Error e ->\n Log.info (fun f -> f \"IP.output: %a\" A.pp_error e);\n Error `Local\n end\n |ip -> (* Gateway *)\n match gateway with\n | None ->\n Log.info (fun f ->\n f \"IP.output: no route to %a (no default gateway is configured)\"\n Ipaddr.V4.pp ip);\n Lwt.return (Error `Gateway)\n | Some gateway ->\n A.query arp gateway >|= function\n | Ok mac -> Ok mac\n | Error `Timeout ->\n Log.info (fun f ->\n f \"IP.output: could not send to %a: failed to contact gateway %a\"\n Ipaddr.V4.pp ip Ipaddr.V4.pp gateway);\n Error `Gateway\n | Error e ->\n Log.info (fun f -> f \"IP.output: %a\" A.pp_error e);\n Error `Gateway\nend\n" }, { "path": "src/ipv4/static_ipv4.ml", "content": "(*\n * Copyright (c) 2010-2011 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Lwt.Infix\n\nlet src = Logs.Src.create \"ipv4\" ~doc:\"Mirage IPv4\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nmodule Make (Ethernet: Ethernet.S) (Arpv4 : Arp.S) = struct\n module Routing = Routing.Make(Log)(Arpv4)\n\n (** IO operation errors *)\n type error = [ Tcpip.Ip.error | `Would_fragment | `Ethif of Ethernet.error ]\n let pp_error ppf = function\n | #Tcpip.Ip.error as e -> Tcpip.Ip.pp_error ppf e\n | `Ethif e -> Ethernet.pp_error ppf e\n\n type ipaddr = Ipaddr.V4.t\n type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\n\n let pp_ipaddr = Ipaddr.V4.pp\n\n type prefix = Ipaddr.V4.Prefix.t\n\n let pp_prefix = Ipaddr.V4.Prefix.pp\n\n type t = {\n ethif : Ethernet.t;\n arp : Arpv4.t;\n cidr: Ipaddr.V4.Prefix.t;\n gateway: Ipaddr.V4.t option;\n mutable cache: Fragments.Cache.t;\n }\n\n let write t ?(fragment = true) ?(ttl = 38) ?src dst proto ?(size = 0) headerf bufs =\n Routing.destination_mac t.cidr t.gateway t.arp dst >>= function\n | Error `Local ->\n Log.warn (fun f -> f \"Could not find %a on the local network\" Ipaddr.V4.pp dst);\n Lwt.return @@ Error (`No_route \"no response for IP on local network\")\n | Error `Gateway when t.gateway = None ->\n Log.warn (fun f -> f \"Write to %a would require an external route, which was not provided\" Ipaddr.V4.pp dst);\n Lwt.return @@ Ok ()\n | Error `Gateway ->\n Log.warn (fun f -> f \"Write to %a requires an external route, and the provided %a was not reachable\" Ipaddr.V4.pp dst (Fmt.option Ipaddr.V4.pp) t.gateway);\n (* when a gateway is specified the user likely expects their traffic to be passed to it *)\n Lwt.return @@ Error (`No_route \"no route to default gateway to outside world\")\n | Ok mac ->\n (* need first to deal with fragmentation decision - find out mtu *)\n let mtu = Ethernet.mtu t.ethif in\n (* no options here, always 20 bytes! *)\n let hdr_len = Ipv4_wire.sizeof_ipv4 in\n let needed_bytes = Cstruct.lenv bufs + hdr_len + size in\n let multiple = needed_bytes > mtu in\n (* construct the header (will be reused across fragments) *)\n if not fragment && multiple then\n Lwt.return (Error `Would_fragment)\n else\n let off =\n match fragment, multiple with\n | true, true -> 0x2000\n | false, false -> 0x4000\n | true, false -> 0x0000\n | false, true -> assert false (* handled by conditional above *)\n in\n let hdr =\n let src = match src with None -> Ipaddr.V4.Prefix.address t.cidr | Some x -> x in\n let id = if multiple then Randomconv.int16 Mirage_crypto_rng.generate else 0 in\n Ipv4_packet.{\n options = Cstruct.empty ;\n src ; dst ; ttl ; off ; id ;\n proto = Ipv4_packet.Marshal.protocol_to_int proto }\n in\n let writeout size fill =\n Ethernet.write t.ethif mac `IPv4 ~size fill >|= function\n | Error e ->\n Log.warn (fun f -> f \"Error sending Ethernet frame: %a\"\n Ethernet.pp_error e);\n Error (`Ethif e)\n | Ok () -> Ok ()\n in\n Log.debug (fun m -> m \"ip write: mtu is %d, hdr_len is %d, size %d \\\n payload len %d, needed_bytes %d\"\n mtu hdr_len size (Cstruct.lenv bufs) needed_bytes) ;\n let leftover = ref Cstruct.empty in\n (* first fragment *)\n let fill buf =\n let payload_buf = Cstruct.shift buf hdr_len in\n let header_len = headerf payload_buf in\n if header_len > size then begin\n Log.err (fun m -> m \"headers returned length exceeding size\") ;\n invalid_arg \"headerf exceeds size\"\n end ;\n (* need to copy the given payload *)\n let len, rest =\n Cstruct.fillv ~src:bufs ~dst:(Cstruct.shift payload_buf header_len)\n in\n leftover := Cstruct.concat rest;\n let payload_len = header_len + len in\n match Ipv4_packet.Marshal.into_cstruct ~payload_len hdr buf with\n | Ok () -> payload_len + hdr_len\n | Error msg ->\n Log.err (fun m -> m \"failure while assembling ip frame: %s\" msg) ;\n invalid_arg msg\n in\n writeout (min mtu needed_bytes) fill >>= function\n | Error e -> Lwt.return (Error e)\n | Ok () ->\n if not multiple then\n Lwt.return (Ok ())\n else\n let remaining = Fragments.fragment ~mtu hdr !leftover in\n Lwt_list.fold_left_s (fun acc p ->\n match acc with\n | Error e -> Lwt.return (Error e)\n | Ok () ->\n let l = Cstruct.length p in\n writeout l (fun buf -> Cstruct.blit p 0 buf 0 l ; l))\n (Ok ()) remaining\n\n let input t ~tcp ~udp ~default buf =\n match Ipv4_packet.Unmarshal.of_cstruct buf with\n | Error s ->\n Log.info (fun m -> m \"error %s while parsing IPv4 frame %a\" s Cstruct.hexdump_pp buf);\n Lwt.return_unit\n | Ok (packet, payload) ->\n let of_interest ip =\n Ipaddr.V4.(compare ip (Prefix.address t.cidr) = 0\n || compare ip broadcast = 0\n || compare ip (Prefix.broadcast t.cidr) = 0)\n in\n if not (of_interest packet.dst) then begin\n Log.debug (fun m -> m \"dropping IP fragment not for us or broadcast %a\"\n Ipv4_packet.pp packet);\n Lwt.return_unit\n end else if Cstruct.length payload = 0 then begin\n Log.debug (fun m -> m \"dropping zero length IPv4 frame %a\" Ipv4_packet.pp packet) ;\n Lwt.return_unit\n end else\n let ts = Mirage_mtime.elapsed_ns () in\n let cache, res = Fragments.process t.cache ts packet payload in\n t.cache <- cache ;\n match res with\n | None -> Lwt.return_unit\n | Some (packet, payload) ->\n let src, dst = packet.src, packet.dst in\n match Ipv4_packet.Unmarshal.int_to_protocol packet.proto with\n | Some `TCP -> tcp ~src ~dst payload\n | Some `UDP -> udp ~src ~dst payload\n | Some `ICMP | None -> default ~proto:packet.proto ~src ~dst payload\n\n let connect\n ?(no_init = false) ~cidr ?gateway ?(fragment_cache_size = 1024 * 256) ethif arp =\n (if no_init then\n Lwt.return_unit\n else\n Arpv4.set_ips arp [Ipaddr.V4.Prefix.address cidr]) >|= fun () ->\n let cache = Fragments.Cache.empty fragment_cache_size in\n { ethif; arp; cidr; gateway; cache }\n\n let disconnect _ = Lwt.return_unit\n\n let get_ip t = [Ipaddr.V4.Prefix.address t.cidr]\n\n let configured_ips t = [t.cidr]\n\n let pseudoheader t ?src dst proto len =\n let src = match src with None -> Ipaddr.V4.Prefix.address t.cidr | Some x -> x in\n Ipv4_packet.Marshal.pseudoheader ~src ~dst ~proto len\n\n let src t ~dst:_ = Ipaddr.V4.Prefix.address t.cidr\n\n let mtu t ~dst:_ = Ethernet.mtu t.ethif - Ipv4_wire.sizeof_ipv4\n\nend\n" }, { "path": "src/ipv4/static_ipv4.mli", "content": "(*\n * Copyright (c) 2010 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nmodule Make (E: Ethernet.S) (A: Arp.S) : sig\n include Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t and type prefix = Ipaddr.V4.Prefix.t\n\n val connect : ?no_init:bool -> cidr:Ipaddr.V4.Prefix.t -> ?gateway:Ipaddr.V4.t ->\n ?fragment_cache_size:int -> E.t -> A.t -> t Lwt.t\n (** [connect ~no_init ~cidr ~gateway ~fragment_cache_size eth arp] connects the ipv4\n device using [cidr] and [gateway] for network communication. The size of\n the IPv4 fragment cache (for reassembly) can be provided in byte-size of\n fragments (defaults to 256kB). *)\nend\n" }, { "path": "src/ipv6/dune", "content": "(library\n (name tcpip_ipv6)\n (public_name tcpip.ipv6)\n (instrumentation\n (backend bisect_ppx))\n (libraries logs mirage-sleep mirage-net macaddr-cstruct tcpip.checksum\n mirage-mtime duration ipaddr cstruct tcpip randomconv\n mirage-crypto-rng ethernet ipaddr-cstruct)\n (wrapped false))\n" }, { "path": "src/ipv6/ipv6.ml", "content": "(*\n * Copyright (c) 2014 Nicolas Ojeda Bar \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\n\nlet src = Logs.Src.create \"ipv6\" ~doc:\"Mirage IPv6\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\nmodule I = Ipaddr\n\nopen Lwt.Infix\n\nmodule Make (N : Mirage_net.S)\n (E : Ethernet.S) = struct\n type ipaddr = Ipaddr.V6.t\n type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\n\n let pp_ipaddr = Ipaddr.V6.pp\n\n type prefix = Ipaddr.V6.Prefix.t\n\n let pp_prefix = Ipaddr.V6.Prefix.pp\n\n type t =\n { ethif : E.t;\n mutable ctx : Ndpv6.context }\n\n type error = [ Tcpip.Ip.error | `Ethif of E.error ]\n\n let pp_error ppf = function\n | #Tcpip.Ip.error as e -> Tcpip.Ip.pp_error ppf e\n | `Ethif e -> E.pp_error ppf e\n\n let output t (dst, size, fill) =\n E.write t.ethif dst `IPv6 ~size fill\n\n let output_ign t a = output t a >|= fun _ -> ()\n\n let start_ticking t u =\n let rec loop u =\n let now = Mirage_mtime.elapsed_ns () in\n let ctx, outs = Ndpv6.tick ~now t.ctx in\n t.ctx <- ctx;\n let u = match u, Ndpv6.get_ip t.ctx with\n | None, _ | _, [] -> u\n | Some u, _ -> Lwt.wakeup_later u (); None\n in\n Lwt_list.iter_s (output_ign t) outs (* MCP: replace with propagation *) >>= fun () ->\n Mirage_sleep.ns (Duration.of_sec 1) >>= fun () ->\n loop u\n in\n loop (Some u)\n\n let mtu t ~dst:_ = E.mtu t.ethif - Ipv6_wire.sizeof_ipv6\n\n let write t ?fragment:_ ?ttl:_ ?src dst proto ?(size = 0) headerf bufs =\n let now = Mirage_mtime.elapsed_ns () in\n (* TODO fragmentation! *)\n let payload = Cstruct.concat bufs in\n let size' = size + Cstruct.length payload in\n let fillf _ip6hdr buf =\n let h_len = headerf buf in\n if h_len > size then begin\n Log.err (fun m -> m \"provided headerf exceeds size\") ;\n invalid_arg \"headerf exceeds size\"\n end ;\n Cstruct.blit payload 0 buf h_len (Cstruct.length payload);\n h_len + Cstruct.length payload\n in\n let ctx, outs = Ndpv6.send ~now t.ctx ?src dst proto size' fillf in\n t.ctx <- ctx;\n let fail_any progress data =\n let squeal = function\n | Ok () as ok -> Lwt.return ok\n | Error e ->\n Log.warn (fun f -> f \"ethif write errored: %a\" E.pp_error e);\n Lwt.return @@ Error (`Ethif e)\n in\n match progress with\n | Ok () -> output t data >>= squeal\n | Error e -> Lwt.return @@ Error e\n in\n (* MCP - it's not totally clear to me that this the right behavior\n for writev. *)\n Lwt_list.fold_left_s fail_any (Ok ()) outs\n\n let input t ~tcp ~udp ~default buf =\n let now = Mirage_mtime.elapsed_ns () in\n let ctx, outs, actions = Ndpv6.handle ~now t.ctx buf in\n t.ctx <- ctx;\n Lwt_list.iter_s (function\n | `Tcp (src, dst, buf) -> tcp ~src ~dst buf\n | `Udp (src, dst, buf) -> udp ~src ~dst buf\n | `Default (proto, src, dst, buf) -> default ~proto ~src ~dst buf\n ) actions >>= fun () ->\n (* MCP: replace below w/proper error propagation *)\n Lwt_list.iter_s (output_ign t) outs\n\n let disconnect _ = (* TODO *)\n Lwt.return_unit\n\n let src t ~dst = Ndpv6.select_source t.ctx dst\n\n let get_ip t =\n Ndpv6.get_ip t.ctx\n\n let configured_ips t =\n Ndpv6.configured_ips t.ctx\n\n let pseudoheader t ?src:source dst proto len =\n let ph = Cstruct.create (16 + 16 + 8) in\n let src = match source with None -> src t ~dst | Some x -> x in\n Ipv6_wire.set_ip ph 0 src;\n Ipv6_wire.set_ip ph 16 dst;\n Cstruct.BE.set_uint32 ph 32 (Int32.of_int len);\n Cstruct.set_uint8 ph 36 0;\n Cstruct.set_uint8 ph 37 0;\n Cstruct.set_uint8 ph 38 0;\n Cstruct.set_uint8 ph 39 (Ipv6_wire.protocol_to_int proto);\n ph\n\n let connect ?(no_init = false) ?(handle_ra = true) ?cidr ?gateway netif ethif =\n Log.info (fun f -> f \"IP6: Starting\");\n let now = Mirage_mtime.elapsed_ns () in\n let ctx, outs = Ndpv6.local ~handle_ra ~now (E.mac ethif) in\n let ctx, outs = match cidr with\n | None -> ctx, outs\n | Some p ->\n let ctx, outs' = Ndpv6.add_ip ~now ctx p in\n let ctx = Ndpv6.add_prefix ~now ctx (Ipaddr.V6.Prefix.prefix p) in\n ctx, outs @ outs'\n in\n let ctx = match gateway with\n | None -> ctx\n | Some ip -> Ndpv6.add_routers ~now ctx [ip]\n in\n let t = {ctx; ethif} in\n if no_init then\n Lwt.return t\n else\n let task, u = Lwt.task () in\n Lwt.async (fun () -> start_ticking t u);\n (* call listen until we're good in respect to DAD *)\n let ethif_listener =\n let noop ~src:_ ~dst:_ _ = Lwt.return_unit in\n E.input ethif\n ~arpv4:(fun _ -> Lwt.return_unit)\n ~ipv4:(fun _ -> Lwt.return_unit)\n ~ipv6:(input t ~tcp:noop ~udp:noop ~default:(fun ~proto:_ -> noop))\n in\n let timeout = Mirage_sleep.ns (Duration.of_sec 3) in\n Lwt.pick [\n (* MCP: replace this error swallowing with proper propagation *)\n (Lwt_list.iter_s (output_ign t) outs >>= fun () ->\n task) ;\n (N.listen netif ~header_size:Ethernet.Packet.sizeof_ethernet ethif_listener >|= fun _ -> ()) ;\n timeout\n ] >>= fun () ->\n let expected_ips = match cidr with None -> 1 | Some _ -> 2 in\n match get_ip t with\n | ips when List.length ips = expected_ips ->\n Log.info (fun f -> f \"IP6: Started with %a\"\n Fmt.(list ~sep:(any \",@ \") Ipaddr.V6.pp) ips);\n Lwt.return t\n | _ -> Lwt.fail_with \"IP6 not started, couldn't assign IP addresses\"\nend\n" }, { "path": "src/ipv6/ipv6.mli", "content": "(*\n * Copyright (c) 2014 Nicolas Ojeda Bar \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nmodule Make (N : Mirage_net.S)\n (E : Ethernet.S) : sig\n include Tcpip.Ip.S with type ipaddr = Ipaddr.V6.t and type prefix = Ipaddr.V6.Prefix.t\n val connect :\n ?no_init:bool ->\n ?handle_ra:bool ->\n ?cidr:Ipaddr.V6.Prefix.t ->\n ?gateway:Ipaddr.V6.t ->\n N.t -> E.t -> t Lwt.t\nend\n" }, { "path": "src/ipv6/ipv6_wire.ml", "content": "let sizeof_ipv6 = 40\n\nlet int_to_protocol = function\n | 58 -> Some `ICMP\n | 6 -> Some `TCP\n | 17 -> Some `UDP\n | _ -> None\n\nlet protocol_to_int = function\n | `ICMP -> 58\n | `TCP -> 6\n | `UDP -> 17\n\nlet set_ip buf off v =\n Ipaddr_cstruct.V6.write_cstruct_exn v (Cstruct.shift buf off)\nlet get_ip buf off =\n Ipaddr_cstruct.V6.of_cstruct_exn (Cstruct.shift buf off)\n\nlet version_flow_off = 0\nlet len_off = 4\nlet nhdr_off = 6\nlet hlim_off = 7\nlet src_off = 8\nlet dst_off = 24\n\nlet get_version_flow buf = Cstruct.BE.get_uint32 buf version_flow_off\nlet set_version_flow buf v = Cstruct.BE.set_uint32 buf version_flow_off v\n\nlet get_nhdr buf = Cstruct.get_uint8 buf nhdr_off\nlet set_nhdr buf v = Cstruct.set_uint8 buf nhdr_off v\n\nlet get_len buf = Cstruct.BE.get_uint16 buf len_off\nlet set_len buf v = Cstruct.BE.set_uint16 buf len_off v\n\nlet get_hlim buf = Cstruct.get_uint8 buf hlim_off\nlet set_hlim buf v = Cstruct.set_uint8 buf hlim_off v\n\nlet get_src buf = get_ip buf src_off\nlet set_src buf v = set_ip buf src_off v\n\nlet get_dst buf = get_ip buf dst_off\nlet set_dst buf v = set_ip buf dst_off v\n\nlet ty_off = 0\nlet get_ty buf = Cstruct.get_uint8 buf ty_off\nlet set_ty buf v = Cstruct.set_uint8 buf ty_off v\n\nlet code_off = 1\nlet get_code buf = Cstruct.get_uint8 buf code_off\nlet set_code buf v = Cstruct.set_uint8 buf code_off v\n\nmodule Ns = struct\n let sizeof_ns = 24\n\n let csum_off = 2\n let reserved_off = 4\n let target_off = 8\n\n let get_checksum buf = Cstruct.BE.get_uint16 buf csum_off\n let set_checksum buf v = Cstruct.BE.set_uint16 buf csum_off v\n let get_reserved buf = Cstruct.BE.get_uint32 buf reserved_off\n let set_reserved buf v = Cstruct.BE.set_uint32 buf reserved_off v\n let get_target buf = get_ip buf target_off\n let set_target buf v = set_ip buf target_off v\nend\n\nmodule Llopt = struct\n let sizeof_llopt = 8\n\n let len_off = 1\n let addr_off = 2\n\n let get_len buf = Cstruct.get_uint8 buf len_off\n let set_len buf v = Cstruct.set_uint8 buf len_off v\n\n let get_addr buf = Macaddr_cstruct.of_cstruct_exn (Cstruct.shift buf addr_off)\n let set_addr buf v =\n Macaddr_cstruct.write_cstruct_exn v (Cstruct.shift buf addr_off)\nend\n\nmodule Icmpv6 = struct\n let sizeof_icmpv6 = 8\n\n let _reserved_off = 4\n\n let set_checksum = Ns.set_checksum\nend\n\nmodule Na = struct\n let sizeof_na = 24\n\n let get_reserved = Ns.get_reserved\n let set_reserved = Ns.set_reserved\n let get_target = Ns.get_target\n let set_target = Ns.set_target\n\n let get_first_reserved_byte buf =\n Cstruct.get_uint8 buf Ns.reserved_off\n\n let get_router buf = (get_first_reserved_byte buf land 0x80) <> 0\n let get_solicited buf = (get_first_reserved_byte buf land 0x40) <> 0\n let get_override buf = (get_first_reserved_byte buf land 0x20) <> 0\nend\n\nmodule Rs = struct\n let sizeof_rs = 8\n\n let set_checksum = Ns.set_checksum\n let set_reserved = Ns.set_reserved\nend\n\nmodule Pingv6 = struct\n let sizeof_pingv6 = 8\n\n let id_off = 4\n let seq_off = 6\n\n let get_checksum = Ns.get_checksum\n let set_checksum = Ns.set_checksum\n\n let get_id buf = Cstruct.BE.get_uint16 buf id_off\n let set_id buf v = Cstruct.BE.set_uint16 buf id_off v\n\n let get_seq buf = Cstruct.BE.set_uint16 buf seq_off\n let set_seq buf v = Cstruct.BE.set_uint16 buf seq_off v\nend\n\nmodule Opt = struct\n let sizeof_opt = 2\n\n let get_len = Llopt.get_len\n let set_len = Llopt.set_len\nend\n\nmodule Opt_prefix = struct\n let sizeof_opt_prefix = 32\n\n let get_len = Llopt.get_len\n let set_len = Llopt.set_len\n\n let prefix_len_off = 2\n let get_prefix_len buf = Cstruct.get_uint8 buf prefix_len_off\n let set_prefix_len buf v = Cstruct.set_uint8 buf prefix_len_off v\n\n let reserved1_off = 3\n let get_reserved1 buf = Cstruct.get_uint8 buf reserved1_off\n let set_reserved1 buf v = Cstruct.set_uint8 buf reserved1_off v\n\n let valid_lifetime_off = 4\n let get_valid_lifetime buf = Cstruct.BE.get_uint32 buf valid_lifetime_off\n let set_valid_lifetime buf v = Cstruct.BE.set_uint32 buf valid_lifetime_off v\n\n let preferred_lifetime_off = 8\n let get_preferred_lifetime buf = Cstruct.BE.get_uint32 buf preferred_lifetime_off\n let set_preferred_lifetime buf v = Cstruct.BE.set_uint32 buf preferred_lifetime_off v\n\n let reserved2_off = 12\n\n let prefix_off = 16\n let get_prefix buf = get_ip buf prefix_off\n let set_prefix buf v = set_ip buf prefix_off v\n\n let on_link buf = get_reserved1 buf land 0x80 <> 0\n\n let autonomous buf = get_reserved1 buf land 0x40 <> 0\n\nend\n\nmodule Ra = struct\n let sizeof_ra = 16\n\n let get_checksum = Ns.get_checksum\n let set_checksum = Ns.set_checksum\n\n let cur_hop_limit_off = 4\n let get_cur_hop_limit buf = Cstruct.get_uint8 buf cur_hop_limit_off\n\n let reserved_off = 5\n\n let router_lifetime_off = 6\n let get_router_lifetime buf = Cstruct.BE.get_uint16 buf router_lifetime_off\n\n let reachable_time_off = 8\n let get_reachable_time buf = Cstruct.BE.get_uint32 buf reachable_time_off\n\n let retrans_timer_off = 12\n let get_retrans_timer buf = Cstruct.BE.get_uint32 buf retrans_timer_off\nend\n\nmodule Redirect = struct\n let sizeof_redirect = 40\n\n let get_checksum = Ns.get_checksum\n let set_checksum = Ns.set_checksum\n\n let get_reserved = Ns.get_reserved\n let set_reserved = Ns.set_reserved\n\n let get_target = Ns.get_target\n let set_target = Ns.set_target\n\n let destination_off = 24\n let get_destination buf = get_ip buf destination_off\n let set_destination buf v = set_ip buf destination_off v\nend\n\n(* let sizeof_ipv6_pseudo_header = 16 + 16 + 4 + 4 *)\n" }, { "path": "src/ipv6/ndpv6.ml", "content": "(*\n * Copyright (c) 2015 Nicolas Ojeda Bar \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\n(*\nReferences:\n\n- Transmission of IPv6 packets over Ethernet networks\n http://tools.ietf.org/html/rfc2464\n\n- IPv6 Stateless Address Autoconfiguration\n https://tools.ietf.org/html/rfc2462\n\n- Neighbor Discovery for IP Version 6 (IPv6)\n https://tools.ietf.org/html/rfc2461\n\n- Internet Control Message Protocol (ICMPv6)\n http://tools.ietf.org/html/rfc2463\n\n- IPv6 Node Requirements\n http://tools.ietf.org/html/rfc6434\n\n- Multicast Listener Discovery Version 2 (MLDv2) for IPv6\n http://tools.ietf.org/html/rfc3810\n*)\n\nlet src = Logs.Src.create \"ndpc6\" ~doc:\"Mirage IPv6 discovery\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nmodule Ipaddr = Ipaddr.V6\n\ntype ipaddr = Ipaddr.t\ntype prefix = Ipaddr.Prefix.t\ntype time = int64\n\nmodule BoundedMap (K : Map.OrderedType) : sig\n type 'a t\n val empty: int -> 'a t\n val push: K.t -> 'a -> 'a t -> 'a t\n val pop: K.t -> 'a t -> 'a list * 'a t\nend = struct\n module M = Map.Make (K)\n type 'a t = 'a list M.t * int\n let empty n = (M.empty, n)\n let push k d (m, n) =\n let l = try M.find k m with Not_found -> [] in\n match l, List.length l >= n with\n | _, false ->\n M.add k (l @ [d]) m, n\n | _ :: l, true ->\n M.add k (d :: l) m, n\n | [], true ->\n m, n\n let pop k (m, n) =\n let l = try M.find k m with Not_found -> [] in\n l, (M.remove k m, n)\nend\n\nmodule PacketQueue = BoundedMap (Ipaddr)\n\nlet solicited_node_prefix =\n Ipaddr.(Prefix.make 104 (of_int16 (0xff02, 0, 0, 0, 0, 1, 0xff00, 0)))\n\nmodule Defaults = struct\n let _max_rtr_solicitation_delay = Duration.of_sec 1\n let _ptr_solicitation_interval = 4\n let _max_rtr_solicitations = 3\n let max_multicast_solicit = 3\n let max_unicast_solicit = 3\n let _max_anycast_delay_time = 1\n let _max_neighbor_advertisement = 3\n let delay_first_probe_time = Duration.of_sec 5\n\n let link_mtu = 1500 (* RFC 2464, 2. *)\n let _min_link_mtu = 1280\n\n let dup_addr_detect_transmits = 1\n\n let min_random_factor = 0.5\n let max_random_factor = 1.5\n let reachable_time = Duration.of_sec 30\n let retrans_timer = Duration.of_sec 1\nend\n\nlet interface_addr mac =\n let bmac = Macaddr.to_octets mac in\n let c i = Char.code (String.get bmac i) in\n Ipaddr.make\n 0 0 0 0\n ((c 0 lxor 2) lsl 8 + c 1)\n (c 2 lsl 8 + 0xff)\n (0xfe00 + c 3)\n (c 4 lsl 8 + c 5)\n\nlet link_local_addr mac =\n let addr = Ipaddr.(Prefix.network_address Prefix.link (interface_addr mac)) in\n Ipaddr.Prefix.(make (bits link) addr)\n\nlet multicast_mac =\n let pbuf = Cstruct.create 6 in\n Cstruct.BE.set_uint16 pbuf 0 0x3333;\n fun ip ->\n let _, _, _, n = Ipaddr.to_int32 ip in\n Cstruct.BE.set_uint32 pbuf 2 n;\n Macaddr_cstruct.of_cstruct_exn pbuf\n\n(* vary the reachable time by some random factor between 0.5 and 1.5 *)\nlet compute_reachable_time reachable_time =\n let factor =\n Defaults.min_random_factor +.\n Randomconv.float ~bound:Defaults.(max_random_factor -. min_random_factor)\n Mirage_crypto_rng.generate\n in\n Int64.of_float (factor *. Int64.to_float reachable_time)\n\nlet cksum_buf = Cstruct.create 8\n\nlet checksum' ~proto frame bufs =\n Cstruct.BE.set_uint32 cksum_buf 0 (Int32.of_int (Cstruct.lenv bufs));\n Cstruct.BE.set_uint32 cksum_buf 4 (Int32.of_int proto);\n let src_dst = Cstruct.sub frame 8 (2 * 16) in\n Tcpip_checksum.ones_complement_list (src_dst :: cksum_buf :: bufs)\n\nlet checksum frame bufs =\n let proto = Ipv6_wire.get_nhdr frame in\n checksum' ~proto frame bufs\n\nmodule Allocate = struct\n let hdr ~hlim ~src ~dst ~proto ~size fillf =\n let size' = size + Ipv6_wire.sizeof_ipv6 in\n let fill ipbuf =\n Ipv6_wire.set_version_flow ipbuf 0x60000000l; (* IPv6 *)\n Ipv6_wire.set_len ipbuf size;\n Ipv6_wire.set_src ipbuf src;\n Ipv6_wire.set_dst ipbuf dst;\n Ipv6_wire.set_hlim ipbuf hlim;\n Ipv6_wire.set_nhdr ipbuf (Ipv6_wire.protocol_to_int proto);\n let hdr, payload = Cstruct.split ipbuf Ipv6_wire.sizeof_ipv6 in\n let len' = fillf hdr payload in\n len' + Ipv6_wire.sizeof_ipv6\n in\n (size', fill)\n\n let ns ~specified ~mac ~src ~dst ~tgt =\n let size = Ipv6_wire.Ns.sizeof_ns + if specified then Ipv6_wire.Llopt.sizeof_llopt else 0 in\n let fillf hdr icmpbuf =\n let optbuf = Cstruct.shift icmpbuf Ipv6_wire.Ns.sizeof_ns in\n Ipv6_wire.set_ty icmpbuf 135; (* NS *)\n Ipv6_wire.set_code icmpbuf 0;\n Ipv6_wire.Ns.set_reserved icmpbuf 0l;\n Ipv6_wire.Ns.set_target icmpbuf tgt;\n if specified then begin\n Ipv6_wire.set_ty optbuf 1;\n Ipv6_wire.Llopt.set_len optbuf 1;\n Ipv6_wire.Llopt.set_addr optbuf mac;\n end;\n Ipv6_wire.Icmpv6.set_checksum icmpbuf 0;\n Ipv6_wire.Icmpv6.set_checksum icmpbuf @@ checksum hdr [ icmpbuf ];\n size\n in\n hdr ~src ~dst ~hlim:255 ~proto:`ICMP ~size fillf\n\n let na ~mac ~src ~dst ~tgt ~sol =\n let size = Ipv6_wire.Na.sizeof_na + Ipv6_wire.Llopt.sizeof_llopt in\n let fillf hdr icmpbuf =\n let optbuf = Cstruct.shift icmpbuf Ipv6_wire.Na.sizeof_na in\n Ipv6_wire.set_ty icmpbuf 136; (* NA *)\n Ipv6_wire.set_code icmpbuf 0;\n Ipv6_wire.Na.set_reserved icmpbuf (if sol then 0x60000000l else 0x20000000l);\n Ipv6_wire.Na.set_target icmpbuf tgt;\n Ipv6_wire.set_ty optbuf 2;\n Ipv6_wire.Llopt.set_len optbuf 1;\n Ipv6_wire.Llopt.set_addr optbuf mac;\n Ipv6_wire.Icmpv6.set_checksum icmpbuf 0;\n Ipv6_wire.Icmpv6.set_checksum icmpbuf @@ checksum hdr [ icmpbuf ];\n size\n in\n hdr ~src ~dst ~hlim:255 ~proto:`ICMP ~size fillf\n\n let rs ~mac select_source =\n let dst = Ipaddr.link_routers in\n let src = select_source ~dst in\n let cmp = Ipaddr.compare in\n let include_slla = (cmp src Ipaddr.unspecified) != 0 in\n let slla_len = if include_slla then Ipv6_wire.Llopt.sizeof_llopt else 0 in\n let size = Ipv6_wire.Rs.sizeof_rs + slla_len in\n let fillf hdr icmpbuf =\n Ipv6_wire.set_ty icmpbuf 133;\n Ipv6_wire.set_code icmpbuf 0;\n Ipv6_wire.Rs.set_reserved icmpbuf 0l;\n if include_slla then begin\n let optbuf = Cstruct.shift icmpbuf Ipv6_wire.Rs.sizeof_rs in\n Ipv6_wire.set_ty optbuf 1;\n Ipv6_wire.Llopt.set_len optbuf 1;\n Ipv6_wire.Llopt.set_addr optbuf mac\n end;\n Ipv6_wire.Icmpv6.set_checksum icmpbuf 0;\n Ipv6_wire.Icmpv6.set_checksum icmpbuf @@ checksum hdr [ icmpbuf ];\n size\n in\n hdr ~src ~dst ~hlim:255 ~proto:`ICMP ~size fillf\n\n let pong ~src ~dst ~hlim ~id ~seq ~data =\n (* TODO data may exceed size, fragment? *)\n let size = Ipv6_wire.Pingv6.sizeof_pingv6 + Cstruct.length data in\n let fillf hdr icmpbuf =\n Ipv6_wire.set_ty icmpbuf 129; (* ECHO REPLY *)\n Ipv6_wire.set_code icmpbuf 0;\n Ipv6_wire.Pingv6.set_id icmpbuf id;\n Ipv6_wire.Pingv6.set_seq icmpbuf seq;\n Ipv6_wire.Pingv6.set_checksum icmpbuf 0;\n Cstruct.blit data 0 icmpbuf Ipv6_wire.Pingv6.sizeof_pingv6 (Cstruct.length data);\n Ipv6_wire.Pingv6.set_checksum icmpbuf @@ checksum hdr [ icmpbuf ];\n size\n in\n hdr ~src ~dst ~hlim ~proto:`ICMP ~size fillf\nend\n\ntype ns =\n { ns_target : Ipaddr.t;\n ns_slla : Macaddr.t option }\n\ntype pfx =\n { pfx_on_link : bool;\n pfx_autonomous : bool;\n pfx_valid_lifetime : time option;\n pfx_preferred_lifetime : time option;\n pfx_prefix : Ipaddr.Prefix.t }\n\ntype ra =\n { ra_cur_hop_limit : int;\n ra_router_lifetime : time;\n ra_reachable_time : time option;\n ra_retrans_timer : time option;\n ra_slla : Macaddr.t option;\n ra_prefix : pfx list }\n\ntype na =\n { na_router : bool;\n na_solicited : bool;\n na_override : bool;\n na_target : Ipaddr.t;\n na_tlla : Macaddr.t option }\n\ntype redirect =\n { target : Ipaddr.t;\n destination : Ipaddr.t }\n\ntype action =\n | SendNS of [`Unspecified | `Specified ] * ipaddr * ipaddr\n | SendNA of ipaddr * ipaddr * ipaddr * [`Solicited | `Unsolicited]\n | SendRS\n | SendQueued of ipaddr * Macaddr.t\n | CancelQueued of ipaddr\n\nmodule AddressList = struct\n\n type state =\n | TENTATIVE of (time * time option) option * int * time\n | PREFERRED of (time * time option) option\n | DEPRECATED of time option\n\n type t =\n (Ipaddr.Prefix.t * state) list\n\n let empty =\n []\n\n let to_list al =\n let rec loop = function\n | [] -> []\n | (_, TENTATIVE _) :: rest -> loop rest\n | (ip, (PREFERRED _ | DEPRECATED _)) :: rest -> ip :: loop rest\n in\n loop al\n\n let select_source al ~dst:_ =\n let rec loop = function\n | (_, TENTATIVE _) :: rest -> loop rest\n | (ip, _) :: _ -> Ipaddr.Prefix.address ip (* FIXME *)\n | [] -> Ipaddr.unspecified\n in\n loop al\n\n let tick_one ~now ~retrans_timer = function\n | (prefix, TENTATIVE (timeout, n, t)) when t <= now ->\n if n + 1 >= Defaults.dup_addr_detect_transmits then\n let timeout = match timeout with\n | None -> None\n | Some (preferred_lifetime, valid_lifetime) ->\n Some (Int64.add now preferred_lifetime, valid_lifetime)\n in\n let ip = Ipaddr.Prefix.address prefix in\n Log.debug (fun f -> f \"SLAAC: %a --> PREFERRED\" Ipaddr.pp ip);\n Some (prefix, PREFERRED timeout), []\n else\n let ip = Ipaddr.Prefix.address prefix in\n let dst = Ipaddr.Prefix.network_address solicited_node_prefix ip in\n Some (prefix, TENTATIVE (timeout, n+1, Int64.add now retrans_timer)),\n [SendNS (`Unspecified, dst, ip)]\n | prefix, PREFERRED (Some (preferred_timeout, valid_lifetime)) when preferred_timeout <= now ->\n let ip = Ipaddr.Prefix.address prefix in\n Log.debug (fun f -> f \"SLAAC: %a --> DEPRECATED\" Ipaddr.pp ip);\n let valid_timeout = match valid_lifetime with\n | None -> None\n | Some valid_lifetime -> Some (Int64.add now valid_lifetime)\n in\n Some (prefix, DEPRECATED valid_timeout), []\n | prefix, DEPRECATED (Some t) when t <= now ->\n let ip = Ipaddr.Prefix.address prefix in\n Log.debug (fun f -> f \"SLAAC: %a --> EXPIRED\" Ipaddr.pp ip);\n None, []\n | x ->\n Some x, []\n\n let tick al ~now ~retrans_timer =\n List.fold_right (fun ip (ips, acts) ->\n let addr, acts' = tick_one ~now ~retrans_timer ip in\n let acts = acts' @ acts in\n let ips = match addr with Some ip -> ip :: ips | None -> ips in\n ips, acts\n ) al ([], [])\n\n let _expired al ~now =\n List.exists (function\n | _, TENTATIVE (_, _, t)\n | _, PREFERRED (Some (t, _))\n | _, DEPRECATED (Some t) -> t <= now\n | _ -> false\n ) al\n\n let add al ~now ~retrans_timer ~lft ip =\n match List.mem_assoc ip al with\n | false ->\n let al = (ip, TENTATIVE (lft, 0, Int64.add now retrans_timer)) :: al in\n let src = Ipaddr.Prefix.address ip in\n let dst = Ipaddr.Prefix.network_address solicited_node_prefix src in\n al, [SendNS (`Unspecified, dst, src)]\n | true ->\n Log.warn (fun f -> f \"ndpv6: attempted to add ip %a already in address list\"\n Ipaddr.Prefix.pp ip);\n al, []\n\n let is_my_addr al ip =\n List.exists (function\n | _, TENTATIVE _ -> false\n | ip', (PREFERRED _ | DEPRECATED _) -> Ipaddr.(compare (Prefix.address ip') ip) = 0\n ) al\n\n let find_prefix al pfx =\n let rec loop = function\n | (ip, _) :: _ when Ipaddr.Prefix.mem (Ipaddr.Prefix.address ip) pfx -> Some ip\n | _ :: rest -> loop rest\n | [] -> None\n in\n loop al\n\n let configure al ~now ~retrans_timer ~lft mac pfx =\n (* FIXME is this the same as add ? *)\n match find_prefix al pfx with\n | Some _addr ->\n (* TODO handle already configured SLAAC address 5.5.3 e). *)\n al, []\n | None ->\n let ip = Ipaddr.Prefix.network_address pfx (interface_addr mac) in\n let prefix = Ipaddr.Prefix.(make (bits pfx) ip) in\n add al ~now ~retrans_timer ~lft prefix\n\n let handle_na al ip =\n (* FIXME How to notify the client? *)\n match List.partition (fun (pre, _) -> Ipaddr.Prefix.mem ip pre) al with\n | [ (_, TENTATIVE _) ], rest ->\n Log.info (fun f -> f \"DAD: Failed: %a\" Ipaddr.pp ip);\n rest\n | _ -> al\nend\n\nmodule PrefixList = struct\n\n type t =\n (Ipaddr.Prefix.t * time option) list\n\n let link_local =\n [Ipaddr.Prefix.link, None]\n\n let to_list pl =\n List.map fst pl\n\n let is_local pl ip =\n List.exists (fun (pfx, _) -> Ipaddr.Prefix.mem ip pfx) pl\n\n let tick pl ~now =\n List.filter (function (_, Some t) -> t > now | (_, None) -> true) pl\n\n let add pl ~now pfx ~vlft =\n let vlft = match vlft with\n | None -> None\n | Some dt -> Some (Int64.add now dt)\n in\n match List.mem_assoc pfx pl with\n | false ->\n (pfx, vlft) :: pl\n | true ->\n let pl = List.remove_assoc pfx pl in\n (pfx, vlft) :: pl\n\n let handle_ra pl ~now ~vlft pfx =\n\n (* RFC 2461, 6.3.4.\n\n For each Prefix Information option with the on-link flag set, a host\n does the following:\n\n - If the prefix is the link-local prefix, silently ignore the\n Prefix Information option.\n\n - If the prefix is not already present in the Prefix List, and the Prefix\n Information option's Valid Lifetime field is non-zero, create a new\n entry for the prefix and initialize its invalidation timer to the Valid\n Lifetime value in the Prefix Information option.\n\n - If the prefix is already present in the host's Prefix List as the\n result of a previously-received advertisement, reset its invalidation\n timer to the Valid Lifetime value in the Prefix Information option. If\n the new Lifetime value is zero, time-out the prefix immediately (see\n Section 6.3.5).\n\n - If the Prefix Information option's Valid Lifetime field is zero, and\n the prefix is not present in the host's Prefix List, silently ignore\n the option. *)\n\n Log.debug (fun f -> f \"ND6: Processing PREFIX option in RA\");\n if Ipaddr.Prefix.link <> pfx then\n match vlft, List.mem_assoc pfx pl with\n | Some 0L, true ->\n Log.debug (fun f -> f \"ND6: Removing PREFIX: pfx=%a\" Ipaddr.Prefix.pp pfx);\n List.remove_assoc pfx pl, []\n | Some 0L, false ->\n pl, []\n | Some dt, true ->\n Log.debug (fun f -> f \"ND6: Refreshing PREFIX: pfx=%a lft=%Lu\" Ipaddr.Prefix.pp pfx dt);\n let pl = List.remove_assoc pfx pl in\n (pfx, Some (Int64.add now dt)) :: pl, []\n | Some dt, false ->\n Log.debug (fun f -> f \"ND6: Received new PREFIX: pfx=%a lft=%Lu\" Ipaddr.Prefix.pp pfx dt);\n (pfx, Some (Int64.add now dt)) :: pl, []\n | None, true ->\n Log.debug (fun f -> f \"ND6: Refreshing PREFIX: pfx=%a lft=inf\" Ipaddr.Prefix.pp pfx);\n let pl = List.remove_assoc pfx pl in\n (pfx, None) :: pl, []\n | None, false ->\n Log.debug (fun f -> f \"ND6: Received new PREFIX: pfx=%a lft=inf\" Ipaddr.Prefix.pp pfx);\n (pfx, None) :: pl, []\n else\n pl, []\nend\n\nmodule NeighborCache = struct\n\n type state =\n | INCOMPLETE of time * int\n | REACHABLE of time * Macaddr.t\n | STALE of Macaddr.t\n | DELAY of time * Macaddr.t\n | PROBE of time * int * Macaddr.t\n\n type info =\n { state : state;\n is_router : bool }\n\n module IpMap = Map.Make (Ipaddr)\n\n type t =\n info IpMap.t\n\n let empty =\n IpMap.empty\n\n let tick_one ~now ~retrans_timer ip nb nc =\n match nb.state with\n | INCOMPLETE (t, tn) when t <= now ->\n if tn < Defaults.max_multicast_solicit then begin\n Log.debug (fun f -> f \"NUD: %a --> INCOMPLETE [Timeout]\" Ipaddr.pp ip);\n let dst = Ipaddr.Prefix.network_address solicited_node_prefix ip in\n IpMap.add ip {nb with state = INCOMPLETE ((Int64.add now retrans_timer), tn+1)} nc,\n [SendNS (`Specified, dst, ip)]\n end else begin\n Log.debug (fun f -> f \"NUD: %a --> UNREACHABLE [Discarding]\" Ipaddr.pp ip);\n (* TODO Generate ICMP error: Destination Unreachable *)\n IpMap.remove ip nc, [CancelQueued ip]\n end\n | REACHABLE (t, mac) when t <= now ->\n Log.debug (fun f -> f \"NUD: %a --> STALE\" Ipaddr.pp ip);\n IpMap.add ip {nb with state = STALE mac} nc, []\n | DELAY (t, dmac) when t <= now ->\n Log.debug (fun f -> f \"NUD: %a --> PROBE\" Ipaddr.pp ip);\n IpMap.add ip {nb with state = PROBE ((Int64.add now retrans_timer), 0, dmac)} nc,\n [SendNS (`Specified, ip, ip)]\n | PROBE (t, tn, dmac) when t <= now ->\n if tn < Defaults.max_unicast_solicit then begin\n Log.debug (fun f -> f \"NUD: %a --> PROBE [Timeout]\" Ipaddr.pp ip);\n IpMap.add ip {nb with state = PROBE ((Int64.add now retrans_timer), tn+1, dmac)} nc,\n [SendNS (`Specified, ip, ip)]\n end else begin\n Log.debug (fun f -> f \"NUD: %a --> UNREACHABLE [Discarding]\" Ipaddr.pp ip);\n IpMap.remove ip nc, []\n end\n | _ ->\n nc, []\n\n let tick nc ~now ~retrans_timer =\n IpMap.fold\n (fun ip nb (nc, acts) ->\n let nc, acts' = tick_one ~now ~retrans_timer ip nb nc in\n nc, acts' @ acts) nc (nc, [])\n\n let handle_ns nc ~src new_mac =\n let nb =\n if IpMap.mem src nc then\n IpMap.find src nc\n else\n {state = STALE new_mac; is_router = false}\n in\n let nb, acts =\n match nb.state with\n | INCOMPLETE _ ->\n let nb = {nb with state = STALE new_mac} in\n nb, [SendQueued (src, new_mac)]\n | REACHABLE (_, mac) | STALE mac | DELAY (_, mac) | PROBE (_, _, mac) ->\n let nb = if mac <> new_mac then {nb with state = STALE new_mac} else nb in\n nb, []\n in\n IpMap.add src nb nc, acts\n\n let handle_ra nc ~src new_mac =\n Log.debug (fun f -> f \"ND6: Processing SLLA option in RA\");\n let nb =\n try\n let nb = IpMap.find src nc in\n {nb with is_router = true}\n with\n | Not_found ->\n {state = STALE new_mac; is_router = true}\n in\n match nb.state with\n | INCOMPLETE _ ->\n let nb = {nb with state = STALE new_mac} in\n IpMap.add src nb nc, [SendQueued (src, new_mac)]\n | REACHABLE (_, mac) | STALE mac | DELAY (_, mac) | PROBE (_, _, mac) ->\n let nb = if mac <> new_mac then {nb with state = STALE new_mac} else nb in\n IpMap.add src nb nc, []\n\n let handle_na nc ~now ~reachable_time ~rtr ~sol ~ovr ~tgt ~lladdr =\n let new_mac = lladdr in\n\n let update nb =\n match nb.state, new_mac, sol, ovr with\n | INCOMPLETE _, Some new_mac, false, _ ->\n Log.debug (fun f -> f \"NUD: %a --> STALE\" Ipaddr.pp tgt);\n let nb = {nb with state = STALE new_mac} in\n IpMap.add tgt nb nc, [SendQueued (tgt, new_mac)]\n | INCOMPLETE _, Some new_mac, true, _ ->\n Log.debug (fun f -> f \"NUD: %a --> REACHABLE\" Ipaddr.pp tgt);\n let nb = {nb with state = REACHABLE ((Int64.add now reachable_time), new_mac)} in\n IpMap.add tgt nb nc, [SendQueued (tgt, new_mac)]\n | INCOMPLETE _, None, _, _ ->\n let nc =\n if nb.is_router != rtr then\n IpMap.add tgt {nb with is_router = rtr} nc\n else\n nc\n in\n nc, []\n | PROBE (_, _, mac), Some new_mac, true, false when mac = new_mac ->\n Log.debug (fun f -> f \"NUD: %a --> REACHABLE\" Ipaddr.pp tgt);\n let nb = {nb with state = REACHABLE ((Int64.add now reachable_time), new_mac)} in\n IpMap.add tgt nb nc, []\n | PROBE (_, _, mac), None, true, false ->\n Log.debug (fun f -> f \"NUD: %a --> REACHABLE\" Ipaddr.pp tgt);\n let nb = {nb with state = REACHABLE ((Int64.add now reachable_time), mac)} in\n IpMap.add tgt nb nc, []\n | (REACHABLE _ | STALE _ | DELAY _ | PROBE _), None, _, _ ->\n let nc =\n if nb.is_router != rtr then\n IpMap.add tgt {nb with is_router = rtr} nc\n else\n nc\n in\n nc, []\n | REACHABLE (_, mac), Some new_mac, true, false when mac <> new_mac ->\n Log.debug (fun f -> f \"NUD: %a --> STALE\" Ipaddr.pp tgt);\n let nb = {nb with state = STALE mac} in (* TODO check mac or new_mac *)\n IpMap.add tgt nb nc, []\n | (REACHABLE _ | STALE _ | DELAY _ | PROBE _), Some new_mac, true, true ->\n Log.debug (fun f -> f \"NUD: %a --> REACHABLE\" Ipaddr.pp tgt);\n let nb = {nb with state = REACHABLE ((Int64.add now reachable_time), new_mac)} in\n IpMap.add tgt nb nc, []\n | (REACHABLE (_, mac) | STALE mac | DELAY (_, mac) | PROBE (_, _, mac)),\n Some new_mac, false, true when mac <> new_mac ->\n Log.debug (fun f -> f \"NUD: %a --> STALE\" Ipaddr.pp tgt);\n let nb = {nb with state = STALE mac} in\n IpMap.add tgt nb nc, []\n | _ ->\n nc, []\n in\n try\n let nb = IpMap.find tgt nc in\n update nb\n with\n | Not_found ->\n nc, []\n\n let query nc ~now ~retrans_timer ip =\n try\n let nb = IpMap.find ip nc in\n match nb.state with\n | INCOMPLETE _ ->\n nc, None, []\n | REACHABLE (_, dmac) | DELAY (_, dmac) | PROBE (_, _, dmac) ->\n nc, Some dmac, []\n | STALE dmac ->\n let dt = Defaults.delay_first_probe_time in\n let nc = IpMap.add ip {nb with state = DELAY (Int64.add now dt, dmac)} nc in\n nc, Some dmac, []\n with\n | Not_found ->\n let nb = {state = INCOMPLETE (Int64.add now retrans_timer, 0); is_router = false} in\n let nc = IpMap.add ip nb nc in\n let dst = Ipaddr.Prefix.network_address solicited_node_prefix ip in\n nc, None, [SendNS (`Specified, dst, ip)]\n\n let reachable nc ip =\n try\n let nb = IpMap.find ip nc in\n match nb.state with\n | INCOMPLETE _ -> false\n | _ -> true\n with\n | Not_found -> false\nend\n\nmodule RouterList = struct\n\n type t =\n (Ipaddr.t * time) list\n\n let empty =\n []\n\n let to_list rl =\n List.map fst rl\n\n let add rl ~now ?(lifetime = Duration.of_year 1) ip =\n (* FIXME *)\n (* yomimono 2016-06-30: fix what? *)\n (* yomimono 2016-08-17: maybe fix this default lifetime. *)\n (ip, Int64.add now lifetime) :: rl\n\n (* FIXME if we are keeping a destination cache, we must remove the stale routers from there as well. *)\n let tick rl ~now =\n List.filter (fun (_, t) -> t > now) rl\n\n let handle_ra rl ~now ~src ~lft =\n match List.mem_assoc src rl with\n | true ->\n let rl = List.remove_assoc src rl in\n if lft > 0L then begin\n Log.info (fun f -> f \"RA: Refreshing Router: src=%a lft=%Lu\" Ipaddr.pp src lft);\n (src, Int64.add now lft) :: rl, []\n end else begin\n Log.info (fun f -> f \"RA: Router Expired: src=%a\" Ipaddr.pp src);\n rl, []\n end\n | false ->\n if lft > 0L then begin\n Log.debug (fun f -> f \"RA: Adding Router: src=%a\" Ipaddr.pp src);\n (add rl ~now ~lifetime:lft src), []\n end else\n rl, []\n\n let add rl ~now:_ ip =\n match List.mem_assoc ip rl with\n | true -> rl\n | false -> (ip, Duration.of_year 1) :: rl\n\n let select rl reachable ip =\n let rec loop = function\n | [] ->\n begin match rl with\n | [] -> ip, rl\n | (ip, _) as r :: rest ->\n ip, rest @ [r]\n end\n | (ip, _) :: _ when reachable ip -> ip, rl\n | _ :: rest -> loop rest\n in\n loop rl\nend\n\nmodule Parser = struct\n type packet =\n | Drop\n | DropWithError of int * int * int\n | NA of Ipaddr.t * Ipaddr.t * na\n | NS of Ipaddr.t * Ipaddr.t * ns\n | RA of Ipaddr.t * Ipaddr.t * ra\n | Ping of Ipaddr.t * Ipaddr.t * int * int * Cstruct.t\n | Pong of Cstruct.t\n | Udp of Ipaddr.t * Ipaddr.t * Cstruct.t\n | Tcp of Ipaddr.t * Ipaddr.t * Cstruct.t\n | Default of int * Ipaddr.t * Ipaddr.t * Cstruct.t\n\n type option =\n | SLLA of Macaddr.t\n | TLLA of Macaddr.t\n | MTU of int\n | PREFIX of pfx\n\n let rec parse_options1 opts =\n if Cstruct.length opts >= Ipv6_wire.Opt.sizeof_opt then\n (* TODO check for invalid len == 0 *)\n let opt, opts = Cstruct.split opts (Ipv6_wire.Opt.get_len opts * 8) in\n match Ipv6_wire.get_ty opt, Ipv6_wire.Opt.get_len opt with\n | 1, 1 ->\n SLLA (Ipv6_wire.Llopt.get_addr opt) :: parse_options1 opts\n | 2, 1 ->\n TLLA (Ipv6_wire.Llopt.get_addr opt) :: parse_options1 opts\n | 5, 1 ->\n MTU (Int32.to_int (Cstruct.BE.get_uint32 opt 4)) :: parse_options1 opts\n | 3, 4 ->\n let pfx_prefix =\n Ipaddr.Prefix.make\n (Ipv6_wire.Opt_prefix.get_len opt)\n (Ipv6_wire.Opt_prefix.get_prefix opt)\n in\n let pfx_on_link = Ipv6_wire.Opt_prefix.on_link opt in\n let pfx_autonomous = Ipv6_wire.Opt_prefix.autonomous opt in\n let pfx_valid_lifetime =\n let n = Ipv6_wire.Opt_prefix.get_valid_lifetime opt in\n match n with\n | 0xffffffffl -> None\n | n -> Some (Int64.of_int32 n)\n in\n let pfx_preferred_lifetime =\n let n = Ipv6_wire.Opt_prefix.get_preferred_lifetime opt in\n match n with\n | 0xffffffffl -> None\n | n -> Some (Int64.of_int32 n)\n in\n let pfx =\n {pfx_on_link; pfx_autonomous; pfx_valid_lifetime; pfx_preferred_lifetime; pfx_prefix}\n in\n PREFIX pfx :: parse_options1 opts\n | ty, len ->\n Log.info (fun f -> f \"ND6: Unsupported ND option in RA: ty=%d len=%d\" ty len);\n parse_options1 opts\n else\n []\n\n let parse_ra buf =\n let ra_cur_hop_limit = Ipv6_wire.Ra.get_cur_hop_limit buf in\n let ra_router_lifetime =\n Int64.of_int (Ipv6_wire.Ra.get_router_lifetime buf)\n in\n let ra_reachable_time =\n let n = Ipv6_wire.Ra.get_reachable_time buf in\n if n = 0l then None\n else\n let dt = Int64.of_int32 @@ Int32.div n 1000l in\n Some dt\n in\n let ra_retrans_timer =\n let n = Ipv6_wire.Ra.get_retrans_timer buf in\n if n = 0l then None\n else\n let dt = Int64.of_int32 @@ Int32.div n 1000l in\n Some dt\n in\n let opts = Cstruct.shift buf Ipv6_wire.Ra.sizeof_ra in\n let ra_slla, ra_prefix =\n let opts = parse_options1 opts in\n List.fold_left (fun ra opt ->\n match ra, opt with\n | (_, pfxs), SLLA slla -> Some slla, pfxs\n | (slla, pfxs), PREFIX pfx -> slla, (pfx :: pfxs)\n | _ -> ra\n ) (None, []) opts\n in\n {ra_cur_hop_limit; ra_router_lifetime; ra_reachable_time; ra_retrans_timer; ra_slla; ra_prefix}\n\n let parse_ns buf =\n (* FIXME check code = 0 or drop *)\n let ns_target = Ipv6_wire.Ns.get_target buf in\n let opts = Cstruct.shift buf Ipv6_wire.Ns.sizeof_ns in\n let ns_slla =\n let opts = parse_options1 opts in\n List.fold_left (fun ns opt ->\n match opt with\n | SLLA slla -> Some slla\n | _ -> ns\n ) None opts\n in\n {ns_target; ns_slla}\n\n let parse_na buf =\n (* FIXME check code = 0 or drop *)\n let na_router = Ipv6_wire.Na.get_router buf in\n let na_solicited = Ipv6_wire.Na.get_solicited buf in\n let na_override = Ipv6_wire.Na.get_override buf in\n let na_target = Ipv6_wire.Na.get_target buf in\n let na_tlla =\n let opts = Cstruct.shift buf Ipv6_wire.Na.sizeof_na in\n let opts = parse_options1 opts in\n List.fold_left (fun na opt ->\n match opt with\n | TLLA tlla -> Some tlla\n | _ -> na\n ) None opts\n in\n {na_router; na_solicited; na_override; na_target; na_tlla}\n\n let parse_redirect buf =\n let destination = Ipv6_wire.Redirect.get_destination buf in\n let target = Ipv6_wire.Redirect.get_target buf in\n { target; destination }\n\n let dst_unreachable icmpbuf =\n match Ipv6_wire.get_code icmpbuf with\n | 0 -> \"No route to destination\"\n | 1 -> \"Communication with destination administratively prohibited\"\n | 2 -> \"Beyond scope of source address\"\n | 3 -> \"Address unreachable\"\n | 4 -> \"Port unreachable\"\n | 5 -> \"Source address failed ingress/egress policy\"\n | 6 -> \"Reject route to destination\"\n | 7 -> \"Error in Source Routing Header\"\n | c -> \"Unknown code: \" ^ string_of_int c\n\n let time_exceeded icmpbuf =\n match Ipv6_wire.get_code icmpbuf with\n | 0 -> \"Hop limit exceeded in transit\"\n | 1 -> \"Fragment reassembly time exceeded\"\n | c -> \"Unknown code: \" ^ string_of_int c\n\n let parameter_problem icmpbuf =\n match Ipv6_wire.get_code icmpbuf with\n | 0 -> \"Erroneous header field encountered\"\n | 1 -> \"Unrecognized Next Header type encountered\"\n | 2 -> \"Unrocognized IPv6 option encountered\"\n | c -> \"Unknown code: \" ^ string_of_int c\n\n (* buf : icmp packet with ipv6 header *)\n let parse_icmp ~src ~dst buf poff =\n let icmpbuf = Cstruct.shift buf poff in\n let csum = checksum' ~proto:58 buf [ icmpbuf ] in\n if csum != 0 then begin\n Log.info (fun f -> f \"ICMP6: Checksum error, dropping packet: csum=0x%x\" csum);\n Drop\n end else begin\n match Ipv6_wire.get_ty icmpbuf with\n | 128 -> (* Echo request *)\n let id = Cstruct.BE.get_uint16 icmpbuf 4 in\n let seq = Cstruct.BE.get_uint16 icmpbuf 6 in\n Ping (src, dst, id, seq, Cstruct.shift icmpbuf 8)\n | 129 (* Echo reply *) ->\n Pong (Cstruct.shift buf poff)\n | 133 (* RS *) ->\n (* RFC 4861, 2.6.2 *)\n Drop\n | 134 (* RA *) ->\n if Ipv6_wire.get_hlim buf <> 255 then\n Drop\n else\n RA (src, dst, parse_ra icmpbuf)\n | 135 (* NS *) ->\n if Ipv6_wire.get_hlim buf <> 255 then\n Drop\n else\n let ns = parse_ns icmpbuf in\n if Ipaddr.is_multicast ns.ns_target then\n Drop\n else\n NS (src, dst, ns)\n | 136 (* NA *) ->\n if Ipv6_wire.get_hlim buf <> 255 then\n Drop\n else\n let na = parse_na icmpbuf in\n if Ipaddr.is_multicast na.na_target ||\n (na.na_solicited && Ipaddr.is_multicast dst) then\n Drop\n else\n NA (src, dst, na)\n | 137 (* Redirect *) ->\n if Ipv6_wire.get_hlim buf <> 255 then\n Drop\n else\n let redirect = parse_redirect icmpbuf in\n Log.info (fun f -> f \"ICMP6 Redirect: %a via %a\"\n Ipaddr.pp redirect.destination\n Ipaddr.pp redirect.target);\n Drop\n | 1 ->\n Log.info (fun f -> f \"ICMP6 Destination Unreachable: %s\" (dst_unreachable icmpbuf));\n Drop\n | 2 ->\n Log.info (fun f -> f \"ICMP6 Packet Too Big\");\n Drop\n | 3 ->\n Log.info (fun f -> f \"ICMP6 Time Exceeded: %s\" (time_exceeded icmpbuf));\n Drop\n | 4 ->\n Log.info (fun f -> f \"ICMP6 Parameter Problem: %s\" (parameter_problem icmpbuf));\n Drop\n | n ->\n Log.info (fun f -> f \"ICMP6: Unknown packet type: ty=%d\" n);\n Drop\n end\n\n let rec parse_extension ~src ~dst buf first hdr (poff : int) =\n match hdr with\n | 0 (* HOPTOPT *) when first ->\n Log.debug (fun f -> f \"IP6: Processing HOPOPT header\");\n parse_options ~src ~dst buf poff\n | 0 ->\n Drop\n | 60 (* IPv6-Opts *) ->\n Log.debug (fun f -> f \"IP6: Processing DESTOPT header\");\n parse_options ~src ~dst buf poff\n | 43 (* IPv6-Route *)\n | 44 (* IPv6-Frag *)\n | 50 (* ESP *)\n | 51 (* AH *)\n | 135 (* Mobility Header *)\n | 59 (* NO NEXT HEADER *) ->\n Drop\n | 58 (* ICMP *) ->\n parse_icmp ~src ~dst buf poff\n | 17 (* UDP *) ->\n Udp (src, dst, Cstruct.shift buf poff)\n | 6 (* TCP *) ->\n Tcp (src, dst, Cstruct.shift buf poff)\n | n when 143 <= n && n <= 255 ->\n (* UNASSIGNED, EXPERIMENTAL & RESERVED *)\n Drop\n | n ->\n Default (n, src, dst, Cstruct.shift buf poff)\n\n and parse_options ~src ~dst buf poff =\n let pbuf = Cstruct.shift buf poff in\n let nhdr = Ipv6_wire.get_ty pbuf in\n let olen = Ipv6_wire.Opt.get_len pbuf * 8 + 8 in\n let oend = olen + poff in\n let rec loop ooff =\n if ooff < oend then begin\n let obuf = Cstruct.shift buf ooff in\n match Ipv6_wire.get_ty obuf with\n | 0 ->\n Log.debug (fun f -> f \"IP6: Processing PAD1 option\");\n loop (ooff+1)\n | 1 ->\n Log.debug (fun f -> f \"IP6: Processing PADN option\");\n let len = Ipv6_wire.Opt.get_len obuf in\n loop (ooff+len+2)\n | _ as n ->\n Log.info (fun f -> f \"IP6: Processing unknown option, MSB %x\" n);\n let len = Ipv6_wire.Opt.get_len obuf in\n match n land 0xc0 with\n | 0x00 ->\n loop (ooff+len+2)\n | 0x40 ->\n (* discard the packet *)\n Drop\n | 0x80 ->\n (* discard, send icmp error *)\n DropWithError (4, 2, ooff)\n | 0xc0 ->\n (* discard, send icmp error if dest is not mcast *)\n if Ipaddr.is_multicast dst then\n Drop\n else\n DropWithError (4, 2, ooff)\n | _ ->\n assert false\n end else\n parse_extension ~src ~dst buf false nhdr oend\n in\n loop (poff+2)\n\n let packet is_my_addr buf =\n if Cstruct.length buf < Ipv6_wire.sizeof_ipv6 || Cstruct.length buf < Ipv6_wire.sizeof_ipv6 + Ipv6_wire.get_len buf then begin\n Log.debug (fun m -> m \"short IPv6 packet received, dropping\");\n Drop\n end else if Int32.logand (Ipv6_wire.get_version_flow buf) 0xF0000000l <> 0x60000000l then begin\n Log.debug (fun m -> m \"version in IPv6 packet not 6\");\n Drop\n end else begin\n let buf = Cstruct.sub buf 0 (Ipv6_wire.sizeof_ipv6 + Ipv6_wire.get_len buf) in\n let src = Ipv6_wire.get_src buf in\n let dst = Ipv6_wire.get_dst buf in\n if Ipaddr.Prefix.(mem src multicast) then begin\n Log.debug (fun f -> f \"IP6: Dropping packet, src is mcast\");\n Drop\n end else\n if not (is_my_addr dst || Ipaddr.Prefix.(mem dst multicast)) then begin\n Log.debug (fun f -> f \"IP6: Dropping packet, not for me\");\n Drop\n end\n else\n parse_extension ~src ~dst buf true (Ipv6_wire.get_nhdr buf) Ipv6_wire.sizeof_ipv6\n end\nend\n\ntype event =\n [ `Tcp of ipaddr * ipaddr * Cstruct.t\n | `Udp of ipaddr * ipaddr * Cstruct.t\n | `Default of int * ipaddr * ipaddr * Cstruct.t ]\n\n(* TODO add destination cache *)\ntype context =\n { neighbor_cache : NeighborCache.t;\n prefix_list : PrefixList.t;\n router_list : RouterList.t;\n mac : Macaddr.t;\n address_list : AddressList.t;\n link_mtu : int;\n cur_hop_limit : int;\n base_reachable_time : time;\n reachable_time : time;\n retrans_timer : time;\n packet_queue : (int * (Cstruct.t -> int)) PacketQueue.t;\n handle_ra : bool }\n\nlet next_hop ctx ip =\n if PrefixList.is_local ctx.prefix_list ip then\n ctx, ip\n else\n let ip, router_list =\n RouterList.select ctx.router_list (NeighborCache.reachable ctx.neighbor_cache) ip\n in\n {ctx with router_list}, ip\n\nlet rec process_actions ~now ctx actions =\n let aux ctx = function\n | SendNS (unspec, dst, tgt) ->\n let src, specified = match unspec with\n | `Unspecified -> Ipaddr.unspecified, false\n | `Specified -> AddressList.select_source ctx.address_list ~dst, true\n in\n Log.debug (fun f -> f \"ND6: Sending NS src=%a dst=%a tgt=%a\"\n Ipaddr.pp src Ipaddr.pp dst Ipaddr.pp tgt);\n let size, fillf = Allocate.ns ~specified ~mac:ctx.mac ~src ~dst ~tgt in\n send' ~now ctx dst size fillf\n | SendNA (src, dst, tgt, sol) ->\n let sol = match sol with `Solicited -> true | `Unsolicited -> false in\n Log.debug (fun f -> f \"ND6: Sending NA: src=%a dst=%a tgt=%a sol=%B\"\n Ipaddr.pp src Ipaddr.pp dst Ipaddr.pp tgt sol);\n let size, fillf = Allocate.na ~mac:ctx.mac ~src ~dst ~tgt ~sol in\n send' ~now ctx dst size fillf\n | SendRS ->\n Log.debug (fun f -> f \"ND6: Sending RS\");\n let size, fillf = Allocate.rs ~mac:ctx.mac (AddressList.select_source ctx.address_list) in\n let dst = Ipaddr.link_routers in\n send' ~now ctx dst size fillf\n | SendQueued (ip, dmac) ->\n Log.debug (fun f -> f \"IP6: Releasing queued packets: dst=%a mac=%a\" Ipaddr.pp ip Macaddr.pp dmac);\n let outs, packet_queue = PacketQueue.pop ip ctx.packet_queue in\n let outs' = List.map (fun (size, fillf) -> dmac, size, fillf) outs in\n let ctx = {ctx with packet_queue} in\n ctx, outs'\n | CancelQueued ip ->\n Log.debug (fun f -> f \"IP6: Cancelling packets: dst = %a\" Ipaddr.pp ip);\n let _, packet_queue = PacketQueue.pop ip ctx.packet_queue in\n let ctx = {ctx with packet_queue} in\n ctx, []\n in\n List.fold_left (fun (ctx, bufs) action ->\n let ctx, bufs' = aux ctx action in\n ctx, bufs @ bufs'\n ) (ctx, []) actions\n\nand send' ~now ctx dst size fillf =\n match Ipaddr.is_multicast dst with\n | true -> ctx, [(multicast_mac dst, size, fillf)]\n | false ->\n let ctx, ip = next_hop ctx dst in\n let neighbor_cache, mac, actions =\n NeighborCache.query ctx.neighbor_cache ~now ~retrans_timer:ctx.retrans_timer ip in\n let ctx = {ctx with neighbor_cache} in\n match mac with\n | Some dmac ->\n Log.debug (fun f -> f \"IP6: Sending packet: dst=%a mac=%a\" Ipaddr.pp dst Macaddr.pp dmac);\n let ctx, outs = process_actions ~now ctx actions in\n ctx, (dmac, size, fillf) :: outs\n | None ->\n Log.debug (fun f -> f \"IP6: Queueing packet: dst=%a\" Ipaddr.pp dst);\n let packet_queue = PacketQueue.push ip (size, fillf) ctx.packet_queue in\n let ctx = {ctx with packet_queue} in\n process_actions ~now ctx actions\n\nlet send ~now ctx ?src dst proto size fillf =\n let src = match src with None -> AddressList.select_source ctx.address_list ~dst | Some s -> s in\n let siz, fill = Allocate.hdr ~hlim:ctx.cur_hop_limit ~src ~dst ~proto ~size fillf in\n send' ~now ctx dst siz fill\n\nlet local ~handle_ra ~now mac =\n let ctx =\n { neighbor_cache = NeighborCache.empty;\n prefix_list = PrefixList.link_local;\n router_list = RouterList.empty;\n mac = mac;\n address_list = AddressList.empty;\n link_mtu = Defaults.link_mtu;\n cur_hop_limit = 64; (* TODO *)\n base_reachable_time = Defaults.reachable_time;\n reachable_time = compute_reachable_time Defaults.reachable_time;\n retrans_timer = Defaults.retrans_timer;\n packet_queue = PacketQueue.empty 3;\n handle_ra }\n in\n let ip = link_local_addr mac in\n let address_list, actions =\n AddressList.add ctx.address_list ~now ~retrans_timer:ctx.retrans_timer ~lft:None ip\n in\n let ctx, actions = {ctx with address_list}, SendRS :: actions in\n process_actions ~now ctx actions\n\nlet add_ip ~now ctx ip =\n let address_list, actions =\n AddressList.add ctx.address_list ~now ~retrans_timer:ctx.retrans_timer ~lft:None ip\n in\n let ctx = {ctx with address_list} in\n process_actions ~now ctx actions\n\nlet get_ip ctx =\n List.map Ipaddr.Prefix.address (AddressList.to_list ctx.address_list)\n\nlet configured_ips ctx =\n AddressList.to_list ctx.address_list\n\nlet select_source ctx dst =\n AddressList.select_source ctx.address_list ~dst\n\nlet handle_ra ~now ctx ~src ~dst ra =\n Log.debug (fun f -> f \"ND: Received RA: src=%a dst=%a\" Ipaddr.pp src Ipaddr.pp dst);\n let ctx =\n if ra.ra_cur_hop_limit <> 0 then\n {ctx with cur_hop_limit = ra.ra_cur_hop_limit}\n else ctx\n in\n let ctx = match ra.ra_reachable_time with\n | None -> ctx\n | Some rt ->\n if ctx.base_reachable_time <> rt then\n {ctx with base_reachable_time = rt;\n reachable_time = compute_reachable_time rt}\n else\n ctx\n in\n let ctx = match ra.ra_retrans_timer with\n | None -> ctx\n | Some rt ->\n {ctx with retrans_timer = rt}\n in\n let ctx, actions =\n match ra.ra_slla with\n | Some new_mac ->\n let neighbor_cache, actions = NeighborCache.handle_ra ctx.neighbor_cache ~src new_mac in\n {ctx with neighbor_cache}, actions\n | None ->\n ctx, []\n in\n let ctx, actions' =\n List.fold_left\n (fun (state, _) pfx ->\n let vlft = pfx.pfx_valid_lifetime in\n let prefix_list, acts = PrefixList.handle_ra state.prefix_list ~now ~vlft pfx.pfx_prefix in\n match pfx.pfx_autonomous, vlft with\n | _, Some 0L ->\n {state with prefix_list}, acts\n | true, Some _ ->\n let plft = pfx.pfx_preferred_lifetime in\n let lft = match plft with\n | None -> None\n | Some plft -> Some (plft, vlft)\n in\n let address_list, acts' = (* FIXME *)\n AddressList.configure state.address_list ~now ~retrans_timer:state.retrans_timer\n ~lft state.mac pfx.pfx_prefix\n in\n {state with address_list; prefix_list}, acts @ acts'\n | _ ->\n {state with prefix_list}, acts) (ctx, actions) ra.ra_prefix\n in\n let router_list, actions'' =\n RouterList.handle_ra ctx.router_list ~now ~src ~lft:ra.ra_router_lifetime\n in\n let actions = actions @ actions' @ actions'' in\n {ctx with router_list}, actions\n\nlet handle_ns ~now:_ ctx ~src ~dst ns =\n Log.debug (fun f -> f \"ND: Received NS: src=%a dst=%a tgt=%a\"\n Ipaddr.pp src Ipaddr.pp dst Ipaddr.pp ns.ns_target);\n (* TODO check hlim = 255, target not mcast, code = 0 *)\n let ctx, actions = match ns.ns_slla with\n | Some new_mac ->\n let neighbor_cache, actions = NeighborCache.handle_ns ctx.neighbor_cache ~src new_mac in\n {ctx with neighbor_cache}, actions\n (* handle_ns_slla ~state ~src new_mac *)\n | None ->\n ctx, []\n in\n if AddressList.is_my_addr ctx.address_list ns.ns_target then begin\n let src = ns.ns_target\n and dst, sol =\n if Ipaddr.(compare src unspecified = 0) then\n Ipaddr.link_nodes, `Unsolicited\n else\n src, `Solicited\n in\n (* Log.debug (fun f -> f \"Sending NA to %a from %a with target address %a\"\n Ipaddr.pp dst Ipaddr.pp src Ipaddr.pp ns.ns_target); *)\n ctx, SendNA (src, dst, ns.ns_target, sol) :: actions\n end else\n ctx, actions\n\nlet handle_na ~now ctx ~src ~dst na =\n Log.debug (fun f -> f \"ND: Received NA: src=%a dst=%a tgt=%a\"\n Ipaddr.pp src Ipaddr.pp dst Ipaddr.pp na.na_target);\n\n (* TODO Handle case when na.target is one of my bound IPs. *)\n\n (* If my_ip is TENTATIVE then fail DAD. *)\n let address_list = AddressList.handle_na ctx.address_list na.na_target in\n let neighbor_cache, actions =\n NeighborCache.handle_na ctx.neighbor_cache\n ~now ~reachable_time:ctx.reachable_time\n ~rtr:na.na_router ~sol:na.na_solicited ~ovr:na.na_override ~tgt:na.na_target\n ~lladdr:na.na_tlla\n in\n let ctx = {ctx with neighbor_cache; address_list} in\n ctx, actions\n\nlet handle ~now ctx buf =\n let open Parser in\n match packet (AddressList.is_my_addr ctx.address_list) buf with\n | RA (src, dst, ra) ->\n if ctx.handle_ra then\n let ctx, actions = handle_ra ~now ctx ~src ~dst ra in\n let ctx, bufs = process_actions ~now ctx actions in\n ctx, bufs, []\n else begin\n Log.info (fun m -> m \"Ignoring router advertisement (stack is configured to not handle them)\");\n ctx, [], []\n end\n | NS (src, dst, ns) ->\n let ctx, actions = handle_ns ~now ctx ~src ~dst ns in\n let ctx, bufs = process_actions ~now ctx actions in\n ctx, bufs, []\n | NA (src, dst, na) ->\n let ctx, actions = handle_na ~now ctx ~src ~dst na in\n let ctx, bufs = process_actions ~now ctx actions in\n ctx, bufs, []\n | Ping (src, dst, id, seq, data) ->\n Log.info (fun f -> f \"ICMP6: Received PING: src=%a dst=%a id=%d seq=%d\" Ipaddr.pp src\n Ipaddr.pp dst id seq);\n let dst = src\n and src =\n if Ipaddr.is_multicast dst then\n AddressList.select_source ctx.address_list ~dst\n else\n dst\n in\n let frame, bufs =\n Allocate.pong ~src ~dst ~hlim:ctx.cur_hop_limit ~id ~seq ~data\n in\n let ctx, bufs = send' ~now ctx dst frame bufs in\n ctx, bufs, []\n | DropWithError _ (* TODO *) | Drop ->\n ctx, [], []\n | Pong _ ->\n ctx, [], []\n | Tcp (src, dst, buf) ->\n ctx, [], [`Tcp (src, dst, buf)]\n | Udp (src, dst, buf) ->\n ctx, [], [`Udp (src, dst, buf)]\n | Default (proto, src, dst, buf) ->\n ctx, [], [`Default (proto, src, dst, buf)]\n\nlet tick ~now ctx =\n let retrans_timer = ctx.retrans_timer in\n let address_list, actions = AddressList.tick ctx.address_list ~now ~retrans_timer in\n let prefix_list = PrefixList.tick ctx.prefix_list ~now in\n let neighbor_cache, actions' = NeighborCache.tick ctx.neighbor_cache ~now ~retrans_timer in\n let router_list = RouterList.tick ctx.router_list ~now in\n let ctx = {ctx with address_list; prefix_list; neighbor_cache; router_list} in\n let actions = actions @ actions' in\n process_actions ~now ctx actions\n\nlet add_prefix ~now ctx pfx =\n let prefix_list = PrefixList.add ctx.prefix_list ~now pfx ~vlft:None in\n {ctx with prefix_list}\n\nlet get_prefix ctx =\n PrefixList.to_list ctx.prefix_list\n\nlet add_routers ~now ctx ips =\n let router_list = List.fold_left (RouterList.add ~now) ctx.router_list ips in\n {ctx with router_list}\n\nlet get_routers ctx =\n RouterList.to_list ctx.router_list\n" }, { "path": "src/ipv6/ndpv6.mli", "content": "(*\n * Copyright (c) 2015 Nicolas Ojeda Bar \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\ntype ipaddr = Ipaddr.V6.t\ntype prefix = Ipaddr.V6.Prefix.t\ntype time = int64\n\nval checksum : Cstruct.t -> Cstruct.t list -> int\n\ntype event =\n [ `Tcp of ipaddr * ipaddr * Cstruct.t\n | `Udp of ipaddr * ipaddr * Cstruct.t\n | `Default of int * ipaddr * ipaddr * Cstruct.t ]\n\ntype context\n\nval local : handle_ra:bool -> now:time -> Macaddr.t ->\n context * (Macaddr.t * int * (Cstruct.t -> int)) list\n(** [local ~handle_ra ~now mac] is a pair [ctx, outs] where [ctx] is a local IPv6 context\n associated to the hardware address [mac]. [outs] is a list of ethif packets\n to be sent. *)\n\nval add_ip : now:time -> context -> prefix ->\n context * (Macaddr.t * int * (Cstruct.t -> int)) list\n(** [add_ip ~now ctx ip] is [ctx', outs] where [ctx'] is [ctx] updated with a\n new local ip and [outs] is a list of ethif packets to be sent. *)\n\nval get_ip : context -> ipaddr list\n(** [get_ip ctx] returns the list of local ips. *)\n\nval configured_ips : context -> prefix list\n(** [configured_ips ctx] returns the list of local prefixes. *)\n\nval select_source : context -> ipaddr -> ipaddr\n(** [select_source ctx ip] returns the ip that should be put in the source field\n of a packet destined to [ip]. *)\n\nval handle : now:time -> context -> Cstruct.t ->\n context * (Macaddr.t * int * (Cstruct.t -> int)) list * event list\n(** [handle ~now ctx buf] handles an incoming ipv6 packet. It returns\n [ctx', bufs, evs] where [ctx'] is the updated context, [bufs] is a list of\n packets to be sent and [evs] is a list of packets to be passed to the higher\n layers (udp, tcp, etc) for further processing. *)\n\nval send : now:time -> context -> ?src:ipaddr -> ipaddr -> Tcpip.Ip.proto ->\n int -> (Cstruct.t -> Cstruct.t -> int) -> context * (Macaddr.t * int * (Cstruct.t -> int)) list\n(** [send ~now ctx ?src dst proto size fillf] starts route resolution and assembles an\n ipv6 packet of [size] for sending with header and body passed to [fillf].\n It returns a pair [ctx', dst_size_fills] where [ctx'] is the updated\n context and [dst, size, fillf] is a list of packets to be sent, specified\n by destination, their size, and fill function. *)\n\nval tick : now:time -> context -> context * (Macaddr.t * int * (Cstruct.t -> int)) list\n(** [tick ~now ctx] should be called periodically (every 1s is good). It\n returns [ctx', bufs] where [ctx'] is the updated context and [bufs] is a list of\n packets to be sent. *)\n\nval add_prefix : now:time -> context -> prefix -> context\n(** [add_prefix ~now ctx pfx] adds a local prefix to [ctx]. *)\n\nval get_prefix : context -> prefix list\n(** [get_prefix ctx] returns the list of local prefixes known to [ctx]. *)\n\nval add_routers : now:time -> context -> ipaddr list -> context\n(** [add_routers ~now ctx ips] adds a list of gateways to [ctx] to be used for\n routing. *)\n\nval get_routers : context -> ipaddr list\n(** [get_routers ctx] returns the list of gateways known to [ctx]. *)\n" }, { "path": "src/stack-direct/dune", "content": "(library\n (name tcpip_stack_direct)\n (public_name tcpip.stack-direct)\n (instrumentation\n (backend bisect_ppx))\n (libraries logs ipaddr lwt fmt mirage-sleep mirage-crypto-rng mirage-net\n ethernet arp.mirage tcpip.icmpv4 tcpip.udp tcpip.tcp))\n" }, { "path": "src/stack-direct/tcpip_stack_direct.ml", "content": "(*\n * Copyright (c) 2011-2014 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Lwt.Infix\n\nlet src = Logs.Src.create \"tcpip-stack-direct\" ~doc:\"Pure OCaml TCP/IP stack\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nmodule IPV4V6\n (Ipv4 : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t and type prefix = Ipaddr.V4.Prefix.t)\n (Ipv6 : Tcpip.Ip.S with type ipaddr = Ipaddr.V6.t and type prefix = Ipaddr.V6.Prefix.t) = struct\n\n type ipaddr = Ipaddr.t\n type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\n\n let pp_ipaddr = Ipaddr.pp\n\n type prefix = Ipaddr.Prefix.t\n let pp_prefix = Ipaddr.Prefix.pp\n\n type error = [ Tcpip.Ip.error | `Ipv4 of Ipv4.error | `Ipv6 of Ipv6.error | `Msg of string ]\n\n let pp_error ppf = function\n | #Tcpip.Ip.error as e -> Tcpip.Ip.pp_error ppf e\n | `Ipv4 e -> Ipv4.pp_error ppf e\n | `Ipv6 e -> Ipv6.pp_error ppf e\n | `Msg m -> Fmt.string ppf m\n\n type t = { ipv4 : Ipv4.t ; ipv4_only : bool ; ipv6 : Ipv6.t ; ipv6_only : bool }\n\n let connect ~ipv4_only ~ipv6_only ipv4 ipv6 =\n if ipv4_only && ipv6_only then\n Lwt.fail_with \"cannot configure stack with both IPv4 only and IPv6 only\"\n else\n Lwt.return { ipv4 ; ipv4_only ; ipv6 ; ipv6_only }\n\n let disconnect _ = Lwt.return_unit\n\n let input t ~tcp ~udp ~default =\n let tcp4 ~src ~dst payload = tcp ~src:(Ipaddr.V4 src) ~dst:(Ipaddr.V4 dst) payload\n and tcp6 ~src ~dst payload = tcp ~src:(Ipaddr.V6 src) ~dst:(Ipaddr.V6 dst) payload\n and udp4 ~src ~dst payload = udp ~src:(Ipaddr.V4 src) ~dst:(Ipaddr.V4 dst) payload\n and udp6 ~src ~dst payload = udp ~src:(Ipaddr.V6 src) ~dst:(Ipaddr.V6 dst) payload\n and default4 ~proto ~src ~dst payload = default ~proto ~src:(Ipaddr.V4 src) ~dst:(Ipaddr.V4 dst) payload\n and default6 ~proto ~src ~dst payload = default ~proto ~src:(Ipaddr.V6 src) ~dst:(Ipaddr.V6 dst) payload\n in\n fun buf ->\n if Cstruct.length buf >= 1 then\n let v = Cstruct.get_uint8 buf 0 lsr 4 in\n if v = 4 && not t.ipv6_only then\n Ipv4.input t.ipv4 ~tcp:tcp4 ~udp:udp4 ~default:default4 buf\n else if v = 6 && not t.ipv4_only then\n Ipv6.input t.ipv6 ~tcp:tcp6 ~udp:udp6 ~default:default6 buf\n else\n Lwt.return_unit\n else\n Lwt.return_unit\n\n let write t ?fragment ?ttl ?src dst proto ?size headerf bufs =\n match dst with\n | Ipaddr.V4 dst ->\n if not t.ipv6_only then\n match\n match src with\n | None -> Ok None\n | Some (Ipaddr.V4 src) -> Ok (Some src)\n | _ -> Error (`Msg \"source must be V4 if dst is V4\")\n with\n | Error e -> Lwt.return (Error e)\n | Ok src ->\n Ipv4.write t.ipv4 ?fragment ?ttl ?src dst proto ?size headerf bufs >|= function\n | Ok () -> Ok ()\n | Error e -> Error (`Ipv4 e)\n else begin\n Log.warn (fun m -> m \"attempted to write an IPv4 packet in a v6 only stack\");\n Lwt.return (Ok ())\n end\n | Ipaddr.V6 dst ->\n if not t.ipv4_only then\n match\n match src with\n | None -> Ok None\n | Some (Ipaddr.V6 src) -> Ok (Some src)\n | _ -> Error (`Msg \"source must be V6 if dst is V6\")\n with\n | Error e -> Lwt.return (Error e)\n | Ok src ->\n Ipv6.write t.ipv6 ?fragment ?ttl ?src dst proto ?size headerf bufs >|= function\n | Ok () -> Ok ()\n | Error e -> Error (`Ipv6 e)\n else begin\n Log.warn (fun m -> m \"attempted to write an IPv6 packet in a v4 only stack\");\n Lwt.return (Ok ())\n end\n\n let pseudoheader t ?src dst proto len =\n match dst with\n | Ipaddr.V4 dst ->\n let src =\n match src with\n | None -> None\n | Some (Ipaddr.V4 src) -> Some src\n | _ -> None (* cannot happen *)\n in\n Ipv4.pseudoheader t.ipv4 ?src dst proto len\n | Ipaddr.V6 dst ->\n let src =\n match src with\n | None -> None\n | Some (Ipaddr.V6 src) -> Some src\n | _ -> None (* cannot happen *)\n in\n Ipv6.pseudoheader t.ipv6 ?src dst proto len\n\n let src t ~dst =\n match dst with\n | Ipaddr.V4 dst -> Ipaddr.V4 (Ipv4.src t.ipv4 ~dst)\n | Ipaddr.V6 dst -> Ipaddr.V6 (Ipv6.src t.ipv6 ~dst)\n\n [@@@alert \"-deprecated\"]\n let get_ip t =\n List.map (fun ip -> Ipaddr.V4 ip) (Ipv4.get_ip t.ipv4) @\n List.map (fun ip -> Ipaddr.V6 ip) (Ipv6.get_ip t.ipv6)\n [@@@alert \"+deprecated\"]\n\n let configured_ips t =\n List.map (fun cidr -> Ipaddr.V4 cidr) (Ipv4.configured_ips t.ipv4) @\n List.map (fun cidr -> Ipaddr.V6 cidr) (Ipv6.configured_ips t.ipv6)\n\n let mtu t ~dst = match dst with\n | Ipaddr.V4 dst -> Ipv4.mtu t.ipv4 ~dst\n | Ipaddr.V6 dst -> Ipv6.mtu t.ipv6 ~dst\nend\n\nmodule MakeV4V6\n (Netif : Mirage_net.S)\n (Eth : Ethernet.S)\n (Arpv4 : Arp.S)\n (Ip : Tcpip.Ip.S with type ipaddr = Ipaddr.t)\n (Icmpv4 : Icmpv4.S)\n (Udp : Tcpip.Udp.S with type ipaddr = Ipaddr.t)\n (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t) = struct\n\n module UDP = Udp\n module TCP = Tcp\n module IP = Ip\n\n type t = {\n netif : Netif.t;\n ethif : Eth.t;\n arpv4 : Arpv4.t;\n icmpv4 : Icmpv4.t;\n ip : IP.t;\n udp : Udp.t;\n tcp : Tcp.t;\n mutable task : unit Lwt.t option;\n }\n\n let pp fmt t =\n Format.fprintf fmt \"mac=%a,ip=%a\" Macaddr.pp (Eth.mac t.ethif)\n Fmt.(list ~sep:(any \", \") IP.pp_prefix) (IP.configured_ips t.ip)\n\n let tcp { tcp; _ } = tcp\n let udp { udp; _ } = udp\n let ip { ip; _ } = ip\n\n let listen t =\n Lwt.catch (fun () ->\n Log.debug (fun f -> f \"Establishing or updating listener for stack %a\" pp t);\n let tcp = Tcp.input t.tcp\n and udp = Udp.input t.udp\n and default ~proto ~src ~dst buf =\n match proto, src, dst with\n | 1, Ipaddr.V4 src, Ipaddr.V4 dst -> Icmpv4.input t.icmpv4 ~src ~dst buf\n | _ -> Lwt.return_unit\n in\n let ethif_listener = Eth.input\n ~arpv4:(Arpv4.input t.arpv4)\n ~ipv4:(IP.input ~tcp ~udp ~default t.ip)\n ~ipv6:(IP.input ~tcp ~udp ~default t.ip)\n t.ethif\n in\n Netif.listen t.netif ~header_size:Ethernet.Packet.sizeof_ethernet ethif_listener\n >>= function\n | Error e ->\n Log.warn (fun p -> p \"%a\" Netif.pp_error e) ;\n (* XXX: error should be passed to the caller *)\n Lwt.return_unit\n | Ok _res ->\n let nstat = Netif.get_stats_counters t.netif in\n let open Mirage_net in\n Log.info (fun f ->\n f \"listening loop of interface %s terminated regularly:@ %Lu bytes \\\n (%lu packets) received, %Lu bytes (%lu packets) sent@ \"\n (Macaddr.to_string (Netif.mac t.netif))\n nstat.rx_bytes nstat.rx_pkts\n nstat.tx_bytes nstat.tx_pkts) ;\n Lwt.return_unit)\n (function\n | Lwt.Canceled ->\n Log.info (fun f -> f \"listen of %a cancelled\" pp t);\n Lwt.return_unit\n | e -> Lwt.fail e)\n\n let connect netif ethif arpv4 ip icmpv4 udp tcp =\n let t = { netif; ethif; arpv4; ip; icmpv4; tcp; udp; task = None } in\n Log.info (fun f -> f \"Dual TCP/IP stack assembled: %a\" pp t);\n Lwt.async (fun () -> let task = listen t in t.task <- Some task; task);\n Lwt.return t\n\n let disconnect t =\n Log.info (fun f -> f \"Dual TCP/IP stack disconnected: %a\" pp t);\n (match t.task with None -> () | Some task -> Lwt.cancel task);\n Lwt.return_unit\nend\n\nmodule TCPV4V6 (S : Tcpip.Stack.V4V6) : sig\n include Tcpip.Tcp.S with type ipaddr = Ipaddr.t\n and type flow = S.TCP.flow\n and type t = S.TCP.t\n\n val connect : S.t -> t Lwt.t\nend = struct\n include S.TCP\n\n let connect stackv4v6 = Lwt.return (S.tcp stackv4v6)\nend\n" }, { "path": "src/stack-direct/tcpip_stack_direct.mli", "content": "(*\n * Copyright (c) 2014 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nmodule IPV4V6\n (Ipv4 : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t and type prefix = Ipaddr.V4.Prefix.t)\n (Ipv6 : Tcpip.Ip.S with type ipaddr = Ipaddr.V6.t and type prefix = Ipaddr.V6.Prefix.t) : sig\n include Tcpip.Ip.S with type ipaddr = Ipaddr.t and type prefix = Ipaddr.Prefix.t\n\n val connect : ipv4_only:bool -> ipv6_only:bool -> Ipv4.t -> Ipv6.t -> t Lwt.t\nend\n\nmodule MakeV4V6\n (Netif : Mirage_net.S)\n (Ethernet : Ethernet.S)\n (Arpv4 : Arp.S)\n (Ip : Tcpip.Ip.S with type ipaddr = Ipaddr.t and type prefix = Ipaddr.Prefix.t)\n (Icmpv4 : Icmpv4.S)\n (Udp : Tcpip.Udp.S with type ipaddr = Ipaddr.t)\n (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t) : sig\n include Tcpip.Stack.V4V6\n with module IP = Ip\n and module TCP = Tcp\n and module UDP = Udp\n\n val connect : Netif.t -> Ethernet.t -> Arpv4.t -> Ip.t -> Icmpv4.t -> Udp.t -> Tcp.t -> t Lwt.t\n (** [connect] assembles the arguments into a network stack, then calls\n `listen` on the assembled stack before returning it to the caller. The\n initial `listen` functions to ensure that the lower-level layers are\n functioning, so that if the user wishes to establish outbound connections,\n they will be able to do so. *)\nend\n\nmodule TCPV4V6\n (S : Tcpip.Stack.V4V6)\n : sig\n include Tcpip.Tcp.S with type ipaddr = Ipaddr.t\n and type flow = S.TCP.flow\n and type t = S.TCP.t\n\n val connect : S.t -> t Lwt.t\n (** [connect] returns the TCP/IP stack from a network stack to let the user to\n initiate only TCP/IP connections (regardless UDP/IP). *)\nend\n" }, { "path": "src/stack-unix/dune", "content": "(library\n (name icmpv4_socket)\n (public_name tcpip.icmpv4-socket)\n (modules icmpv4_socket)\n (wrapped false)\n (instrumentation\n (backend bisect_ppx))\n (libraries lwt.unix ipaddr.unix cstruct-lwt tcpip.icmpv4 tcpip.ipv4\n tcpip.ipv6))\n\n(library\n (name udpv4v6_socket)\n (public_name tcpip.udpv4v6-socket)\n (modules udpv4v6_socket)\n (wrapped false)\n (instrumentation\n (backend bisect_ppx))\n (libraries lwt.unix ipaddr.unix cstruct-lwt fmt logs))\n\n(library\n (name tcp_socket_options)\n (public_name tcpip.tcp_socket_options)\n (modules tcp_socket_options)\n (foreign_stubs\n (language c)\n (names tcp_socket_options_stubs)\n (flags :standard))\n (wrapped false)\n (instrumentation\n (backend bisect_ppx))\n (libraries lwt.unix duration))\n\n(library\n (name tcpv4v6_socket)\n (public_name tcpip.tcpv4v6-socket)\n (modules tcp_socket tcpv4v6_socket)\n (wrapped false)\n (instrumentation\n (backend bisect_ppx))\n (libraries lwt.unix ipaddr.unix cstruct-lwt fmt tcpip tcp_socket_options logs))\n\n(library\n (name tcpip_stack_socket)\n (public_name tcpip.stack-socket)\n (modules tcpip_stack_socket ipv4_socket ipv6_socket ipv4v6_socket)\n (wrapped false)\n (instrumentation\n (backend bisect_ppx))\n (libraries lwt.unix cstruct-lwt ipaddr.unix logs tcpip.ipv4 tcpip.ipv6\n tcpip.tcpv4v6-socket tcpip.udpv4v6-socket))\n" }, { "path": "src/stack-unix/icmpv4_socket.ml", "content": "open Lwt.Infix\n\ntype ipaddr = Ipaddr.V4.t\n\ntype t = {\n mutable listening_sockets : Lwt_unix.file_descr list\n}\n\ntype error = [ `Ip of string ]\nlet pp_error ppf (`Ip s) = Fmt.string ppf s\n\nlet is_win32 = Sys.os_type = \"Win32\"\n\nlet ipproto_icmp = 1 (* according to BSD /etc/protocols *)\nlet port = 0 (* port isn't meaningful in this context *)\n\nlet safe_close fd =\n Lwt.catch\n (fun () -> Lwt_unix.close fd)\n (function\n | Unix.Unix_error (Unix.EBADF, _, _) -> Lwt.return_unit\n | e -> Lwt.fail e)\n\nlet connect () = Lwt.return { listening_sockets = [] }\nlet disconnect t = Lwt_list.iter_p safe_close t.listening_sockets\n\nlet pp_sockaddr fmt sa =\n let open Lwt_unix in\n match sa with\n | ADDR_UNIX s -> Format.fprintf fmt \"%s\" s\n | ADDR_INET (ip, port) -> Format.fprintf fmt \"%s, %d\" (Unix.string_of_inet_addr ip) port\n\nlet src = Logs.Src.create \"icmpv4_socket\" ~doc:\"Mirage ICMPv4 (Sockets Edition)\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nlet sendto' fd buf flags dst =\n if is_win32 then begin\n (* Lwt on Win32 doesn't support Lwt_bytes.sendto *)\n let bytes = Bytes.make (Cstruct.length buf) '\\000' in\n Cstruct.blit_to_bytes buf 0 bytes 0 (Cstruct.length buf);\n Lwt_unix.sendto fd bytes 0 (Bytes.length bytes) flags dst\n end else Lwt_cstruct.sendto fd buf flags dst\n\nlet recvfrom' fd buf flags =\n if is_win32 then begin\n (* Lwt on Win32 doesn't support Lwt_bytes.recvfrom *)\n let bytes = Bytes.make (Cstruct.length buf) '\\000' in\n Lwt_unix.recvfrom fd bytes 0 (Bytes.length bytes) flags\n >>= fun (n, sockaddr) ->\n Cstruct.blit_from_bytes bytes 0 buf 0 n;\n Lwt.return (n, sockaddr)\n end else Lwt_cstruct.recvfrom fd buf flags\n\nlet write _t ?src:_ ~dst ?ttl:_ttl buf =\n let open Lwt_unix in\n let flags = [] in\n let ipproto_icmp = 1 in (* according to BSD /etc/protocols *)\n let port = 0 in (* port isn't meaningful in this context *)\n let fd = socket PF_INET SOCK_RAW ipproto_icmp in\n let in_addr = Unix.inet_addr_of_string (Ipaddr.V4.to_string dst) in\n let sockaddr = ADDR_INET (in_addr, port) in\n Lwt.catch (fun () ->\n sendto' fd buf flags sockaddr >>= fun sent ->\n if (sent <> (Cstruct.length buf)) then\n Log.debug (fun f -> f \"short write: %d received vs %d expected\" sent (Cstruct.length buf));\n Lwt_unix.close fd |> Lwt_result.ok\n ) (fun exn -> Lwt.return @@ Error (`Ip (Printexc.to_string exn)))\n\nlet input t ~src ~dst:_ buf =\n (* some default logic -- respond to echo requests with echo replies *)\n match Icmpv4_packet.Unmarshal.of_cstruct buf with\n | Error s ->\n Log.debug (fun f -> f \"Error decomposing an ICMP packet: %s\" s);\n Lwt.return_unit\n | Ok (icmp, payload) ->\n let open Icmpv4_packet in\n match icmp.ty, icmp.subheader with\n | Icmpv4_wire.Echo_request, Id_and_seq (id, seq) ->\n let response =\n { ty = Icmpv4_wire.Echo_reply;\n code = 0x00;\n subheader = Id_and_seq (id, seq); } in\n (* TODO: if `listen` were allowed to report problems,\n * it would be sensible not to discard the value returned here,\n * but as it is we can only return () *)\n write t ~dst:src (Marshal.make_cstruct response ~payload) >>= fun _ -> Lwt.return_unit\n | _, _ -> Lwt.return_unit\n\nlet listen t addr fn =\n let fd = Lwt_unix.socket PF_INET SOCK_RAW ipproto_icmp in\n t.listening_sockets <- fd :: t.listening_sockets;\n let sa = Lwt_unix.ADDR_INET (Unix.inet_addr_of_string (Ipaddr.V4.to_string addr), port) in\n Lwt_unix.bind fd sa >>= fun () ->\n Log.debug (fun f -> f \"Bound ICMP file descriptor to %a\" pp_sockaddr sa);\n let rec loop () =\n let receive_buffer = Cstruct.create 4096 in\n recvfrom' fd receive_buffer [] >>= fun (len, _sockaddr) ->\n (* trim the buffer to the amount of data actually received *)\n let receive_buffer = Cstruct.sub receive_buffer 0 len in\n (* On macOS the IP length field is set to a very large value (16384) which\n probably reflects some kernel datastructure size rather than the real\n on-the-wire size. This confuses our IPv4 parser so we correct the size\n here. *)\n let len = Ipv4_wire.get_len receive_buffer in\n Ipv4_wire.set_len receive_buffer (min len (Cstruct.length receive_buffer));\n Lwt.async (fun () -> fn receive_buffer);\n loop ()\n in\n loop ()\n" }, { "path": "src/stack-unix/icmpv4_socket.mli", "content": "include Icmpv4.S\n\nval connect : unit -> t Lwt.t\n\nval listen : t -> ipaddr -> (Cstruct.t -> unit Lwt.t) -> unit Lwt.t\n(** [listen t addr fn] attempts to create an unprivileged listener on IP address [addr].\n\n When a packet is received, the callback [fn] will be called in a fresh background\n thread. The callback will be provided a buffer containing an IP datagram with an\n ICMP payload inside.\n\n The thread returned by [listen] blocks until the stack is disconnected.\n*)\n" }, { "path": "src/stack-unix/ipv4_socket.ml", "content": "(*\n * Copyright (c) 2014 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\ntype t = unit\ntype error = Tcpip.Ip.error\ntype ipaddr = Ipaddr.V4.t\ntype callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\ntype prefix = Ipaddr.V4.Prefix.t\n\nlet pp_error = Tcpip.Ip.pp_error\nlet pp_ipaddr = Ipaddr.V4.pp\nlet pp_prefix = Ipaddr.V4.Prefix.pp\n\nlet mtu _ ~dst:_ = 1500 - Ipv4_wire.sizeof_ipv4\n\nlet disconnect _ = Lwt.return_unit\nlet connect _ = Lwt.return_unit\n\nlet input _ ~tcp:_ ~udp:_ ~default:_ _ = Lwt.return_unit\nlet write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ =\n Lwt.fail (Failure \"Not implemented\")\n\nlet get_ip _ = [Ipaddr.V4.any]\nlet configured_ips _ = [Ipaddr.V4.Prefix.global]\nlet src _ ~dst:_ = raise (Failure \"Not implemented\")\nlet pseudoheader _ ?src:_ _ _ _ = raise (Failure \"Not implemented\")\n" }, { "path": "src/stack-unix/ipv4v6_socket.ml", "content": "(*\n * Copyright (c) 2014 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\ntype t = unit\ntype error = Tcpip.Ip.error\ntype ipaddr = Ipaddr.t\ntype callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\ntype prefix = Ipaddr.Prefix.t\n\nlet pp_error = Tcpip.Ip.pp_error\nlet pp_ipaddr = Ipaddr.pp\nlet pp_prefix = Ipaddr.Prefix.pp\n\nlet mtu _ ~dst = match dst with\n | Ipaddr.V4 _ -> 1500 - Ipv4_wire.sizeof_ipv4\n | Ipaddr.V6 _ -> 1500 - Ipv6_wire.sizeof_ipv6\n\nlet disconnect _ = Lwt.return_unit\nlet connect _ = Lwt.return_unit\n\nlet input _ ~tcp:_ ~udp:_ ~default:_ _ = Lwt.return_unit\nlet write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ =\n Lwt.fail (Failure \"Not implemented\")\n\nlet get_ip _ = [Ipaddr.V6 Ipaddr.V6.unspecified]\nlet configured_ips _ = [Ipaddr.Prefix.of_string_exn \"::/0\"]\nlet src _ ~dst:_ = raise (Failure \"Not implemented\")\nlet pseudoheader _ ?src:_ _ _ _ = raise (Failure \"Not implemented\")\n" }, { "path": "src/stack-unix/ipv6_socket.ml", "content": "(*\n * Copyright (c) 2014 Anil Madhavapeddy \n * Copyright (c) 2014 Nicolas Ojeda Bar \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\ntype t = unit\ntype error = Tcpip.Ip.error\ntype ipaddr = Ipaddr.V6.t\ntype callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t\ntype prefix = Ipaddr.V6.Prefix.t\n\nlet pp_error = Tcpip.Ip.pp_error\nlet pp_ipaddr = Ipaddr.V6.pp\nlet pp_prefix = Ipaddr.V6.Prefix.pp\n\nlet mtu _ ~dst:_ = 1500 - Ipv6_wire.sizeof_ipv6\n\nlet disconnect () = Lwt.return_unit\nlet connect () = Lwt.return_unit\n\nlet input _ ~tcp:_ ~udp:_ ~default:_ _ = Lwt.return_unit\nlet write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ =\n Lwt.fail (Failure \"Not implemented\")\n\nlet get_ip _ = [Ipaddr.V6.unspecified]\nlet configured_ips _ = [Ipaddr.V6.Prefix.of_string_exn \"::/0\"]\nlet src _ ~dst:_ = raise (Failure \"Not implemented\")\nlet pseudoheader _ ?src:_ _ _ _ = raise (Failure \"Not implemented\")\n" }, { "path": "src/stack-unix/tcp_socket.ml", "content": "open Lwt\n\ntype error = [ Tcpip.Tcp.error | `Exn of exn ]\ntype write_error = [ Tcpip.Tcp.write_error | `Exn of exn ]\n\nlet pp_error ppf = function\n | #Tcpip.Tcp.error as e -> Tcpip.Tcp.pp_error ppf e\n | `Exn e -> Fmt.exn ppf e\n\nlet pp_write_error ppf = function\n | #Tcpip.Tcp.write_error as e -> Tcpip.Tcp.pp_write_error ppf e\n | `Exn e -> Fmt.exn ppf e\n\nlet ignore_canceled = function\n | Lwt.Canceled -> Lwt.return_unit\n | exn -> raise exn\n\nlet disconnect _ =\n return_unit\n\nlet read fd =\n let buflen = 65536 in\n let buf = Cstruct.create buflen in\n Lwt.catch (fun () ->\n Lwt_cstruct.read fd buf\n >>= function\n | 0 -> return (Ok `Eof)\n | n when n = buflen -> return (Ok (`Data buf))\n | n -> return @@ Ok (`Data (Cstruct.sub buf 0 n))\n )\n (fun exn -> return (Error (`Exn exn)))\n\nlet rec write fd buf =\n Lwt.catch\n (fun () ->\n Lwt_cstruct.write fd buf\n >>= function\n | n when n = Cstruct.length buf -> return @@ Ok ()\n | 0 -> return @@ Error `Closed\n | n -> write fd (Cstruct.sub buf n (Cstruct.length buf - n))\n ) (function\n | Unix.Unix_error(Unix.EPIPE, _, _) -> return @@ Error `Closed\n | e -> return (Error (`Exn e)))\n\nlet writev fd bufs =\n Lwt_list.fold_left_s\n (fun res buf ->\n match res with\n | Error _ as e -> return e\n | Ok () -> write fd buf\n ) (Ok ()) bufs\n\n(* TODO make nodelay a flow option *)\nlet write_nodelay fd buf =\n write fd buf\n\n(* TODO make nodelay a flow option *)\nlet writev_nodelay fd bufs =\n writev fd bufs\n\nlet close fd =\n Lwt.catch\n (fun () -> Lwt_unix.close fd)\n (function\n | Unix.Unix_error (Unix.EBADF, _, _) -> Lwt.return_unit\n | e -> Lwt.fail e)\n\nlet shutdown fd mode =\n let cmd = match mode with\n | `read -> Lwt_unix.SHUTDOWN_RECEIVE\n | `write -> Lwt_unix.SHUTDOWN_SEND\n | `read_write -> Lwt_unix.SHUTDOWN_ALL\n in\n Lwt.return (Lwt_unix.shutdown fd cmd)\n\nlet input _t ~src:_ ~dst:_ _buf = Lwt.return_unit\n" }, { "path": "src/stack-unix/tcp_socket_options.ml", "content": "(*\n * Copyright (c) 2017 Docker Inc\n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nexternal tcp_set_keepalive_params: Unix.file_descr -> int -> int -> int -> unit = \"caml_tcp_set_keepalive_params\"\n\nlet enable_keepalive ~fd ~after ~interval ~probes =\n let fd' = Lwt_unix.unix_file_descr fd in\n let after = Duration.to_ms after in\n let interval = Duration.to_ms interval in\n tcp_set_keepalive_params fd' after interval probes;\n Lwt_unix.setsockopt fd Lwt_unix.SO_KEEPALIVE true" }, { "path": "src/stack-unix/tcp_socket_options_stubs.c", "content": "/*\n * Copyright (c) 2017 Docker Inc\n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n */\n\n#include \n#include \n#include \n#include \n#include \n#include \n#include \n\n#ifdef _WIN32\n#ifdef _MSC_VER\n/* https://docs.microsoft.com/en-us/windows/win32/winsock/sio-keepalive-vals */\n#include \n#endif\n#else\n#include \n#include \n#include \n#include \n#include \n#endif\n\n/* Round up to the next second */\n#define SECONDS_OF_MILLISECONDS(x) ( (x + 999) / 1000 )\n\nCAMLprim value\ncaml_tcp_set_keepalive_params(value v_fd, value v_time, value v_interval, value v_probe)\n{\n CAMLparam4(v_fd, v_time, v_interval, v_probe);\n#ifdef _WIN32\n SOCKET s = Socket_val(v_fd);\n DWORD dwBytesRet=0;\n struct tcp_keepalive alive;\n alive.onoff = TRUE;\n alive.keepalivetime = Int_val(v_time); /* ms */\n alive.keepaliveinterval = Int_val(v_interval); /* ms */\n if (WSAIoctl(s, SIO_KEEPALIVE_VALS, &alive, sizeof(alive),\n NULL, 0, &dwBytesRet, NULL, NULL) == SOCKET_ERROR) {\n win32_maperr(WSAGetLastError());\n }\n#elif DARWIN\n int s = Int_val(v_fd);\n int optval = SECONDS_OF_MILLISECONDS(Int_val(v_time));\n if(setsockopt(s, IPPROTO_TCP, TCP_KEEPALIVE, &optval, sizeof optval) < 0) {\n uerror(\"setsockopt\", Nothing);\n }\n optval = SECONDS_OF_MILLISECONDS(Int_val(v_interval));\n if(setsockopt(s, IPPROTO_TCP, TCP_KEEPINTVL, &optval, sizeof optval) < 0) {\n uerror(\"setsockopt\", Nothing);\n }\n optval = Int_val(v_probe);\n if(setsockopt(s, IPPROTO_TCP, TCP_KEEPCNT, &optval, sizeof optval) < 0) {\n uerror(\"setsockopt\", Nothing);\n }\n#elif LINUX\n int s = Int_val(v_fd);\n int optval = SECONDS_OF_MILLISECONDS(Int_val(v_time));\n if(setsockopt(s, SOL_TCP, TCP_KEEPIDLE, &optval, optlen) < 0) {\n uerror(\"setsockopt\", Nothing);\n }\n optval = SECONDS_OF_MILLISECONDS(Int_val(v_interval));\n if(setsockopt(s, SOL_TCP, TCP_KEEPINTVL, &optval, sizeof optval) < 0) {\n uerror(\"setsockopt\", Nothing);\n }\n optval = Int_val(v_probe);\n if(setsockopt(s, SOL_TCP, TCP_KEEPCNT, &optval, sizeof optval) < 0) {\n uerror(\"setsockopt\", Nothing);\n }\n#else\n fprintf(stderr, \"Warning: setting TCP keep-alive parameters not supported on this platform\\n\");\n#endif\n CAMLreturn(Val_unit);\n}\n" }, { "path": "src/stack-unix/tcpip_stack_socket.ml", "content": "(*\n * Copyright (c) 2014 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Lwt.Infix\n\nlet src = Logs.Src.create \"tcpip-stack-socket\" ~doc:\"Platform's native TCP/IP stack\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nmodule V4V6 = struct\n module TCP = Tcpv4v6_socket\n module UDP = Udpv4v6_socket\n module IP = Ipv4v6_socket\n\n type t = {\n udp : UDP.t;\n tcp : TCP.t;\n stop : unit Lwt.u;\n switched_off : unit Lwt.t;\n }\n\n let udp { udp; _ } = udp\n let tcp { tcp; _ } = tcp\n let ip _ = ()\n\n let listen t = t.switched_off\n\n let connect udp tcp =\n Log.info (fun f -> f \"Dual IPv4 and IPv6 socket stack: connect\");\n let switched_off, stop = Lwt.wait () in\n UDP.set_switched_off udp switched_off;\n TCP.set_switched_off tcp switched_off;\n Lwt.return { tcp; udp; stop; switched_off }\n\n let disconnect t =\n TCP.disconnect t.tcp >>= fun () ->\n UDP.disconnect t.udp >|= fun () ->\n Lwt.wakeup_later t.stop ()\nend\n" }, { "path": "src/stack-unix/tcpip_stack_socket.mli", "content": "(*\n * Copyright (c) 2014 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nmodule V4V6 : sig\n include Tcpip.Stack.V4V6\n with module UDP = Udpv4v6_socket\n and module TCP = Tcpv4v6_socket\n and module IP = Ipv4v6_socket\n val connect : Udpv4v6_socket.t -> Tcpv4v6_socket.t -> t Lwt.t\nend\n" }, { "path": "src/stack-unix/tcpv4v6_socket.ml", "content": "(*\n * Copyright (c) 2014 Anil Madhavapeddy \n * Copyright (c) 2014 Nicolas Ojeda Bar \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nlet src = Logs.Src.create \"tcpv4v6-socket\" ~doc:\"TCP socket v4v6 (platform native)\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nopen Lwt.Infix\n\ntype ipaddr = Ipaddr.t\ntype flow = Lwt_unix.file_descr\n\ntype t = {\n interface: [ `Any | `Ip of Unix.inet_addr * Unix.inet_addr | `V4_only of Unix.inet_addr | `V6_only of Unix.inet_addr ]; (* source ip to bind to *)\n mutable active_connections : Lwt_unix.file_descr list;\n listen_sockets : (int, Lwt_unix.file_descr list) Hashtbl.t;\n mutable switched_off : unit Lwt.t;\n}\n\nlet set_switched_off t switched_off =\n t.switched_off <- Lwt.pick [ switched_off; t.switched_off ]\n\nlet any_v6 = Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified\n\ninclude Tcp_socket\n\nlet connect ~ipv4_only ~ipv6_only ipv4 ipv6 =\n let interface =\n let v4 = Ipaddr.V4.Prefix.address ipv4 in\n let v4_unix = Ipaddr_unix.V4.to_inet_addr v4 in\n if ipv4_only then\n `V4_only v4_unix\n else if ipv6_only then\n `V6_only (match ipv6 with\n | None -> any_v6\n | Some x -> Ipaddr_unix.V6.to_inet_addr (Ipaddr.V6.Prefix.address x))\n else\n match ipv6, Ipaddr.V4.(compare v4 any) with\n | None, 0 -> `Any\n | None, _ -> `Ip (v4_unix, any_v6)\n | Some x, v4_any ->\n let v6 = Ipaddr.V6.Prefix.address x in\n if Ipaddr.V6.(compare v6 unspecified = 0) && v4_any = 0 then\n `Any\n else\n `Ip (v4_unix, Ipaddr_unix.V6.to_inet_addr v6)\n in\n Lwt.return {interface; active_connections = []; listen_sockets = Hashtbl.create 7; switched_off = fst (Lwt.wait ())}\n\nlet disconnect t =\n Lwt_list.iter_p close t.active_connections >>= fun () ->\n Lwt_list.iter_p close\n (Hashtbl.fold (fun _ fd acc -> fd @ acc) t.listen_sockets []) >>= fun () ->\n Lwt.cancel t.switched_off ; Lwt.return_unit\n\nlet dst fd =\n match Lwt_unix.getpeername fd with\n | Unix.ADDR_UNIX _ ->\n raise (Failure \"unexpected: got a unix instead of tcp sock\")\n | Unix.ADDR_INET (ia,port) ->\n let ip = Ipaddr_unix.of_inet_addr ia in\n let ip = match Ipaddr.to_v4 ip with\n | None -> ip\n | Some v4 -> Ipaddr.V4 v4\n in\n ip, port\n\nlet src fd =\n match Lwt_unix.getsockname fd with\n | Unix.ADDR_UNIX _ ->\n raise (Failure \"unexpected: got a unix instead of tcp sock\")\n | Unix.ADDR_INET (ia,port) ->\n let ip = Ipaddr_unix.of_inet_addr ia in\n let ip = match Ipaddr.to_v4 ip with\n | None -> ip\n | Some v4 -> Ipaddr.V4 v4\n in\n ip, port\n\nlet create_connection ?keepalive t (dst,dst_port) =\n match\n match dst, t.interface with\n | Ipaddr.V4 _, (`Any | `Ip _ | `V4_only _) -> Ok (Lwt_unix.PF_INET, fst)\n | Ipaddr.V6 _, (`Any | `Ip _ | `V6_only _) -> Ok (Lwt_unix.PF_INET6, snd)\n | Ipaddr.V4 _, `V6_only _ ->\n Error (`Msg \"Attempted to connect to an IPv4 host, but stack is IPv6 only\")\n | Ipaddr.V6 _, `V4_only _ ->\n Error (`Msg \"Attempted to connect to an IPv6 host, but stack is IPv4 only\")\n with\n | Error (`Msg m) -> Lwt.return (Error (`Exn (Invalid_argument m)))\n | Ok (family, proj) ->\n let fd = Lwt_unix.(socket family SOCK_STREAM 0) in\n Lwt.catch (fun () ->\n (match t.interface with\n | `Any -> Lwt.return_unit\n | `Ip p -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (proj p, 0))\n | `V4_only ip -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, 0))\n | `V6_only ip -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, 0))) >>= fun () ->\n Lwt_unix.connect fd\n (Lwt_unix.ADDR_INET ((Ipaddr_unix.to_inet_addr dst), dst_port))\n >>= fun () ->\n ( match keepalive with\n | None -> ()\n | Some { Tcpip.Tcp.Keepalive.after; interval; probes } ->\n Tcp_socket_options.enable_keepalive ~fd ~after ~interval ~probes );\n t.active_connections <- fd :: t.active_connections;\n Lwt.return (Ok fd))\n (fun exn ->\n close fd >>= fun () ->\n Lwt.return (Error (`Exn exn)))\n\nlet unlisten t ~port =\n match Hashtbl.find_opt t.listen_sockets port with\n | None -> ()\n | Some fds ->\n Hashtbl.remove t.listen_sockets port;\n try List.iter (fun fd -> Unix.close (Lwt_unix.unix_file_descr fd)) fds with _ -> ()\n\nlet listen t ~port ?keepalive callback =\n if port < 0 || port > 65535 then\n raise (Invalid_argument (Printf.sprintf \"invalid port number (%d)\" port));\n unlisten t ~port;\n let fds =\n match t.interface with\n | `Any ->\n let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in\n Lwt_unix.(setsockopt fd SO_REUSEADDR true);\n Lwt_unix.(setsockopt fd IPV6_ONLY false);\n [ (fd, Lwt_unix.ADDR_INET (any_v6, port)) ]\n | `Ip (v4, v6) ->\n let fd = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in\n Lwt_unix.(setsockopt fd SO_REUSEADDR true);\n let fd' = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in\n Lwt_unix.(setsockopt fd' SO_REUSEADDR true);\n Lwt_unix.(setsockopt fd' IPV6_ONLY true);\n [ (fd, Lwt_unix.ADDR_INET (v4, port)) ; (fd', Lwt_unix.ADDR_INET (v6, port)) ]\n | `V4_only ip ->\n let fd = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in\n Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true;\n [ (fd, Lwt_unix.ADDR_INET (ip, port)) ]\n | `V6_only ip ->\n let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in\n Lwt_unix.(setsockopt fd SO_REUSEADDR true);\n Lwt_unix.(setsockopt fd IPV6_ONLY true);\n [ (fd, Lwt_unix.ADDR_INET (ip, port)) ]\n in\n List.iter (fun (fd, addr) ->\n Unix.bind (Lwt_unix.unix_file_descr fd) addr;\n Hashtbl.replace t.listen_sockets port (List.map fst fds);\n Lwt_unix.listen fd 10;\n (* FIXME: we should not ignore the result *)\n Lwt.async (fun () ->\n (* TODO cancellation *)\n let rec loop () =\n if not (Lwt.is_sleeping t.switched_off) then raise Lwt.Canceled ;\n Lwt.catch (fun () ->\n Lwt_unix.accept fd >|= fun (afd, _) ->\n t.active_connections <- afd :: t.active_connections;\n (match keepalive with\n | None -> ()\n | Some { Tcpip.Tcp.Keepalive.after; interval; probes } ->\n Tcp_socket_options.enable_keepalive ~fd:afd ~after ~interval ~probes);\n Lwt.async\n (fun () ->\n Lwt.catch\n (fun () -> callback afd)\n (fun exn ->\n Log.warn (fun m -> m \"tcp error on port %u in callback %s\" port (Printexc.to_string exn)) ;\n close afd));\n `Continue)\n (function\n | Unix.Unix_error (Unix.EBADF, _, _) ->\n (match Hashtbl.find_opt t.listen_sockets port with\n | None -> ()\n | Some _ -> Log.warn (fun m -> m \"tcp error bad file descriptor in accept on port %u\" port)) ;\n Lwt.return `Stop\n | exn ->\n Log.warn (fun m -> m \"tcp error on port %u in accept: %s\" port (Printexc.to_string exn)) ;\n Lwt.return `Continue) >>= function\n | `Continue -> loop ()\n | `Stop -> Lwt.return_unit\n in\n Lwt.catch loop ignore_canceled >>= fun () -> close fd)) fds\n" }, { "path": "src/stack-unix/tcpv4v6_socket.mli", "content": "(*\n * Copyright (c) 2014 Anil Madhavapeddy \n * Copyright (c) 2014 Nicolas Ojeda Bar \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\ninclude Tcpip.Tcp.S\n with type ipaddr = Ipaddr.t\n and type flow = Lwt_unix.file_descr\n and type error = [ Tcpip.Tcp.error | `Exn of exn ]\n and type write_error = [ Tcpip.Tcp.write_error | `Exn of exn ]\n\nval connect : ipv4_only:bool -> ipv6_only:bool -> Ipaddr.V4.Prefix.t -> Ipaddr.V6.Prefix.t option -> t Lwt.t\n\nval set_switched_off : t -> unit Lwt.t -> unit\n" }, { "path": "src/stack-unix/udpv4v6_socket.ml", "content": "(*\n * Copyright (c) 2014 Anil Madhavapeddy \n * Copyright (c) 2014 Nicolas Ojeda Bar \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nlet src = Logs.Src.create \"udpv4v6-socket\" ~doc:\"UDP socket v4v6 (platform native)\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nopen Lwt.Infix\n\ntype ipaddr = Ipaddr.t\ntype callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t\n\nlet any_v6 = Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified\n\ntype t = {\n interface: [ `Any | `Ip of Unix.inet_addr * Unix.inet_addr | `V4_only of Unix.inet_addr | `V6_only of Unix.inet_addr ]; (* source ip to bind to *)\n listen_fds: (int, Lwt_unix.file_descr * Lwt_unix.file_descr option) Hashtbl.t; (* UDP fds bound to a particular port *)\n mutable switched_off : unit Lwt.t;\n}\n\nlet set_switched_off t switched_off =\n t.switched_off <- Lwt.pick [ switched_off; t.switched_off ]\n\nlet ignore_canceled = function\n | Lwt.Canceled -> Lwt.return_unit\n | exn -> raise exn\n\nlet get_udpv4v6_listening_fd ?(preserve = true) ?(v4_or_v6 = `Both) {listen_fds;interface;_} port =\n try\n Lwt.return\n (match Hashtbl.find listen_fds port with\n | (fd, None) -> false, [ fd ]\n | (fd, Some fd') -> false, [ fd ; fd' ])\n with Not_found ->\n (match interface with\n | `Any ->\n let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in\n Lwt_unix.(setsockopt fd IPV6_ONLY false);\n Lwt_unix.bind fd (Lwt_unix.ADDR_INET (any_v6, port)) >|= fun () ->\n ((fd, None), [ fd ])\n | `Ip (v4, v6) ->\n (match v4_or_v6 with\n | `Both ->\n let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in\n Lwt_unix.bind fd (Lwt_unix.ADDR_INET (v4, port)) >>= fun () ->\n let fd' = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in\n Lwt_unix.(setsockopt fd' IPV6_ONLY true);\n Lwt_unix.bind fd' (Lwt_unix.ADDR_INET (v6, port)) >|= fun () ->\n ((fd, Some fd'), [ fd ; fd' ])\n | `V4 ->\n let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in\n Lwt_unix.bind fd (Lwt_unix.ADDR_INET (v4, port)) >|= fun () ->\n ((fd, None), [ fd ])\n | `V6 ->\n let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in\n Lwt_unix.(setsockopt fd IPV6_ONLY true);\n Lwt_unix.bind fd (Lwt_unix.ADDR_INET (v6, port)) >|= fun () ->\n ((fd, None), [ fd ]))\n | `V4_only ip ->\n let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in\n Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, port)) >|= fun () ->\n ((fd, None), [ fd ])\n | `V6_only ip ->\n let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in\n Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, port)) >|= fun () ->\n ((fd, None), [ fd ])) >|= fun (fds, r) ->\n if preserve then Hashtbl.add listen_fds port fds;\n true, r\n\n\ntype error = [`Sendto_failed | `Different_ip_version]\n\nlet pp_error ppf = function\n | `Sendto_failed -> Fmt.pf ppf \"sendto failed to write any bytes\"\n | `Different_ip_version ->\n Fmt.string ppf \"attempting to send to a destination with a different IP protocol version\"\n\nlet close fd =\n Lwt.catch\n (fun () -> Lwt_unix.close fd)\n (function\n | Unix.Unix_error (Unix.EBADF, _, _) -> Lwt.return_unit\n | e -> Lwt.fail e)\n\nlet connect ~ipv4_only ~ipv6_only ipv4 ipv6 =\n let v4 = Ipaddr.V4.Prefix.address ipv4 in\n let v4_unix = Ipaddr_unix.V4.to_inet_addr v4 in\n let interface =\n if ipv4_only then\n `V4_only v4_unix\n else if ipv6_only then\n `V6_only (\n match ipv6 with\n | None -> any_v6\n | Some x -> Ipaddr_unix.V6.to_inet_addr (Ipaddr.V6.Prefix.address x))\n else\n match ipv6, Ipaddr.V4.(compare v4 any) with\n | None, 0 -> `Any\n | None, _ -> `Ip (v4_unix, any_v6)\n | Some x, v4_any ->\n let v6 = Ipaddr.V6.Prefix.address x in\n if Ipaddr.V6.(compare v6 unspecified = 0) && v4_any = 0 then\n `Any\n else\n `Ip (v4_unix, Ipaddr_unix.V6.to_inet_addr v6)\n in\n let listen_fds = Hashtbl.create 7 in\n Lwt.return { interface; listen_fds; switched_off = fst (Lwt.wait ()) }\n\nlet disconnect t =\n Hashtbl.fold (fun _ (fd, fd') r ->\n r >>= fun () ->\n close fd >>= fun () ->\n match fd' with None -> Lwt.return_unit | Some fd -> close fd)\n t.listen_fds Lwt.return_unit >>= fun () ->\n Lwt.cancel t.switched_off ; Lwt.return_unit\n\nlet input _t ~src:_ ~dst:_ _buf = Lwt.return_unit\n\nlet write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf =\n let open Lwt_unix in\n let rec write_to_fd fd buf =\n Lwt.catch (fun () ->\n let dst = match t.interface with `Any -> Ipaddr.(V6 (to_v6 dst)) | _ -> dst in\n Lwt_cstruct.sendto fd buf [] (ADDR_INET ((Ipaddr_unix.to_inet_addr dst), dst_port))\n >>= function\n | n when n = Cstruct.length buf -> Lwt.return (Ok ())\n | 0 -> Lwt.return (Error `Sendto_failed)\n | n -> write_to_fd fd (Cstruct.sub buf n (Cstruct.length buf - n))) (* keep trying *)\n (fun _exn -> Lwt.return (Error `Sendto_failed))\n in\n let v4_or_v6 = match dst with Ipaddr.V4 _ -> `V4 | Ipaddr.V6 _ -> `V6 in\n match t.interface, v4_or_v6 with\n | `Any, _ | `Ip _, _ | `V4_only _, `V4 | `V6_only _, `V6 ->\n let p = match src_port with None -> 0 | Some x -> x in\n get_udpv4v6_listening_fd ~preserve:false ~v4_or_v6 t p >>= fun (created, fds) ->\n ((match fds, v4_or_v6 with\n | [ fd ], _ -> Lwt.return (Ok fd)\n | [ v4 ; _v6 ], `V4 -> Lwt.return (Ok v4)\n | [ _v4; v6 ], `V6 -> Lwt.return (Ok v6)\n | _ -> Lwt.return (Error `Different_ip_version)) >>= function\n | Error _ as e -> Lwt.return e\n | Ok fd ->\n write_to_fd fd buf >>= fun r ->\n (if created then close fd else Lwt.return_unit) >|= fun () ->\n r)\n | _ -> Lwt.return (Error `Different_ip_version)\n\nlet unlisten t ~port =\n try\n let fd, fd' = Hashtbl.find t.listen_fds port in\n Hashtbl.remove t.listen_fds port;\n (match fd' with None -> () | Some fd' -> Unix.close (Lwt_unix.unix_file_descr fd'));\n Unix.close (Lwt_unix.unix_file_descr fd)\n with _ -> ()\n\nlet listen t ~port callback =\n if port < 0 || port > 65535 then\n raise (Invalid_argument (Printf.sprintf \"invalid port number (%d)\" port))\n else\n (* FIXME: we should not ignore the result *)\n Lwt.async (fun () ->\n get_udpv4v6_listening_fd t port >|= fun (_, fds) ->\n List.iter (fun fd ->\n Lwt.async (fun () ->\n let buf = Cstruct.create 4096 in\n let rec loop () =\n if not (Lwt.is_sleeping t.switched_off) then raise Lwt.Canceled ;\n Lwt.catch (fun () ->\n Lwt_cstruct.recvfrom fd buf [] >>= fun (len, sa) ->\n if len = 0 then\n Lwt.return `Stop\n else\n (match sa with\n | Lwt_unix.ADDR_INET (addr, src_port) ->\n let src = Ipaddr_unix.of_inet_addr addr in\n let src =\n match Ipaddr.to_v4 src with\n | None -> src\n | Some v4 -> Ipaddr.V4 v4\n in\n let dst = Ipaddr.(V6 V6.unspecified) in (* TODO *)\n let buf = Cstruct.sub_copy buf 0 len in\n callback ~src ~dst ~src_port buf\n | _ -> Lwt.return_unit) >|= fun () ->\n `Continue)\n (function\n | Unix.Unix_error (Unix.EBADF, _, _) ->\n (match Hashtbl.find_opt t.listen_fds port with\n | None -> ()\n | Some _ ->\n Log.info (fun m -> m \"udp error bad file descriptor in accept on port %u\" port)) ;\n Lwt.return `Stop\n | exn ->\n Log.warn (fun m -> m \"udp exception on port %u in recvfrom: %s\" port (Printexc.to_string exn)) ;\n Lwt.return `Continue) >>= function\n | `Continue -> loop ()\n | `Stop -> Lwt.return_unit\n in\n Lwt.catch loop ignore_canceled >>= fun () -> close fd)) fds)\n" }, { "path": "src/tcp/ack.ml", "content": "(*\n * Copyright (c) 2010 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Lwt.Infix\n\n(* General signature for all the ack modules *)\nmodule type M = sig\n type t\n\n (* ack: put mvar to trigger the transmission of an ack *)\n val t : send_ack:Sequence.t Lwt_mvar.t -> last:Sequence.t -> t\n\n (* called when new data is received *)\n val receive: t -> Sequence.t -> unit Lwt.t\n\n (* called when new data is received *)\n val pushack: t -> Sequence.t -> unit Lwt.t\n\n (* called when an ack is transmitted from elsewhere *)\n val transmit: t -> Sequence.t -> unit Lwt.t\nend\n\n(* Transmit ACKs immediately, the dumbest (and simplest) way *)\nmodule Immediate : M = struct\n\n type t = {\n send_ack: Sequence.t Lwt_mvar.t;\n mutable pushpending: bool;\n }\n\n let t ~send_ack ~last:_ =\n let pushpending = false in\n {send_ack; pushpending}\n\n let pushack t ack_number =\n t.pushpending <- true;\n Lwt_mvar.put t.send_ack ack_number\n\n let receive t ack_number =\n match t.pushpending with\n | true -> Lwt.return_unit\n | false -> pushack t ack_number\n\n let transmit t _ =\n t.pushpending <- false;\n Lwt.return_unit\nend\n\n\n(* Delayed ACKs *)\nmodule Delayed : M = struct\n\n type delayed_r = {\n send_ack: Sequence.t Lwt_mvar.t;\n mutable delayedack: Sequence.t;\n mutable delayed: bool;\n mutable pushpending: bool;\n }\n\n type t = {\n r: delayed_r;\n timer: Tcptimer.t;\n }\n\n let transmitacknow r ack_number =\n Lwt_mvar.put r.send_ack ack_number\n\n let transmitack r ack_number =\n match r.pushpending with\n | true -> Lwt.return_unit\n | false ->\n r.pushpending <- true;\n transmitacknow r ack_number\n\n let ontimer r s =\n match r.delayed with\n | false -> Lwt.return Tcptimer.Stoptimer\n | true ->\n match r.delayedack = s with\n | false ->\n Lwt.return (Tcptimer.Continue r.delayedack)\n | true ->\n r.delayed <- false;\n transmitack r s >>= fun () ->\n Lwt.return Tcptimer.Stoptimer\n\n let t ~send_ack ~last : t =\n let pushpending = false in\n let delayed = false in\n let delayedack = last in\n let r = {send_ack; delayedack; delayed; pushpending} in\n let expire = ontimer r in\n let period_ns = Duration.of_ms 100 in\n let timer = Tcptimer.t ~period_ns ~expire in\n {r; timer}\n\n\n (* Advance the received ACK count *)\n let receive t ack_number =\n match t.r.delayed with\n | true ->\n t.r.delayed <- false;\n transmitack t.r ack_number\n | false ->\n t.r.delayed <- true;\n t.r.delayedack <- ack_number;\n Tcptimer.start t.timer ack_number\n\n\n (* Force out an ACK *)\n let pushack t ack_number =\n transmitacknow t.r ack_number\n\n\n (* Indicate that an ACK has been transmitted *)\n let transmit t _ =\n t.r.delayed <- false;\n t.r.pushpending <- false;\n Lwt.return_unit\n\nend\n" }, { "path": "src/tcp/ack.mli", "content": "(*\n * Copyright (c) 2010 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nmodule type M =\nsig\n type t\n val t : send_ack:Sequence.t Lwt_mvar.t -> last:Sequence.t -> t\n\n val receive : t -> Sequence.t -> unit Lwt.t\n val pushack : t -> Sequence.t -> unit Lwt.t\n val transmit : t -> Sequence.t -> unit Lwt.t\nend\n\nmodule Immediate : M\n\nmodule Delayed : M\n" }, { "path": "src/tcp/dune", "content": "(library\n (name tcp)\n (public_name tcpip.tcp)\n (instrumentation\n (backend bisect_ppx))\n (libraries logs ipaddr cstruct lwt-dllist tcpip.checksum\n tcpip duration randomconv fmt mirage-sleep mirage-mtime\n mirage-crypto-rng mirage-flow metrics))\n" }, { "path": "src/tcp/flow.ml", "content": "(*\n * Copyright (c) 2010-2012 Anil Madhavapeddy \n * Copyright (c) 2012 Balraj Singh \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Lwt.Infix\n\nlet src = Logs.Src.create \"tcp.pcb\" ~doc:\"Mirage TCP PCB module\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nmodule Make(Ip: Tcpip.Ip.S) =\nstruct\n\n module ACK = Ack.Immediate\n module RXS = Segment.Rx(ACK)\n module TXS = Segment.Tx\n module UTX = User_buffer.Tx\n module WIRE = Wire.Make(Ip)\n module KEEPALIVE = Keepalive\n\n type error = [ Tcpip.Tcp.error | WIRE.error]\n\n let pp_error ppf = function\n | #Tcpip.Tcp.error as e -> Tcpip.Tcp.pp_error ppf e\n | #WIRE.error as e -> WIRE.pp_error ppf e\n\n type write_error = [Tcpip.Tcp.write_error | `Not_ready]\n\n let pp_write_error ppf = function\n | `Not_ready ->\n Fmt.string ppf \"attempted to send data before connection was ready\"\n | #Tcpip.Tcp.write_error as e -> Tcpip.Tcp.pp_write_error ppf e\n\n type ipaddr = Ip.ipaddr\n\n type pcb = {\n id: WIRE.t;\n wnd: Window.t; (* Window information *)\n rxq: RXS.t; (* Received segments queue for out-of-order data *)\n txq: TXS.t; (* Transmit segments queue *)\n ack: ACK.t; (* Ack state *)\n state: State.t; (* Connection state *)\n urx: User_buffer.Rx.t; (* App rx buffer *)\n utx: UTX.t; (* App tx buffer *)\n keepalive: KEEPALIVE.t option; (* Optional TCP keepalive state *)\n }\n\n type flow = pcb\n type connection = flow * unit Lwt.t\n\n type t = {\n ip : Ip.t;\n listeners : (int, Tcpip.Tcp.Keepalive.t option * (flow -> unit Lwt.t)) Hashtbl.t ;\n mutable active : bool ;\n mutable localport : int;\n channels: (WIRE.t, connection) Hashtbl.t;\n (* server connections the process of connecting - SYN-ACK sent\n waiting for ACK *)\n listens: (WIRE.t, (Sequence.t * ((flow -> unit Lwt.t) * connection)))\n Hashtbl.t;\n (* clients in the process of connecting *)\n connects: (WIRE.t, ((connection, error) result Lwt.u * Sequence.t * Tcpip.Tcp.Keepalive.t option)) Hashtbl.t;\n }\n\n let num_open_channels t = Hashtbl.length t.channels\n\n let listen t ~port ?keepalive cb =\n if port < 0 || port > 65535 then\n raise (Invalid_argument (Printf.sprintf \"invalid port number (%d)\" port))\n else\n Hashtbl.replace t.listeners port (keepalive, cb)\n\n let unlisten t ~port = Hashtbl.remove t.listeners port\n\n let _pp_pcb fmt pcb =\n Format.fprintf fmt \"id=[%a] state=[%a]\" WIRE.pp pcb.id State.pp pcb.state\n\n let pp_stats fmt t =\n Format.fprintf fmt \"[channels=%d listens=%d connects=%d]\"\n (Hashtbl.length t.channels)\n (Hashtbl.length t.listens)\n (Hashtbl.length t.connects)\n\n let log_with_stats name t = Log.debug (fun fmt -> fmt \"%s: %a\" name pp_stats t)\n\n let wscale_default = 2\n\n module Tx = struct\n\n (* Output a TCP packet, and calculate some settings from a state descriptor *)\n let xmit_pcb ip id ~flags ~wnd ~options ~seq (datav : Cstruct.t) =\n let window = Int32.to_int (Window.rx_wnd_unscaled wnd) in\n let rx_ack = Some (Window.rx_nxt wnd) in\n let syn = match flags with Segment.Syn -> true | _ -> false in\n let fin = match flags with Segment.Fin -> true | _ -> false in\n let rst = match flags with Segment.Rst -> true | _ -> false in\n let psh = match flags with Segment.Psh -> true | _ -> false in\n WIRE.xmit ~ip id ~syn ~fin ~rst ~psh ~rx_ack ~seq ~window ~options datav\n\n (* Output an RST response when we dont have a PCB *)\n let send_rst { ip; _ } id ~sequence ~ack_number ~syn ~fin =\n let datalen = Int32.add (if syn then 1l else 0l) (if fin then 1l else 0l) in\n let window = 0 in\n let options = [] in\n let seq = ack_number in\n let rx_ack = Some Sequence.(add sequence (of_int32 datalen)) in\n WIRE.xmit ~ip id ~rst:true ~rx_ack ~seq ~window ~options (Cstruct.create 0)\n\n (* Output a SYN packet *)\n let send_syn { ip; _ } id ~tx_isn ~options ~window =\n WIRE.xmit ~ip id ~syn:true ~rx_ack:None ~seq:tx_isn ~window ~options\n (Cstruct.create 0)\n\n (* Queue up an immediate close segment *)\n let shutdown ctx pcb =\n Log.debug (fun f -> f \"%s connection %a\" (match ctx with `Close -> \"Closing\" | `Shutdown -> \"Shutting down\") WIRE.pp pcb.id);\n match State.state pcb.state with\n | State.Established | State.Close_wait ->\n UTX.wait_for_flushed pcb.utx >>= fun () ->\n (let { wnd; _ } = pcb in\n State.tick pcb.state (State.Send_fin (Window.tx_nxt wnd));\n TXS.output ~flags:Segment.Fin pcb.txq Cstruct.empty\n )\n | State.Closed | State.Syn_rcvd _ | State.Syn_sent _ when ctx = `Close ->\n State.on_close pcb.state;\n Lwt.return_unit\n | _ ->\n Log.debug (fun fmt ->\n let msg = match ctx with `Close -> \"close\" | `Shutdown -> \"shutdown\" in\n fmt \"TX.%s: %s requested but no action needed, state=%a\" msg msg State.pp pcb.state);\n Lwt.return_unit\n\n (* Thread that transmits ACKs in response to received packets,\n thus telling the other side that more can be sent, and\n also data from the user transmit queue *)\n let thread t pcb ~send_ack ~rx_ack =\n let { wnd; ack; _ } = pcb in\n\n (* Transmit an empty ack when prompted by the Ack thread *)\n let rec send_empty_ack () =\n Lwt_mvar.take send_ack >>= fun _ ->\n let ack_number = Window.rx_nxt wnd in\n let flags = Segment.No_flags in\n let options = [] in\n let seq = Window.tx_nxt wnd in\n ACK.transmit ack ack_number >>= fun () ->\n xmit_pcb t.ip pcb.id ~flags ~wnd ~options ~seq (Cstruct.create 0) >>=\n fun _ -> (* TODO: what to do if sending failed. Ignoring\n * errors gives us the same behavior as if the packet\n * was lost in transit *)\n send_empty_ack () in\n (* When something transmits an ACK, tell the delayed ACK thread *)\n let rec notify () =\n Lwt_mvar.take rx_ack >>= fun ack_number ->\n ACK.transmit ack ack_number >>= fun () ->\n notify () in\n send_empty_ack () <&> (notify ())\n end\n\n module Rx = struct\n\n (* Process an incoming TCP packet that has an active PCB *)\n let input _t parsed (pcb,_) =\n let { rxq; _ } = pcb in\n (* The connection is alive! *)\n begin match pcb.keepalive with\n | None -> ()\n | Some keepalive -> KEEPALIVE.refresh keepalive\n end;\n (* Coalesce any outstanding segments and retrieve ready segments *)\n RXS.input rxq parsed\n\n let shutdown pcb =\n User_buffer.Rx.remove_all pcb.urx;\n User_buffer.Rx.add_r pcb.urx None\n\n (* Thread that spools the data into an application receive buffer,\n and notifies the ACK subsystem that new data is here *)\n let thread pcb ~rx_data =\n let { wnd; ack; urx; _ } = pcb in\n (* Thread to monitor application receive and pass it up *)\n let rec rx_application_t () =\n Lwt_mvar.take rx_data >>= fun (data, winadv) ->\n let signal_ack = function\n | None -> Lwt.return_unit\n | Some winadv when Sequence.(gt winadv zero) ->\n Window.rx_advance wnd winadv;\n ACK.receive ack (Window.rx_nxt wnd)\n | Some winadv ->\n Window.rx_advance wnd winadv;\n ACK.pushack ack (Window.rx_nxt wnd)\n in\n begin match data with\n | None ->\n (* don't send an ACK in this case; this already happened *)\n State.tick pcb.state State.Recv_fin;\n User_buffer.Rx.add_r urx None\n | Some data ->\n signal_ack winadv >>= fun () ->\n let rec queue = function\n | [] -> Lwt.return_unit\n | hd::tl ->\n User_buffer.Rx.add_r urx (Some hd) >>= fun () ->\n queue tl\n in\n queue data >>= fun _ ->\n rx_application_t ()\n end\n in\n rx_application_t ()\n end\n\n module Wnd = struct\n\n let thread ~urx:_ ~utx ~wnd:_ ~state ~tx_wnd_update =\n (* Monitor our transmit window when updates are received\n remotely, and tell the application that new space is\n available when it is blocked *)\n let rec tx_window_t () =\n Lwt_mvar.take tx_wnd_update >>= fun tx_wnd ->\n begin match State.state state with\n | State.Reset -> UTX.reset utx\n | _ -> UTX.free utx tx_wnd\n end >>= fun () ->\n tx_window_t ()\n in\n tx_window_t ()\n\n end\n\n (* Helper function to apply function with contents of hashtbl, or\n take default action *)\n let with_hashtbl h k fn default =\n try fn (Hashtbl.find h k) with Not_found -> default k\n\n let hashtbl_find h k =\n try Some (Hashtbl.find h k) with Not_found -> None\n\n let clearpcb t id tx_isn =\n log_with_stats \"removing pcb from connection tables\" t;\n match hashtbl_find t.channels id with\n | Some _ ->\n Hashtbl.remove t.channels id;\n Stats.decr_channel ();\n Log.debug (fun f -> f \"removed %a from active channels\" WIRE.pp id);\n | None ->\n match hashtbl_find t.listens id with\n | Some (isn, _) ->\n if isn = tx_isn then (\n Hashtbl.remove t.listens id;\n Stats.decr_listen ();\n Log.debug (fun f -> f \"removed %a from incomplete listen pcbs\" WIRE.pp id);\n )\n | None ->\n Log.debug (fun f -> f \"error in removing %a - no such connection\" WIRE.pp id)\n\n let pcb_allocs = ref 0\n let th_allocs = ref 0\n let pcb_frees = ref 0\n let th_frees = ref 0\n\n let resolve_wnd_scaling options rx_wnd_scaleoffer =\n let tx_wnd_scale = List.fold_left (fun a ->\n function Options.Window_size_shift m -> Some m | _ -> a\n ) None options in\n match tx_wnd_scale with\n | None -> (0, 0), []\n | Some tx_f ->\n (rx_wnd_scaleoffer, tx_f),\n (Options.Window_size_shift rx_wnd_scaleoffer :: [])\n\n type pcb_params =\n { tx_wnd: int;\n sequence: Sequence.t;\n options: Options.t list;\n tx_isn: Sequence.t;\n rx_wnd: int;\n rx_wnd_scaleoffer: int }\n\n\n let keepalive_cb t id wnd state urx = function\n | `SendProbe ->\n Log.debug (fun f -> f \"Sending keepalive on connection %a\" WIRE.pp id);\n (* From https://tools.ietf.org/html/rfc1122#page-101\n\n > 4.2.3.6 TCP Keep-Alives\n ...\n > Such a segment generally contains SEG.SEQ =\n > SND.NXT-1 and may or may not contain one garbage octet\n > of data. Note that on a quiet connection SND.NXT =\n > RCV.NXT, so that this SEG.SEQ will be outside the\n > window. Therefore, the probe causes the receiver to\n > return an acknowledgment segment, confirming that the\n > connection is still live. If the peer has dropped the\n > connection due to a network partition or a crash, it\n > will respond with a RST instead of an acknowledgment\n > segment.\n *)\n let flags = Segment.No_flags in\n let options = [] in\n let seq = Sequence.pred @@ Window.tx_nxt wnd in\n (* if the sending fails this behaves like a packet drop which will cause\n the connection to be eventually closed after the probes are sent *)\n Tx.xmit_pcb t.ip id ~flags ~wnd ~options ~seq (Cstruct.create 0) >>= fun _ ->\n Lwt.return_unit\n | `Close ->\n Log.debug (fun f -> f \"Keepalive timer expired, resetting connection %a\" WIRE.pp id);\n State.tick state State.Recv_rst;\n (* Close the read direction *)\n User_buffer.Rx.add_r urx None >>= fun () ->\n Lwt.return_unit\n\n let emitted_keepalive_warning = ref false\n\n let pcb_id = ref (-1)\n\n let new_pcb t params id keepalive =\n let mtu_mss = Ip.mtu t.ip ~dst:(WIRE.dst id) - Tcp_wire.sizeof_tcp in\n let { tx_wnd; sequence; options; tx_isn; rx_wnd; rx_wnd_scaleoffer } =\n params\n in\n let tx_mss = List.fold_left (fun a ->\n function\n | Options.MSS m -> min m mtu_mss\n | _ -> a\n ) mtu_mss options\n in\n let (rx_wnd_scale, tx_wnd_scale), opts =\n resolve_wnd_scaling options rx_wnd_scaleoffer\n in\n (* Set up the windowing variables *)\n let rx_isn = sequence in\n (* Initialise the window handler *)\n let wnd =\n Window.t ~rx_wnd_scale ~tx_wnd_scale ~rx_wnd ~tx_wnd ~rx_isn ~tx_mss\n ~tx_isn\n in\n (* When we transmit an ACK for a received segment, rx_ack is written to *)\n let rx_ack = Lwt_mvar.create_empty () in\n (* When we receive an ACK for a transmitted segment, tx_ack is written to *)\n let tx_ack = Lwt_mvar.create_empty () in\n (* When new data is received, rx_data is written to *)\n let rx_data = Lwt_mvar.create_empty () in\n (* Write to this mvar to transmit an empty ACK to the remote side *)\n let send_ack = Lwt_mvar.create_empty () in\n (* The user application receive buffer and close notification *)\n let rx_buf_size = Window.rx_wnd wnd in\n let urx = User_buffer.Rx.create ~max_size:rx_buf_size ~wnd in\n (* The window handling thread *)\n let tx_wnd_update = Lwt_mvar.create_empty () in\n (* Set up transmit and receive queues *)\n let on_close () = clearpcb t id tx_isn in\n let state =\n incr pcb_id;\n State.t ~id:!pcb_id ~on_close\n in\n let txq, _tx_t =\n TXS.create ~xmit:(Tx.xmit_pcb t.ip id) ~wnd ~state ~rx_ack ~tx_ack ~tx_wnd_update\n in\n (* Set up ACK module *)\n let ack = ACK.t ~send_ack ~last:(Sequence.succ rx_isn) in\n (* The user application transmit buffer *)\n let utx = UTX.create ~wnd ~txq ~max_size:16384l in\n let rxq = RXS.create ~rx_data ~ack ~wnd ~state ~tx_ack in\n (* Set up the keepalive state if requested *)\n let keepalive = match keepalive with\n | None -> None\n | Some config ->\n (* Only omit the warning once to avoid spamming the logs *)\n\tif not !emitted_keepalive_warning then begin\n Log.warn (fun f -> f \"using keep-alives can cause excessive memory consumption: https://github.com/mirage/mirage-tcpip/issues/367\");\n emitted_keepalive_warning := true\n end;\n Some (KEEPALIVE.create config (keepalive_cb t id wnd state urx)) in\n (* Construct basic PCB in Syn_received state *)\n let pcb = { state; rxq; txq; wnd; id; ack; urx; utx; keepalive } in\n (* Compose the overall thread from the various tx/rx threads\n and the main listener function *)\n let tx_thread = (Tx.thread t pcb ~send_ack ~rx_ack) in\n let rx_thread = (Rx.thread pcb ~rx_data) in\n let wnd_thread = (Wnd.thread ~utx ~urx ~wnd ~state ~tx_wnd_update) in\n let threads = [ tx_thread; rx_thread; wnd_thread ] in\n let catch_and_cancel = function\n | Lwt.Canceled -> ()\n | ex ->\n (* cancel the other threads *)\n List.iter Lwt.cancel threads;\n Log.err (fun f -> f \"thread failure: [%s]. Terminating threads and closing connection\"\n (Printexc.to_string ex));\n on_close ();\n !Lwt.async_exception_hook ex\n in\n List.iter (fun t -> Lwt.on_failure t catch_and_cancel) threads;\n let th = Lwt.join threads in\n pcb_allocs := !pcb_allocs + 1;\n th_allocs := !th_allocs + 1;\n let fnpcb = fun _ -> pcb_frees := !pcb_frees + 1 in\n let fnth = fun _ -> th_frees := !th_frees + 1 in\n Gc.finalise fnpcb pcb;\n Gc.finalise fnth th;\n Lwt.return (pcb, th, opts)\n\n let new_server_connection t params id pushf keepalive =\n log_with_stats \"new-server-connection\" t;\n new_pcb t params id keepalive >>= fun (pcb, th, opts) ->\n State.tick pcb.state State.Passive_open;\n State.tick pcb.state (State.Send_synack params.tx_isn);\n (* Add the PCB to our listens table *)\n if Hashtbl.mem t.listens id then (\n Log.debug (fun f -> f \"duplicate attempt to make a connection: %a .\\\n Removing the old state and replacing with new attempt\" WIRE.pp id);\n Hashtbl.remove t.listens id;\n Stats.decr_listen ();\n );\n Hashtbl.add t.listens id (params.tx_isn, (pushf, (pcb, th)));\n Stats.incr_listen ();\n (* Queue a SYN ACK for transmission *)\n let options = Options.MSS (Ip.mtu t.ip ~dst:(WIRE.dst id) - Tcp_wire.sizeof_tcp) :: opts in\n TXS.output ~flags:Segment.Syn ~options pcb.txq (Cstruct.create 0) >>= fun () ->\n Lwt.return (pcb, th)\n\n let new_client_connection t params id ack_number keepalive =\n log_with_stats \"new-client-connection\" t;\n let tx_isn = params.tx_isn in\n let params = { params with tx_isn = Sequence.succ tx_isn } in\n new_pcb t params id keepalive >>= fun (pcb, th, _) ->\n (* A hack here because we create the pcb only after the SYN-ACK is rx-ed*)\n State.tick pcb.state (State.Send_syn tx_isn);\n (* Add the PCB to our connection table *)\n Hashtbl.add t.channels id (pcb, th);\n Stats.incr_channel ();\n State.tick pcb.state (State.Recv_synack ack_number);\n (* xmit ACK *)\n TXS.output pcb.txq (Cstruct.create 0) >>= fun () ->\n Lwt.return (pcb, th)\n\n let is_correct_ack ~tx_isn ~ack_number =\n (Sequence.compare (Sequence.succ tx_isn) ack_number) = 0\n\n let process_reset t id ~ack ~ack_number =\n log_with_stats \"process-reset\" t;\n if ack then\n match hashtbl_find t.connects id with\n | Some (wakener, tx_isn, _) ->\n (* We don't send data in the syn request, so the expected ack is tx_isn + 1 *)\n if is_correct_ack ~tx_isn ~ack_number then begin\n Hashtbl.remove t.connects id;\n Stats.decr_connect ();\n Lwt.wakeup wakener (Error `Refused);\n Lwt.return_unit\n end else\n Lwt.return_unit\n | None ->\n match hashtbl_find t.listens id with\n | Some (_, (_, (pcb, th))) ->\n Hashtbl.remove t.listens id;\n Stats.decr_listen ();\n State.tick pcb.state State.Recv_rst;\n Lwt.cancel th;\n Lwt.return_unit\n | None ->\n (* Incoming RST possibly to listen port - ignore per RFC793 pg65 *)\n Lwt.return_unit\n else\n (* rst without ack, drop it *)\n Lwt.return_unit\n\n let process_synack t id ~tx_wnd ~ack_number ~sequence ~options ~syn ~fin =\n log_with_stats \"process-synack\" t;\n match hashtbl_find t.connects id with\n | Some (wakener, tx_isn, keepalive) ->\n if is_correct_ack ~tx_isn ~ack_number then (\n Hashtbl.remove t.connects id;\n Stats.decr_connect ();\n let rx_wnd = 65535 in\n (* TODO: fix hardcoded value - it assumes that this value was\n sent in the SYN *)\n let rx_wnd_scaleoffer = wscale_default in\n new_client_connection t\n { tx_wnd; sequence; options; tx_isn; rx_wnd; rx_wnd_scaleoffer }\n id ack_number keepalive\n >>= fun (pcb, th) ->\n Lwt.wakeup wakener (Ok (pcb, th));\n Lwt.return_unit\n ) else\n (* Normally sending a RST reply to a random pkt would be in\n order but here we stay quiet since we are actively trying\n to connect this id *)\n Lwt.return_unit\n | None ->\n (* Incoming SYN-ACK with no pending connect and no matching pcb\n - send RST *)\n Tx.send_rst t id ~sequence ~ack_number ~syn ~fin\n >>= fun _ -> Lwt.return_unit (* discard errors; we won't retry *)\n\n let process_syn t id ~tx_wnd ~ack_number ~sequence ~options ~syn ~fin =\n log_with_stats \"process-syn\" t;\n match Hashtbl.find_opt t.listeners (WIRE.src_port id) with\n | Some (keepalive, process) ->\n let tx_isn = Sequence.of_int32 (Randomconv.int32 Mirage_crypto_rng.generate) in\n (* TODO: make this configurable per listener *)\n let rx_wnd = 65535 in\n let rx_wnd_scaleoffer = wscale_default in\n new_server_connection t\n { tx_wnd; sequence; options; tx_isn; rx_wnd; rx_wnd_scaleoffer }\n id process keepalive\n >>= fun _ ->\n Lwt.return_unit\n | None ->\n Tx.send_rst t id ~sequence ~ack_number ~syn ~fin\n >>= fun _ -> Lwt.return_unit (* discard errors; we won't retry *)\n\n let process_ack t id ~pkt =\n let open RXS in\n log_with_stats \"process-ack\" t;\n match hashtbl_find t.listens id with\n | Some (tx_isn, (pushf, newconn)) ->\n if Tcp_packet.(is_correct_ack ~tx_isn ~ack_number:pkt.header.ack_number) then begin\n (* Established connection - promote to active channels *)\n Hashtbl.remove t.listens id;\n Stats.decr_listen ();\n Hashtbl.add t.channels id newconn;\n Stats.incr_channel ();\n (* Finish processing ACK, so pcb.state is correct *)\n Rx.input t pkt newconn >>= fun () ->\n (* send new connection up to listener *)\n pushf (fst newconn)\n end else\n (* No RST because we are trying to connect on this id *)\n Lwt.return_unit\n | None ->\n match hashtbl_find t.connects id with\n | Some _ ->\n (* No RST because we are trying to connect on this id *)\n Lwt.return_unit\n | None ->\n let { sequence; Tcp_packet.ack_number; syn; fin; _ } = pkt.header in\n (* ACK but no matching pcb and no listen - send RST *)\n Tx.send_rst t id ~sequence ~ack_number ~syn ~fin\n >>= fun _ -> Lwt.return_unit (* if send fails, who cares *)\n\n let input_no_pcb t (parsed, payload) id =\n if not t.active then\n (* TODO: eventually send an RST? *)\n Lwt.return_unit\n else\n let { sequence; Tcp_packet.ack_number; window; options; syn; fin; rst; ack; _ } = parsed in\n match rst, syn, ack with\n | true, _, _ -> process_reset t id ~ack ~ack_number\n | false, true, true ->\n process_synack t id ~ack_number ~sequence ~tx_wnd:window ~options ~syn ~fin\n | false, true , false -> process_syn t id ~tx_wnd:window\n\t\t\t ~ack_number ~sequence ~options ~syn ~fin\n | false, false, true ->\n let open RXS in\n process_ack t id ~pkt:{ header = parsed; payload}\n | false, false, false ->\n Log.debug (fun f -> f \"incoming packet matches no connection table entry and has no useful flags set; dropping it\");\n Lwt.return_unit\n\n (* Main input function for TCP packets *)\n let input t ~src ~dst data =\n let open Tcp_packet in\n match Unmarshal.of_cstruct data with\n | Error s -> Log.debug (fun f -> f \"parsing TCP header failed: %s\" s);\n Lwt.return_unit\n | Ok (pkt, payload) ->\n let id =\n WIRE.v ~src_port:pkt.dst_port ~dst_port:pkt.src_port ~dst:src ~src:dst\n in\n (* Lookup connection from the active PCB hash *)\n with_hashtbl t.channels id\n (* PCB exists, so continue the connection state machine in tcp_input *)\n (Rx.input t RXS.({header = pkt; payload}))\n (* No existing PCB, so check if it is a SYN for a listening function *)\n (input_no_pcb t (pkt, payload))\n\n (* Blocking read on a PCB *)\n let read pcb =\n User_buffer.Rx.take_l pcb.urx\n >>= function\n | None -> Lwt.return @@ Ok `Eof\n | Some t -> Lwt.return @@ Ok (`Data t)\n\n (* Maximum allowed write *)\n let write_available pcb =\n (* Our effective outgoing MTU is what can fit in a page *)\n min 4000 (min (Window.tx_mss pcb.wnd)\n (Int32.to_int (UTX.available pcb.utx)))\n\n (* Wait for more write space *)\n let write_wait_for pcb sz =\n UTX.wait_for pcb.utx (Int32.of_int sz)\n\n let rec writefn pcb wfn data =\n match State.state pcb.state with\n (* but it's only appropriate to send data if the connection is ready for it *)\n | State.Established | State.Close_wait -> begin\n let len = Cstruct.length data in\n match write_available pcb with\n | 0 -> (* no room at all; we must wait *)\n write_wait_for pcb 1 >>= fun () ->\n writefn pcb wfn data\n | av_len when av_len >= len -> (* we have enough room for the whole packet *)\n wfn [data] >>= fun n -> Lwt.return (Ok n)\n | av_len -> (* partial send is possible *)\n let sendable = Cstruct.sub data 0 av_len in\n writefn pcb wfn sendable >>= function\n | Ok () -> writefn pcb wfn @@ Cstruct.sub data av_len (len - av_len)\n | Error _ as e -> Lwt.return e\n end\n | _ -> Lwt.return (Error `Not_ready)\n\n let rec iter_s f = function\n | [] -> Lwt.return (Ok ())\n | h :: t -> f h >>= function\n | Ok () -> iter_s f t\n | e -> Lwt.return e\n\n (* Blocking write on a PCB *)\n let cast x = (x :> (unit, write_error) result Lwt.t)\n\n let write pcb data = writefn pcb (UTX.write pcb.utx) data |> cast\n let writev pcb data = iter_s (write pcb) data |> cast\n\n let write_nodelay pcb data = writefn pcb (UTX.write_nodelay pcb.utx) data |> cast\n let writev_nodelay pcb data = iter_s (write_nodelay pcb) data |> cast\n\n (* Close *)\n let close pcb = Tx.shutdown `Close pcb\n\n let shutdown pcb mode =\n let wr, rd = match mode with | `read -> false, true | `write -> true, false | `read_write -> true, true in\n (if wr then Tx.shutdown `Shutdown pcb else Lwt.return_unit) >>= fun () ->\n (if rd then Rx.shutdown pcb else Lwt.return_unit)\n\n let dst pcb = WIRE.dst pcb.id, WIRE.dst_port pcb.id\n\n let src pcb = WIRE.src pcb.id, WIRE.src_port pcb.id\n\n let getid t dst dst_port =\n (* TODO: make this more robust and recognise when all ports are gone *)\n let islistener _t _port =\n (* TODO keep a list of active listen ports *)\n false in\n let idinuse t id =\n Hashtbl.mem t.channels id ||\n Hashtbl.mem t.connects id ||\n Hashtbl.mem t.listens id\n in\n let inuse t id = islistener t (WIRE.src_port id) || idinuse t id in\n let rec bumpport t =\n (match t.localport with\n | 65535 -> t.localport <- 10000\n | _ -> t.localport <- t.localport + 1);\n let id =\n WIRE.v ~src:(Ip.src t.ip ~dst) ~src_port:t.localport ~dst ~dst_port\n in\n if inuse t id then bumpport t else id\n in\n bumpport t\n\n (* SYN retransmission timer *)\n let rec connecttimer t id tx_isn options window count =\n let rxtime = match count with\n | 0 -> 3 | 1 -> 6 | 2 -> 12 | 3 -> 24 | _ -> 48\n in\n Mirage_sleep.ns (Duration.of_sec rxtime) >>= fun () ->\n match hashtbl_find t.connects id with\n | None -> Lwt.return_unit\n | Some (wakener, isn, _) ->\n if isn = tx_isn then\n if count > 3 then (\n Hashtbl.remove t.connects id;\n Stats.decr_connect ();\n Lwt.wakeup wakener (Error `Timeout);\n Lwt.return_unit\n ) else (\n Tx.send_syn t id ~tx_isn ~options ~window >>= function\n | Ok () -> connecttimer t id tx_isn options window (count + 1)\n | Error (`No_route _s) ->\n (* normal mechanism for recovery is fine *)\n connecttimer t id tx_isn options window (count + 1)\n | Error `Would_fragment ->\n (* this should not happen, if we've a transport that fragments syn.. *)\n Log.err (fun m -> m \"syn retransmission timer returned would fragment\");\n Lwt.return_unit\n )\n else Lwt.return_unit\n\n let connect ?keepalive t ~dst ~dst_port =\n let id = getid t dst dst_port in\n let tx_isn = Sequence.of_int32 (Randomconv.int32 Mirage_crypto_rng.generate) in\n (* TODO: This is hardcoded for now - make it configurable *)\n let rx_wnd_scaleoffer = wscale_default in\n let options =\n Options.MSS (Ip.mtu t.ip ~dst - Tcp_wire.sizeof_tcp) :: Options.Window_size_shift rx_wnd_scaleoffer :: []\n in\n let window = 5840 in\n let th, wakener = Lwt.wait () in\n if Hashtbl.mem t.connects id then (\n Log.debug (fun f ->\n f \"duplicate attempt to make a connection: [%a]. \\\n Removing the old state and replacing with new attempt\"\n WIRE.pp id);\n Hashtbl.remove t.connects id;\n Stats.decr_connect ();\n );\n Hashtbl.add t.connects id (wakener, tx_isn, keepalive);\n Stats.incr_connect ();\n Tx.send_syn t id ~tx_isn ~options ~window >>= function\n | Ok () | Error _ (* keep trying *) ->\n Lwt.async (fun () -> connecttimer t id tx_isn options window 0);\n th\n\n let log_failure daddr dport = function\n | `Timeout ->\n Log.debug (fun fmt ->\n fmt \"Timeout attempting to connect to %a:%d\\n%!\"\n Ip.pp_ipaddr daddr dport)\n | `Refused ->\n Log.debug (fun fmt ->\n fmt \"Refused connection to %a:%d\\n%!\"\n Ip.pp_ipaddr daddr dport)\n | e ->\n Log.debug (fun fmt ->\n fmt \"%a error connecting to %a:%d\\n%!\"\n pp_error e Ip.pp_ipaddr daddr dport)\n\n let create_connection ?keepalive tcp (daddr, dport) =\n if not tcp.active then\n Lwt.return (Error `Timeout) (* TODO: custom error variant *)\n else\n connect ?keepalive tcp ~dst:daddr ~dst_port:dport >>= function\n | Error e -> log_failure daddr dport e; Lwt.return @@ Error e\n | Ok (fl, _) -> Lwt.return (Ok fl)\n\n (* Construct the main TCP thread *)\n let connect ip =\n let localport =\n 1024 + (Randomconv.int ~bound:(0xFFFF - 1024) Mirage_crypto_rng.generate)\n in\n let listens = Hashtbl.create 1 in\n let connects = Hashtbl.create 1 in\n let channels = Hashtbl.create 7 in\n Log.info (fun f -> f \"TCP layer connected on %a\"\n Fmt.(list ~sep:(any \", \") Ip.pp_prefix)\n (Ip.configured_ips ip));\n Lwt.return { ip; listeners = Hashtbl.create 7; active = true; localport; channels; listens; connects }\n\n let disconnect t =\n t.active <- false;\n Log.info (fun f -> f \"TCP layer disconnected on %a\"\n Fmt.(list ~sep:(any \", \") Ip.pp_prefix)\n (Ip.configured_ips t.ip));\n let conns = Hashtbl.fold (fun _ (pcb, _) acc -> pcb :: acc) t.channels [] in\n Lwt_list.iter_p close conns >|= fun () ->\n Hashtbl.reset t.listens;\n Hashtbl.reset t.connects\n (* TODO: should there be Lwt tasks being cancelled? *)\nend\n" }, { "path": "src/tcp/flow.mli", "content": "(*\n * Copyright (c) 2011-2014 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nmodule Make (IP:Tcpip.Ip.S) : sig\n include Tcpip.Tcp.S with type ipaddr = IP.ipaddr\n val connect : IP.t -> t Lwt.t\n\n (**/**)\n (* the number of open connections *)\n val num_open_channels : t -> int\n (**/**)\n\nend\n" }, { "path": "src/tcp/keepalive.ml", "content": "(*\n * Copyright (c) 2017 Docker Inc\n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\ntype action = [\n | `SendProbe\n | `Wait of Duration.t\n | `Close\n]\n\ntype state = {\n probes_sent: int\n}\n\nlet alive = {\n probes_sent = 0;\n}\n\nlet next ~configuration ~ns state =\n let open Tcpip.Tcp.Keepalive in\n let after_ns = configuration.after in\n (* Wait until [time] has gone past *)\n if after_ns > ns\n then `Wait (Int64.sub after_ns ns), alive\n else begin\n let sending_probes_for_ns = Int64.sub ns after_ns in\n let interval_ns = configuration.interval in\n let should_have_sent = Int64.(to_int (div sending_probes_for_ns interval_ns)) in\n if should_have_sent > configuration.probes\n then `Close, state\n else\n if should_have_sent > state.probes_sent\n then `SendProbe, { probes_sent = should_have_sent } (* we don't want to send back-to-back probes *)\n else begin\n let since_last_probe_ns = Int64.rem sending_probes_for_ns interval_ns in\n `Wait (Int64.sub interval_ns since_last_probe_ns), state\n end\n end\n\ntype t = {\n configuration: Tcpip.Tcp.Keepalive.t;\n callback: ([ `SendProbe | `Close ] -> unit Lwt.t);\n mutable state: state;\n mutable timer: unit Lwt.t;\n mutable start: int64;\n}\n(** A keep-alive timer *)\n\nlet rec restart t =\n let open Lwt.Infix in\n let ns = Int64.sub (Mirage_mtime.elapsed_ns ()) t.start in\n match next ~configuration:t.configuration ~ns t.state with\n | `Wait ns, state ->\n Mirage_sleep.ns ns >>= fun () ->\n t.state <- state;\n restart t\n | `SendProbe, state ->\n t.callback `SendProbe >>= fun () ->\n t.state <- state;\n restart t\n | `Close, _ ->\n t.callback `Close >>= fun () ->\n Lwt.return_unit\n\nlet create configuration callback =\n let state = alive in\n let timer = Lwt.return_unit in\n let start = Mirage_mtime.elapsed_ns () in\n let t = { configuration; callback; state; timer; start } in\n t.timer <- restart t;\n t\n\nlet refresh t =\n t.start <- Mirage_mtime.elapsed_ns ();\n t.state <- alive;\n Lwt.cancel t.timer;\n t.timer <- restart t\n\n" }, { "path": "src/tcp/keepalive.mli", "content": "(*\n * Copyright (c) 2017 Docker Inc\n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\n(** TCP keepalives.\n\n A TCP implementation may send \"keep-alives\" (empty TCP ACKs with the\n sequence number set to one less than the current sequence number for\n the connection) in order to provoke the peer to respond with an ACK\n of the current sequence number. If the peer doesn't recognise the\n connection (e.g. because the connection state has been dropped) then\n it will return a RST; if the peer (or the network in-between) fails\n to respond to a configured number of repeated probes then the\n connection is assumed to be lost.\n*)\n\ntype action = [\n | `SendProbe (** we should send a keep-alive now *)\n | `Wait of Duration.t (** sleep for a given number of nanoseconds *)\n | `Close (** connection should be closed *)\n]\n(** An I/O action to perform *)\n\ntype state\n(** State of a current connection *)\n\nval alive: state\n(** An alive connection *)\n\nval next: configuration:Tcpip.Tcp.Keepalive.t -> ns:int64 -> state -> action * state\n(** [next ~configuration ~ns state] returns the action we should take given\n that we last received a packet [ns] nanoseconds ago and the new state\n of the connection *)\n\ntype t\n(** A keep-alive timer *)\n\nval create: Tcpip.Tcp.Keepalive.t -> ([ `SendProbe | `Close] -> unit Lwt.t) -> t\n(** [create configuration f clock] returns a keep-alive timer which will call\n [f] in future depending on both the [configuration] and any calls to\n [refresh] *)\n\nval refresh: t -> unit\n(** [refresh t] marks the connection [t] as alive. This should be called\n when packets are received. *)\n" }, { "path": "src/tcp/options.ml", "content": "(*\n * Copyright (c) 2011 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\n(* TCP options parsing *)\n\ntype t =\n | Noop\n | MSS of int (* RFC793 *)\n | Window_size_shift of int (* RFC1323 2.2 *)\n | SACK_ok (* RFC2018 *)\n | SACK of (int32 * int32) list (* RFC2018 *)\n | Timestamp of int32 * int32 (* RFC1323 3.2 *)\n | Unknown of int * string (* RFC793 *)\n\nlet equal x y = match x, y with\n | Noop, Noop -> true\n | MSS x, MSS y -> x = y\n | Window_size_shift x, Window_size_shift y -> x = y\n | SACK_ok, SACK_ok -> true\n | Timestamp (a, b), Timestamp (x, y) -> a = x && b = y\n | SACK l1, SACK l2 -> List.for_all2 (fun x y -> x = y) l1 l2\n | Unknown (a, s1), Unknown (b, s2) -> a = b && String.equal s1 s2\n | _, _ -> false\n\nlet report_error n =\n let error = Printf.sprintf \"Invalid option %d presented\" n in\n Error error\n\nlet check_mss buf =\n let min_mss_size = 88 in\n let mss_size = Cstruct.BE.get_uint16 buf 2 in\n if mss_size < min_mss_size then\n let err = (Printf.sprintf \"Invalid MSS %d received\" mss_size) in\n Error err\n else\n Ok (MSS mss_size)\n\nlet unmarshal buf =\n let i = Cstruct.iter\n (fun buf ->\n match Cstruct.get_uint8 buf 0 with\n | 0 -> None (* EOF *)\n | 1 -> Some 1 (* NOP *)\n | _option_type ->\n match Cstruct.length buf with\n | 0 | 1 -> None\n | buffer_size ->\n let option_size = Cstruct.get_uint8 buf 1 in\n if option_size <= buffer_size && option_size >= 2 then\n Some option_size\n else None (* Nothing after this can be trusted, but previous\n options might be all right *)\n )\n (fun buf ->\n match Cstruct.get_uint8 buf 0 with\n | 0 -> assert false\n | 1 -> Ok Noop\n | option_number ->\n let option_length = Cstruct.get_uint8 buf 1 in\n if Cstruct.length buf < option_length then\n report_error option_number\n else begin\n match option_number, option_length with\n (* error out for lengths that are always nonsensible when option\n * number >1 *)\n | _, 0 | _, 1 -> report_error option_number\n | 2, 4 -> check_mss buf\n | 3, 3 -> Ok (Window_size_shift (Cstruct.get_uint8 buf 2))\n | 4, 2 -> Ok SACK_ok\n | 5, _ ->\n let num = (option_length - 2) / 8 in\n let rec to_int32_list off acc = function\n |0 -> acc\n |n ->\n let x =\n Cstruct.BE.get_uint32 buf off,\n Cstruct.BE.get_uint32 buf (off+4)\n in\n to_int32_list (off+8) (x::acc) (n-1)\n in Ok (SACK (to_int32_list 2 [] num))\n | 8, 10 -> Ok (Timestamp (Cstruct.BE.get_uint32 buf 2,\n Cstruct.BE.get_uint32 buf 6))\n (* error out for lengths that don't match the spec's\n fixed length for a given, recognized option number *)\n | 2, _ | 3, _ | 4, _ | 8, _ -> report_error option_number\n (* Parse apparently well-formed but unrecognized\n options *)\n | n, _ ->\n Ok (Unknown (n, Cstruct.to_string ~off:2 buf))\n end\n ) buf in\n Result.map List.rev\n (Cstruct.fold (fun a b ->\n match a, b with\n | Ok items, Ok item -> Ok (item :: items)\n | _, Error s | Error s, _ -> Error s\n ) i (Ok []))\n\nlet size_of_option = function\n | Noop -> 1\n | MSS _ -> 4\n | Window_size_shift _ -> 3\n | SACK_ok -> 2\n | SACK acks -> (List.length acks * 8) + 2\n | Timestamp _ -> 10\n | Unknown (_, contents) -> String.length contents + 2\n\n(* add padding to word length *)\nlet pad tlen =\n match (4 - (tlen mod 4)) mod 4 with\n | 0 -> tlen\n | n when n < 4 -> tlen + n\n | _ -> assert false\n\nlet lenv l =\n pad @@ List.fold_left (fun acc item -> size_of_option item + acc) 0 l\n\nlet write_iter buf =\n let set_tlen t l =\n Cstruct.set_uint8 buf 0 t;\n Cstruct.set_uint8 buf 1 l\n in\n function\n | Noop ->\n Cstruct.set_uint8 buf 0 1;\n 1\n | MSS sz ->\n set_tlen 2 4;\n Cstruct.BE.set_uint16 buf 2 sz;\n 4\n | Window_size_shift shift ->\n set_tlen 3 3;\n Cstruct.set_uint8 buf 2 shift;\n 3\n | SACK_ok ->\n set_tlen 4 2;\n 2\n | SACK acks ->\n let tlen = (List.length acks * 8) + 2 in\n set_tlen 5 tlen;\n let rec fn off = function\n | (le,re)::tl ->\n Cstruct.BE.set_uint32 buf off le;\n Cstruct.BE.set_uint32 buf (off+4) re;\n fn (off+8) tl\n | [] -> () in\n fn 2 acks;\n tlen\n | Timestamp (tsval,tsecr) ->\n set_tlen 8 10;\n Cstruct.BE.set_uint32 buf 2 tsval;\n Cstruct.BE.set_uint32 buf 6 tsecr;\n 10\n | Unknown (kind, contents) ->\n let content_len = String.length contents in\n let tlen = content_len + 2 in\n set_tlen kind tlen;\n Cstruct.blit_from_string contents 0 buf 2 content_len;\n tlen\n\nlet marshal buf ts =\n (* Apply the write iterator on each stamp *)\n let rec write fn off buf =\n function\n | hd::tl ->\n let wlen = fn buf hd in\n let buf = Cstruct.shift buf wlen in\n write fn (off+wlen) buf tl\n | [] -> off\n in\n let tlen = write write_iter 0 buf ts in\n (* add padding to word length *)\n match (4 - (tlen mod 4)) mod 4 with\n | 0 -> tlen\n | 1 ->\n Cstruct.set_uint8 buf tlen 0;\n tlen+1\n | 2 ->\n Cstruct.set_uint8 buf tlen 0;\n Cstruct.set_uint8 buf (tlen+1) 0;\n tlen+2\n | 3 ->\n Cstruct.set_uint8 buf tlen 0;\n Cstruct.set_uint8 buf (tlen+1) 0;\n Cstruct.set_uint8 buf (tlen+2) 0;\n tlen+3\n | _ -> assert false\n\nlet pf = Format.fprintf\n\nlet pp_sack fmt x =\n let pp_v fmt (l, r) = pf fmt \"[%lu,%lu]\" l r in\n Format.pp_print_list pp_v fmt x\n\nlet pp fmt = function\n | Noop -> pf fmt \"Noop\"\n | MSS m -> pf fmt \"MSS=%d\" m\n | Window_size_shift b -> pf fmt \"Window>> %d\" b\n | SACK_ok -> pf fmt \"SACK_ok\"\n | SACK x -> pf fmt \"SACK[%a]\" pp_sack x\n | Timestamp (a,b) -> pf fmt \"Timestamp(%lu,%lu)\" a b\n | Unknown (t,_) -> pf fmt \"%d?\" t\n\nlet pps = Fmt.Dump.list pp\n" }, { "path": "src/tcp/options.mli", "content": "(*\n * Copyright (c) 2011 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\n(** TCP options parsing *)\n\ntype t =\n | Noop\n | MSS of int (** RFC793 *)\n | Window_size_shift of int (** RFC1323 2.2 *)\n | SACK_ok (** RFC2018 *)\n | SACK of (int32 * int32) list (** RFC2018 *)\n | Timestamp of int32 * int32 (** RFC1323 3.2 *)\n | Unknown of int * string (** RFC793 *)\n\nval equal: t -> t -> bool\nval lenv: t list -> int (* how many bytes are required to marshal this list *)\nval marshal: Cstruct.t -> t list -> int\nval unmarshal : Cstruct.t -> (t list, string) result\nval pp : Format.formatter -> t -> unit\nval pps : Format.formatter -> t list -> unit\n" }, { "path": "src/tcp/segment.ml", "content": "(*\n * Copyright (c) 2010-2011 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Lwt.Infix\n\nlet src = Logs.Src.create \"tcp.segment\" ~doc:\"Mirage TCP Segment module\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nlet lwt_sequence_add_l s seq =\n let (_:'a Lwt_dllist.node) = Lwt_dllist.add_l s seq in\n ()\n\nlet lwt_sequence_add_r s seq =\n let (_:'a Lwt_dllist.node) = Lwt_dllist.add_r s seq in\n ()\n\nlet peek_opt_l seq =\n match Lwt_dllist.take_opt_l seq with\n | None -> None\n | Some s ->\n lwt_sequence_add_l s seq;\n Some s\n\nlet peek_l seq =\n match Lwt_dllist.take_opt_l seq with\n | None -> assert false\n | Some s ->\n let _ = Lwt_dllist.add_l s seq in\n s\n\nlet rec reset_seq segs =\n match Lwt_dllist.take_opt_l segs with\n | None -> ()\n | Some _ -> reset_seq segs\n\n(* The receive queue stores out-of-order segments, and can\n coalesece them on input and pass on an ordered list up the\n stack to the application.\n\n It also looks for control messages and dispatches them to\n the Rtx queue to ack messages or close channels.\n*)\nmodule Rx(ACK: Ack.M) = struct\n open Tcp_packet\n\n (* Individual received TCP segment\n TODO: this will change when IP fragments work *)\n type segment = { header: Tcp_packet.t; payload: Cstruct.t }\n\n let pp_segment fmt {header; payload} =\n Format.fprintf fmt\n \"RX seg seq=%a acknum=%a ack=%b rst=%b syn=%b fin=%b win=%d len=%d\"\n Sequence.pp header.sequence Sequence.pp header.ack_number\n header.ack header.rst header.syn header.fin\n header.window (Cstruct.length payload)\n\n let len seg =\n Sequence.of_int ((Cstruct.length seg.payload) +\n (if seg.header.fin then 1 else 0) +\n (if seg.header.syn then 1 else 0))\n\n (* Set of segments, ordered by sequence number *)\n module S = Set.Make(struct\n type t = segment\n let compare a b = (Sequence.compare a.header.sequence b.header.sequence)\n end)\n\n type t = {\n mutable segs: S.t;\n rx_data: (Cstruct.t list option * Sequence.t option) Lwt_mvar.t; (* User receive channel *)\n ack: ACK.t;\n tx_ack: (Sequence.t * int) Lwt_mvar.t; (* Acks of our transmitted segs *)\n wnd: Window.t;\n state: State.t;\n }\n\n let create ~rx_data ~ack ~wnd ~state ~tx_ack =\n let segs = S.empty in\n { segs; rx_data; ack; tx_ack; wnd; state }\n\n let pp fmt t =\n let pp_v fmt seg =\n Format.fprintf fmt \"%a[%a]\" Sequence.pp seg.header.sequence Sequence.pp (len seg)\n in\n Format.pp_print_list pp_v fmt (S.elements t.segs)\n\n (* If there is a FIN flag at the end of this segment set. TODO:\n should look for a FIN and chop off the rest of the set as they\n may be orphan segments *)\n let fin q =\n try (S.max_elt q).header.fin\n with Not_found -> false\n\n let is_empty q = S.is_empty q.segs\n\n let check_valid_segment q seg =\n if seg.header.rst then\n begin match State.state q.state with\n | State.Reset ->\n `Drop\n | _ ->\n if Sequence.compare seg.header.sequence (Window.rx_nxt q.wnd) = 0 then\n `Reset\n else if Window.valid q.wnd seg.header.sequence then\n `ChallengeAck\n else\n `Drop\n end\n else if seg.header.syn then\n `ChallengeAck\n else if Window.valid q.wnd seg.header.sequence then\n let min = Sequence.(sub (Window.tx_una q.wnd) (of_int32 (Window.max_tx_wnd q.wnd))) in\n if Sequence.between seg.header.ack_number min (Window.tx_nxt q.wnd) then\n `Ok\n else\n (* rfc5961 5.2 *)\n `ChallengeAck\n else\n `Drop\n\n let send_challenge_ack q =\n (* TODO: rfc5961 ACK Throttling *)\n ACK.pushack q.ack Sequence.zero\n\n (* Given an input segment, the window information, and a receive\n queue, update the window, extract any ready segments into the\n user receive queue, and signal any acks to the Tx queue *)\n let input (q:t) seg =\n match check_valid_segment q seg with\n | `Ok ->\n let force_ack = ref false in\n (* Insert the latest segment *)\n let segs = S.add seg q.segs in\n (* Walk through the set and get a list of contiguous segments *)\n let ready, waiting = S.fold (fun seg acc ->\n match Sequence.compare seg.header.sequence (Window.rx_nxt_inseq q.wnd) with\n | (-1) ->\n (* Sequence number is in the past, probably an overlapping\n segment. Drop it for now, but TODO segment\n coalescing *)\n force_ack := true;\n acc\n | 0 ->\n (* This is the next segment, so put it into the ready set\n and update the receive ack number *)\n let (ready,waiting) = acc in\n Window.rx_advance_inseq q.wnd (len seg);\n (S.add seg ready), waiting\n | 1 ->\n (* Sequence is in the future, so can't use it yet *)\n force_ack := true;\n let (ready,waiting) = acc in\n ready, (S.add seg waiting)\n | _ -> assert false\n ) segs (S.empty, S.empty) in\n q.segs <- waiting;\n (* If the segment has an ACK, tell the transmit side *)\n let tx_ack =\n if seg.header.ack && (Sequence.geq seg.header.ack_number (Window.ack_seq q.wnd)) then begin\n State.tick q.state (State.Recv_ack seg.header.ack_number);\n let data_in_flight = Window.tx_inflight q.wnd in\n let ack_has_advanced = (Window.ack_seq q.wnd) <> seg.header.ack_number in\n let win_has_changed = (Window.ack_win q.wnd) <> seg.header.window in\n if ((data_in_flight && (Window.ack_serviced q.wnd || not ack_has_advanced)) ||\n (not data_in_flight && win_has_changed)) then begin\n Window.set_ack_serviced q.wnd false;\n Window.set_ack_seq_win q.wnd seg.header.ack_number seg.header.window;\n Lwt_mvar.put q.tx_ack ((Window.ack_seq q.wnd), (Window.ack_win q.wnd))\n end else begin\n Window.set_ack_seq_win q.wnd seg.header.ack_number seg.header.window;\n Lwt.return_unit\n end\n end else Lwt.return_unit\n in\n (* Inform the user application of new data *)\n let urx_inform =\n (* TODO: deal with overlapping fragments *)\n let elems_r, winadv = S.fold (fun seg (acc_l, acc_w) ->\n (if Cstruct.length seg.payload > 0 then seg.payload :: acc_l else acc_l),\n (Sequence.add (len seg) acc_w)\n ) ready ([], Sequence.zero) in\n let elems = List.rev elems_r in\n let w = if !force_ack || Sequence.(gt winadv zero)\n then Some winadv else None in\n Lwt_mvar.put q.rx_data (Some elems, w) >>= fun () ->\n (* If the last ready segment has a FIN, then mark the receive\n window as closed and tell the application *)\n (if fin ready then begin\n if S.cardinal waiting != 0 then\n Log.info (fun f -> f \"application receive queue closed, but there are waiting segments.\");\n Lwt_mvar.put q.rx_data (None, Some Sequence.zero)\n end else Lwt.return_unit)\n in\n tx_ack <&> urx_inform\n | `ChallengeAck ->\n send_challenge_ack q\n | `Drop ->\n Lwt.return_unit\n | `Reset ->\n State.tick q.state State.Recv_rst;\n (* Abandon our current segments *)\n q.segs <- S.empty;\n (* Signal TX side *)\n let txalert ack_svcd =\n if not ack_svcd then Lwt.return_unit\n else Lwt_mvar.put q.tx_ack (Window.ack_seq q.wnd, Window.ack_win q.wnd)\n in\n txalert (Window.ack_serviced q.wnd) >>= fun () ->\n (* Use the fin path to inform the application of end of stream *)\n Lwt_mvar.put q.rx_data (None, Some Sequence.zero)\nend\n\n(* Transmitted segments are sent in-order, and may also be marked\n with control flags (such as urgent, or fin to mark the end).\n*)\n\ntype tx_flags = (* At most one of Syn/Fin/Rst/Psh allowed *)\n | No_flags\n | Syn\n | Fin\n | Rst\n | Psh\n\nmodule Tx = struct\n\n type ('a, 'b) xmit =\n flags:tx_flags -> wnd:Window.t -> options:Options.t list ->\n seq:Sequence.t -> Cstruct.t -> ('a, 'b) result Lwt.t\n\n type seg = {\n data: Cstruct.t;\n flags: tx_flags;\n seq: Sequence.t;\n }\n\n (* Sequence length of the segment *)\n let len seg =\n Sequence.of_int\n ((match seg.flags with\n | No_flags | Psh | Rst -> 0\n | Syn | Fin -> 1) +\n (Cstruct.length seg.data))\n\n (* Queue of pre-transmission segments *)\n type ('a, 'b) q = {\n segs: seg Lwt_dllist.t; (* Retransmitted segment queue *)\n xmit: ('a, 'b) xmit; (* Transmit packet to the wire *)\n rx_ack: Sequence.t Lwt_mvar.t; (* RX Ack thread that we've sent one *)\n wnd: Window.t; (* TCP Window information *)\n state: State.t; (* state of the TCP connection associated\n with this queue *)\n tx_wnd_update: int Lwt_mvar.t; (* Received updates to the transmit window *)\n rexmit_timer: Tcptimer.t; (* Retransmission timer for this connection *)\n mutable dup_acks: int; (* dup ack count for re-xmits *)\n }\n\n type t = T: ('a, 'b) q -> t\n\n let ack_segment _ _ = ()\n (* Take any action to the user transmit queue due to this being\n successfully ACKed *)\n\n (* URG_TODO: Add sequence number to the Syn_rcvd rexmit to only\n rexmit most recent *)\n let ontimer xmit st segs wnd seq =\n match State.state st with\n | State.Syn_rcvd _ | State.Established | State.Fin_wait_1 _\n | State.Close_wait | State.Closing _ | State.Last_ack _ ->\n begin match peek_opt_l segs with\n | None -> Lwt.return Tcptimer.Stoptimer\n | Some rexmit_seg ->\n match rexmit_seg.seq = seq with\n | false ->\n Log.debug (fun fmt ->\n fmt \"PUSHING TIMER - new time=%Lu, new seq=%a\"\n (Window.rto wnd) Sequence.pp rexmit_seg.seq);\n let ret =\n Tcptimer.ContinueSetPeriod (Window.rto wnd, rexmit_seg.seq)\n in\n Lwt.return ret\n | true ->\n if (Window.max_rexmits_done wnd) then (\n (* TODO - include more in log msg like ipaddrs *)\n Log.debug (fun f -> f \"Max retransmits reached: %a\" Window.pp wnd);\n Log.info (fun fmt -> fmt \"Max retransmits reached for connection - terminating\");\n State.tick st State.Timeout;\n Lwt.return Tcptimer.Stoptimer\n ) else (\n let flags = rexmit_seg.flags in\n let options = [] in (* TODO: put the right options *)\n Log.debug (fun fmt ->\n fmt \"TCP retransmission triggered by timer! seq = %d\"\n (Sequence.to_int rexmit_seg.seq));\n Lwt.async\n (fun () ->\n xmit ~flags ~wnd ~options ~seq rexmit_seg.data\n (* TODO should this return value really be ignored? *)\n >|= fun (_: ('a,'b) result) -> () );\n Window.alert_fast_rexmit wnd rexmit_seg.seq;\n Window.backoff_rto wnd;\n Log.debug (fun fmt -> fmt \"Backed off! %a\" Window.pp wnd);\n Log.debug (fun fmt ->\n fmt \"PUSHING TIMER - new time = %Lu, new seq = %a\"\n (Window.rto wnd) Sequence.pp rexmit_seg.seq);\n let ret =\n Tcptimer.ContinueSetPeriod (Window.rto wnd, rexmit_seg.seq)\n in\n Lwt.return ret\n )\n end\n | _ -> Lwt.return Tcptimer.Stoptimer\n\n let rec clearsegs q ack_remaining segs =\n match Sequence.(gt ack_remaining zero) with\n | false -> Sequence.zero (* here we return 0l instead of ack_remaining in case\n the ack was an old packet in the network *)\n | true ->\n match Lwt_dllist.take_opt_l segs with\n | None ->\n Log.debug (fun f -> f \"Dubious ACK received\");\n ack_remaining\n | Some s ->\n let seg_len = (len s) in\n match Sequence.lt ack_remaining seg_len with\n | true ->\n Log.debug (fun f -> f \"Partial ACK received\");\n (* return uncleared segment to the sequence *)\n lwt_sequence_add_l s segs;\n ack_remaining\n | false ->\n ack_segment q s;\n clearsegs q (Sequence.sub ack_remaining seg_len) segs\n\n let rto_t q tx_ack =\n (* Listen for incoming TX acks from the receive queue and ACK\n segments in our retransmission queue *)\n let rec tx_ack_t () =\n let serviceack dupack ack_len seq win =\n let partleft = clearsegs q ack_len q.segs in\n Window.tx_ack q.wnd (Sequence.sub seq partleft) win;\n match dupack || Window.fast_rec q.wnd with\n | true ->\n q.dup_acks <- q.dup_acks + 1;\n if q.dup_acks = 3 ||\n (Sequence.to_int32 ack_len > 0l) then begin\n (* alert window module to fall into fast recovery *)\n Window.alert_fast_rexmit q.wnd seq;\n (* retransmit the bottom of the unacked list of packets *)\n let rexmit_seg = peek_l q.segs in\n Log.debug (fun fmt ->\n fmt \"TCP fast retransmission seq=%a, dupack=%a\"\n Sequence.pp rexmit_seg.seq Sequence.pp seq);\n let { wnd; _ } = q in\n let flags=rexmit_seg.flags in\n let options=[] in (* TODO: put the right options *)\n Lwt.async (fun () ->\n q.xmit ~flags ~wnd ~options ~seq rexmit_seg.data\n (* TODO should this return value really be ignored? *)\n >|= fun (_: ('a,'b) result) -> () );\n Lwt.return_unit\n end else\n Lwt.return_unit\n | false ->\n q.dup_acks <- 0;\n Lwt.return_unit\n in\n Lwt_mvar.take tx_ack >>= fun _ ->\n Window.set_ack_serviced q.wnd true;\n let seq = Window.ack_seq q.wnd in\n let win = Window.ack_win q.wnd in\n begin match State.state q.state with\n | State.Reset ->\n (* Note: This is not strictly necessary, as the PCB will be\n GCed later on. However, it helps removing pressure on\n the GC. *)\n reset_seq q.segs;\n Lwt.return_unit\n | _ ->\n let ack_len = Sequence.sub seq (Window.tx_una q.wnd) in\n let dupacktest () =\n 0l = Sequence.to_int32 ack_len &&\n Window.tx_wnd_unscaled q.wnd = Int32.of_int win &&\n not (Lwt_dllist.is_empty q.segs)\n in\n serviceack (dupacktest ()) ack_len seq win\n end >>= fun () ->\n (* Inform the window thread of updates to the transmit window *)\n Lwt_mvar.put q.tx_wnd_update win >>= fun () ->\n tx_ack_t ()\n in\n tx_ack_t ()\n\n let create ~xmit ~wnd ~state ~rx_ack ~tx_ack ~tx_wnd_update =\n let segs = Lwt_dllist.create () in\n let dup_acks = 0 in\n let expire = ontimer xmit state segs wnd in\n let period_ns = Window.rto wnd in\n let rexmit_timer = Tcptimer.t ~period_ns ~expire in\n let q =\n { xmit; wnd; state; rx_ack; segs; tx_wnd_update;\n rexmit_timer; dup_acks }\n in\n let t = rto_t q tx_ack in\n T q, t\n\n (* Queue a segment for transmission. May block if:\n - There is no transmit window available.\n - The wire transmit function blocks.\n The transmitter should check that the segment size will\n will not be greater than the transmit window.\n *)\n let output ?(flags=No_flags) ?(options=[]) (T q) data =\n (* Transmit the packet to the wire\n TODO: deal with transmission soft/hard errors here RFC5461 *)\n let { wnd; _ } = q in\n let ack = Window.rx_nxt wnd in\n let seq = Window.tx_nxt wnd in\n let seg = { data; flags; seq } in\n let seq_len = len seg in\n Window.tx_advance q.wnd seq_len;\n (* Queue up segment just sent for retransmission if needed *)\n let q_rexmit () =\n match Sequence.(gt seq_len zero) with\n | false -> Lwt.return_unit\n | true ->\n lwt_sequence_add_r seg q.segs;\n let p = Window.rto q.wnd in\n Tcptimer.start q.rexmit_timer ~p seg.seq\n in\n q_rexmit () >>= fun () ->\n q.xmit ~flags ~wnd ~options ~seq data >>= fun _ ->\n (* Inform the RX ack thread that we've just sent one *)\n Lwt_mvar.put q.rx_ack ack\nend\n" }, { "path": "src/tcp/segment.mli", "content": "(*\n * Copyright (c) 2010 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\n(** TCP segments *)\n\n(** The receive queue stores out-of-order segments, and can coalesece\n them on input and pass on an ordered list up the stack to the\n application.\n\n It also looks for control messages and dispatches them to\n the Rtx queue to ack messages or close channels.\n*)\n\nmodule Rx (ACK:Ack.M) : sig\n\n type segment = { header: Tcp_packet.t; payload: Cstruct.t }\n (** Individual received TCP segment *)\n\n val pp_segment: Format.formatter -> segment -> unit\n\n type t\n (** Queue of receive segments *)\n\n val pp: Format.formatter -> t -> unit\n\n val create:\n rx_data:(Cstruct.t list option * Sequence.t option) Lwt_mvar.t ->\n ack:ACK.t ->\n wnd:Window.t ->\n state:State.t ->\n tx_ack:(Sequence.t * int) Lwt_mvar.t ->\n t\n\n val is_empty : t -> bool\n\n val input : t -> segment -> unit Lwt.t\n (** Given the current receive queue and an incoming packet,\n update the window, extract any ready segments into the\n user receive queue, and signal any acks to the Tx queue *)\n\nend\n\ntype tx_flags = No_flags | Syn | Fin | Rst | Psh\n(** Either Syn/Fin/Rst allowed, but not combinations *)\n\n(** Pre-transmission queue *)\nmodule Tx : sig\n\n type ('a, 'b) xmit = flags:tx_flags -> wnd:Window.t -> options:Options.t list ->\n seq:Sequence.t -> Cstruct.t -> ('a, 'b) result Lwt.t\n\n type t\n (** Queue of pre-transmission segments *)\n\n val create:\n xmit:('a, 'b) xmit -> wnd:Window.t -> state:State.t ->\n rx_ack:Sequence.t Lwt_mvar.t ->\n tx_ack:(Sequence.t * int) Lwt_mvar.t ->\n tx_wnd_update:int Lwt_mvar.t -> t * unit Lwt.t\n\n val output:\n ?flags:tx_flags -> ?options:Options.t list -> t -> Cstruct.t -> unit Lwt.t\n (** Queue a segment for transmission. May block if:\n\n {ul\n {- There is no transmit window available.}\n {- The wire transmit function blocks.}}\n\n The transmitter should check that the segment size will not\n be greater than the transmit window. *)\n\nend\n" }, { "path": "src/tcp/sequence.ml", "content": "(*\n * Copyright (c) 2010 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\n(* TCP sequence numbers must work with overflow, so this puts them in a\n separate type to make sure they dont get mixed up *)\n\ntype t = int32\n\n(* a < b *)\nlet lt a b = (Int32.sub a b) < 0l\n\n(* a <= b *)\nlet leq a b = (Int32.sub a b) <= 0l\n\n(* a > b *)\nlet gt a b = (Int32.sub a b) > 0l\n\n(* a >= b *)\nlet geq a b = (Int32.sub a b) >= 0l\n\n(* b <= a <= c *)\nlet between a b c = (geq a b) && (leq a c)\n\n(* a + b *)\nlet add a b = Int32.add a b\n\n(* a - b *)\nlet sub a b = Int32.sub a b\n\n(* a + 1 *)\nlet succ a = Int32.succ a\n\n(* a - 1 *)\nlet pred a = Int32.pred a\n\nlet compare a b = Int32.compare a b\nlet of_int32 t = t\nlet of_int t = Int32.of_int t\nlet to_int32 t = t\nlet to_int t = Int32.to_int t\n\nlet zero = Int32.zero\n\nlet pp fmt t = Format.fprintf fmt \"%lu\" t\n" }, { "path": "src/tcp/sequence.mli", "content": "(*\n * Copyright (c) 2010 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\ntype t\n\n(* a < b *)\nval lt : t -> t -> bool\n\n(* a <= b *)\nval leq : t -> t -> bool\n\n(* a > b *)\nval gt : t -> t -> bool\n\n(* a >= b *)\nval geq : t -> t -> bool\n\n(* b <= a <= c *)\nval between : t -> t -> t -> bool\n\n(* a + b *)\nval add: t -> t -> t\n\n(* a - b *)\nval sub: t -> t -> t\n\n(* a + 1 *)\nval succ: t -> t\n\n(* a - 1 *)\nval pred: t -> t\n\nval compare: t -> t -> int\nval of_int32: int32 -> t\nval of_int: int -> t\nval to_int32: t -> int32\nval to_int: t -> int\n\n(* the value produced by of_int 0 *)\nval zero : t\n\nval pp: Format.formatter -> t -> unit\n" }, { "path": "src/tcp/state.ml", "content": "(*\n * Copyright (c) 2012 Balraj Singh \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Lwt.Infix\n\nlet src = Logs.Src.create \"tcp.state\" ~doc:\"Mirage TCP State module\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\ntype action =\n | Passive_open\n | Recv_rst\n | Recv_synack of Sequence.t\n | Recv_ack of Sequence.t\n | Recv_fin\n (* | Recv_finack of Sequence.t *)\n | Send_syn of Sequence.t\n | Send_synack of Sequence.t\n | Send_rst\n | Send_fin of Sequence.t\n | Timeout\n\ntype tcpstate =\n | Closed\n | Listen\n | Syn_rcvd of Sequence.t\n | Syn_sent of Sequence.t\n | Established\n | Close_wait\n | Last_ack of Sequence.t\n | Fin_wait_1 of Sequence.t\n | Fin_wait_2 of int\n | Closing of Sequence.t\n | Time_wait\n | Reset\n\ntype close_cb = unit -> unit\n\ntype t = {\n on_close: close_cb;\n id: int;\n mutable state: tcpstate;\n}\n\nlet t ~id ~on_close =\n { on_close; id; state=Closed }\n\nlet on_close t = t.on_close ()\n\nlet state t = t.state\n\nlet pf = Format.fprintf\n\nlet pp_action fmt = function\n | Passive_open -> pf fmt \"Passive_open\"\n | Recv_rst -> pf fmt \"Recv_rst\"\n | Recv_synack x -> pf fmt \"Recv_synack(%a)\" Sequence.pp x\n | Recv_ack x -> pf fmt \"Recv_ack(%a)\" Sequence.pp x\n | Recv_fin -> pf fmt \"Recv_fin\"\n (* | Recv_finack x -> pf fmt \"Recv_finack(%a)\" Sequence.pp x *)\n | Send_syn x -> pf fmt \"Send_syn(%a)\" Sequence.pp x\n | Send_synack x -> pf fmt \"Send_synack(%a)\" Sequence.pp x\n | Send_rst -> pf fmt \"Send_rst\"\n | Send_fin x -> pf fmt \"Send_fin(%a)\" Sequence.pp x\n | Timeout -> pf fmt \"Timeout\"\n\nlet pp_tcpstate fmt = function\n | Closed -> pf fmt \"Closed\"\n | Listen -> pf fmt \"Listen\"\n | Syn_rcvd x -> pf fmt \"Syn_rcvd(%a)\" Sequence.pp x\n | Syn_sent x -> pf fmt \"Syn_sent(%a)\" Sequence.pp x\n | Established -> pf fmt \"Established\"\n | Close_wait -> pf fmt \"Close_wait\"\n | Last_ack x -> pf fmt \"Last_ack(%a)\" Sequence.pp x\n | Fin_wait_1 x -> pf fmt \"Fin_wait_1(%a)\" Sequence.pp x\n | Fin_wait_2 i -> pf fmt \"Fin_wait_2(%d)\" i\n | Closing x -> pf fmt \"Closing(%a)\" Sequence.pp x\n | Time_wait -> pf fmt \"Time_wait\"\n | Reset -> pf fmt \"Reset\"\n\nlet pp fmt t = pf fmt \"{ %a }\" pp_tcpstate t.state\n\nlet fin_wait_2_time = (* 60 *) Duration.of_sec 10\nlet time_wait_time = (* 30 *) Duration.of_sec 2\n\nlet rec finwait2timer t count timeout =\n Log.debug (fun fmt -> fmt \"finwait2timer %Lu\" timeout);\n Mirage_sleep.ns timeout >>= fun () ->\n match t.state with\n | Fin_wait_2 i ->\n Log.debug (fun f -> f \"finwait2timer: Fin_wait_2\");\n if i = count then begin\n t.state <- Closed;\n t.on_close ();\n Lwt.return_unit\n end else begin\n finwait2timer t i timeout\n end\n | s ->\n Log.debug (fun fmt -> fmt \"finwait2timer: %a\" pp_tcpstate s);\n Lwt.return_unit\n\nlet timewait t twomsl =\n Log.debug (fun fmt -> fmt \"timewait %Lu\" twomsl);\n Mirage_sleep.ns twomsl >>= fun () ->\n t.state <- Closed;\n Log.debug (fun fmt -> fmt \"timewait on_close\");\n t.on_close ();\n Lwt.return_unit\n\nlet transition_to_timewait t =\n Lwt.async (fun () -> timewait t time_wait_time);\n Time_wait\n\nlet tick t (i:action) =\n let diffone x y = Sequence.succ y = x in\n let tstr s (i:action) =\n match s, i with\n | Closed, Passive_open -> Listen\n | Closed, Send_syn a -> Syn_sent a\n | Listen, Send_synack a -> Syn_rcvd a\n | Syn_rcvd _, Timeout -> t.on_close (); Closed\n | Syn_rcvd _, Recv_rst -> Closed\n | Syn_sent _, Timeout -> t.on_close (); Closed\n | Syn_sent a, Recv_synack b-> if diffone b a then Established else Syn_sent a\n | Syn_rcvd a, Recv_ack b -> if diffone b a then Established else Syn_rcvd a\n | Established, Recv_ack _ -> Established\n | Established, Send_fin a -> Fin_wait_1 a\n | Established, Recv_fin -> Close_wait\n | Established, Timeout -> t.on_close (); Closed\n | Established, Recv_rst -> t.on_close (); Reset\n | Fin_wait_1 a, Recv_ack b ->\n if diffone b a then\n let count = 0 in\n Lwt.async (fun () -> finwait2timer t count fin_wait_2_time);\n Fin_wait_2 count\n else\n Fin_wait_1 a\n | Fin_wait_1 a, Recv_fin -> Closing a\n | Fin_wait_1 _, Timeout -> t.on_close (); Closed\n | Fin_wait_1 _, Recv_rst -> t.on_close (); Reset\n | Fin_wait_2 i, Recv_ack _ -> Fin_wait_2 (i + 1)\n | Fin_wait_2 _, Recv_rst -> t.on_close (); Reset\n | Fin_wait_2 _, Recv_fin -> transition_to_timewait t\n | Closing a, Recv_ack b ->\n if diffone b a then\n transition_to_timewait t\n else Closing a\n | Closing _, Timeout -> t.on_close (); Closed\n | Closing _, Recv_rst -> t.on_close (); Reset\n | Time_wait, Timeout -> t.on_close (); Closed\n | Close_wait, Send_fin a -> Last_ack a\n | Close_wait, Timeout -> t.on_close (); Closed\n | Close_wait, Recv_rst -> t.on_close (); Reset\n | Last_ack a, Recv_ack b -> if diffone b a then (t.on_close (); Closed) else Last_ack a\n | Last_ack _, Timeout -> t.on_close (); Closed\n | Last_ack _, Recv_rst -> t.on_close (); Reset\n | x, _ -> x\n in\n let old_state = t.state in\n let new_state = tstr t.state i in\n Log.debug (fun fmt -> fmt \"%d %a - %a -> %a\" t.id\n pp_tcpstate old_state pp_action i pp_tcpstate new_state);\n t.state <- new_state;\n" }, { "path": "src/tcp/state.mli", "content": "(*\n * Copyright (c) 2012 Balraj Singh \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\ntype action =\n | Passive_open\n | Recv_rst\n | Recv_synack of Sequence.t\n | Recv_ack of Sequence.t\n | Recv_fin\n (* | Recv_finack of Sequence.t *)\n | Send_syn of Sequence.t\n | Send_synack of Sequence.t\n | Send_rst\n | Send_fin of Sequence.t\n | Timeout\n\nval pp_action: Format.formatter -> action -> unit\n\ntype tcpstate =\n | Closed\n | Listen\n | Syn_rcvd of Sequence.t\n | Syn_sent of Sequence.t\n | Established\n | Close_wait\n | Last_ack of Sequence.t\n | Fin_wait_1 of Sequence.t\n | Fin_wait_2 of int\n | Closing of Sequence.t\n | Time_wait\n | Reset\n\nval pp_tcpstate : Format.formatter -> tcpstate -> unit\n\ntype close_cb = unit -> unit\n\ntype t\n\nval state : t -> tcpstate\nval t : id:int -> on_close:close_cb -> t\n\nval on_close : t -> unit\n\nval pp: Format.formatter -> t -> unit\n\nval fin_wait_2_time : int64\nval time_wait_time : int64\nval finwait2timer : t -> int -> int64 -> unit Lwt.t\nval timewait : t -> int64 -> unit Lwt.t\nval tick : t -> action -> unit\n" }, { "path": "src/tcp/stats.ml", "content": "(*\n * Copyright (c) 2015 Thomas Gazagnaire \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nmodule Gc = struct\n\n let gc = ref false\n let enable () = gc := true\n let disable () = gc := false\n\n let full = ref false\n let full_major b = full := b\n\n let words () =\n let t = Gc.stat () in\n t.Gc.live_words / 1_000\n\n let run_full_major () = if !full then Gc.full_major ()\n\n let pp fmt () =\n match !gc with\n | false -> ()\n | true ->\n run_full_major ();\n Format.fprintf fmt \"|%dk\" (words ())\n\nend\n\ntype t = {\n mutable tcp_listens : int;\n mutable tcp_channels: int;\n mutable tcp_connects: int;\n mutable tcp_timers : int;\n mutable total_established : int;\n mutable total_passive_connections : int;\n mutable total_active_connections : int;\n mutable total_timers : int;\n}\n\nlet metrics =\n let open Metrics in\n let doc = \"TCP metrics\" in\n let data t =\n Data.v\n [ int \"syn-rcvd state\" t.tcp_listens\n ; int \"established state\" t.tcp_channels\n ; int \"client connections\" t.tcp_connects\n ; int \"timers\" t.tcp_timers\n ; int \"total timers\" t.total_timers\n ; int \"total established\" t.total_established\n ; int \"total syn-rcvd\" t.total_passive_connections\n ; int \"total client\" t.total_active_connections ]\n in\n Src.v ~doc ~tags:Metrics.Tags.[] ~data \"tcp\"\n\nlet pp fmt t = Format.fprintf fmt \"[%d|%d|%d|%d%a]\"\n t.tcp_timers\n t.tcp_listens\n t.tcp_channels\n t.tcp_connects\n Gc.pp ()\n\nlet singleton =\n {\n tcp_listens = 0;\n tcp_channels = 0;\n tcp_connects = 0;\n tcp_timers = 0;\n total_timers = 0;\n total_established = 0;\n total_passive_connections = 0;\n total_active_connections = 0;\n }\n\nlet metrics () =\n Metrics.add metrics (fun x -> x) (fun d -> d singleton)\n\nlet incr_listen () =\n singleton.tcp_listens <- succ singleton.tcp_listens;\n singleton.total_passive_connections <- succ singleton.total_passive_connections;\n metrics ()\nlet decr_listen () =\n singleton.tcp_listens <- pred singleton.tcp_listens;\n metrics ()\n\nlet incr_channel () =\n singleton.tcp_channels <- succ singleton.tcp_channels;\n singleton.total_established <- succ singleton.total_established;\n metrics ()\nlet decr_channel () =\n singleton.tcp_channels <- pred singleton.tcp_channels;\n metrics ()\n\nlet incr_connect () =\n singleton.tcp_connects <- succ singleton.tcp_connects;\n singleton.total_active_connections <- succ singleton.total_active_connections;\n metrics ()\nlet decr_connect () =\n singleton.tcp_connects <- pred singleton.tcp_connects;\n metrics ()\n\nlet incr_timer () =\n singleton.tcp_timers <- succ singleton.tcp_timers;\n singleton.total_timers <- succ singleton.total_timers;\n metrics ()\nlet decr_timer () =\n singleton.tcp_timers <- pred singleton.tcp_timers;\n metrics ()\n\n" }, { "path": "src/tcp/stats.mli", "content": "(*\n * Copyright (c) 2015 Thomas Gazagnaire \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\n(** TCP Statistics *)\n\ntype t = {\n mutable tcp_listens : int;\n mutable tcp_channels: int;\n mutable tcp_connects: int;\n mutable tcp_timers : int;\n mutable total_established : int;\n mutable total_passive_connections : int;\n mutable total_active_connections : int;\n mutable total_timers : int;\n}\n\nval pp: Format.formatter -> t -> unit\n\nval incr_listen: unit -> unit\nval decr_listen: unit -> unit\n\nval incr_channel: unit -> unit\nval decr_channel: unit -> unit\n\nval incr_connect: unit -> unit\nval decr_connect: unit -> unit\n\nval incr_timer: unit -> unit\nval decr_timer: unit -> unit\n\nval singleton: t\n\nmodule Gc: sig\n (** Show GC stats *)\n\n val enable: unit -> unit\n (** Show live works (in k) on every debug line. *)\n\n val disable: unit -> unit\n\n val full_major: bool -> unit\n (** [full_major true] runs a [Gc.full_major] before printing any\n debug statement. Quite expensive but can sometimes be useful. By\n default, it is set to [false].\n\n {b Note:} This is very slow, use it if you really need it!\n\n *)\n\nend\n" }, { "path": "src/tcp/tcp_packet.ml", "content": "type t = {\n urg : bool;\n ack : bool;\n psh : bool;\n rst : bool;\n syn : bool;\n fin : bool;\n window : Cstruct.uint16;\n options : Options.t list;\n sequence : Sequence.t;\n ack_number : Sequence.t;\n src_port : Cstruct.uint16;\n dst_port : Cstruct.uint16;\n}\n\nlet equal {urg; ack; psh; rst; syn; fin; window; options; sequence; ack_number;\n src_port; dst_port} q =\n src_port = q.src_port &&\n dst_port = q.dst_port &&\n window = q.window &&\n urg = q.urg && ack = q.ack && psh = q.psh && rst = q.rst && syn = q.syn && fin = q.fin &&\n Sequence.compare sequence q.sequence = 0 &&\n Sequence.compare ack_number q.ack_number = 0 &&\n List.for_all2 Options.equal options q.options\n\nlet pp fmt t =\n Format.fprintf fmt\n \"TCP packet seq=%a acknum=%a ack=%b rst=%b syn=%b fin=%b win=%d options=%a\"\n Sequence.pp t.sequence Sequence.pp t.ack_number\n t.ack t.rst t.syn t.fin t.window Options.pps t.options\n\nlet ( let* ) = Result.bind\n\nmodule Unmarshal = struct\n type error = string\n\n let of_cstruct pkt =\n let open Tcp_wire in\n let check_len pkt =\n if Cstruct.length pkt < sizeof_tcp then\n Error \"packet too short to contain a TCP packet of any size\"\n else\n Ok (get_data_offset pkt)\n in\n let long_enough data_offset = if Cstruct.length pkt < data_offset then\n Error \"packet too short to contain a TCP packet of the size claimed\"\n else\n Ok ()\n in\n let options data_offset pkt =\n if data_offset > 20 then\n Options.unmarshal (Cstruct.sub pkt sizeof_tcp (data_offset - sizeof_tcp))\n else if data_offset < 20 then\n Error \"data offset was unreasonably short; TCP header can't be valid\"\n else (Ok [])\n in\n let* data_offset = check_len pkt in\n let* () = long_enough data_offset in\n let* options = options data_offset pkt in\n let sequence = get_sequence pkt |> Sequence.of_int32 in\n let ack_number = get_ack_number pkt |> Sequence.of_int32 in\n let urg = get_urg pkt in\n let ack = get_ack pkt in\n let psh = get_psh pkt in\n let rst = get_rst pkt in\n let syn = get_syn pkt in\n let fin = get_fin pkt in\n let window = get_window pkt in\n let src_port = get_src_port pkt in\n let dst_port = get_dst_port pkt in\n let data = Cstruct.shift pkt data_offset in\n Ok ({ urg; ack; psh; rst; syn; fin; window; options;\n sequence; ack_number; src_port; dst_port }, data)\nend\nmodule Marshal = struct\n open Tcp_wire\n\n type error = string\n\n let unsafe_fill ~pseudoheader ~payload t buf options_len =\n let data_off = sizeof_tcp + options_len in\n let buf = Cstruct.sub buf 0 data_off in\n set_src_port buf t.src_port;\n set_dst_port buf t.dst_port;\n set_sequence buf (Sequence.to_int32 t.sequence);\n set_ack_number buf (Sequence.to_int32 t.ack_number);\n set_data_offset buf (data_off / 4);\n set_flags buf 0;\n if t.urg then set_urg buf;\n if t.ack then set_ack buf;\n if t.rst then set_rst buf;\n if t.syn then set_syn buf;\n if t.fin then set_fin buf;\n if t.psh then set_psh buf;\n set_window buf t.window;\n set_checksum buf 0;\n set_urg_ptr buf 0;\n (* it's possible we've been passed a buffer larger than the size of the header,\n * which contains some data after the end of the header we'll write;\n * in this case, make sure we compute the checksum properly *)\n let checksum = Tcpip_checksum.ones_complement_list [pseudoheader ; buf ;\n payload] in\n set_checksum buf checksum;\n ()\n\n let into_cstruct ~pseudoheader ~payload t buf =\n let check_header_len () =\n if (Cstruct.length buf) < sizeof_tcp then Error \"Not enough space for a TCP header\"\n else Ok ()\n in\n let check_overall_len header_length =\n if (Cstruct.length buf) < header_length then\n Error (Printf.sprintf \"Not enough space for TCP header: %d < %d\"\n (Cstruct.length buf) header_length)\n else Ok ()\n in\n let insert_options options_frame =\n match t.options with\n |[] -> Ok 0\n |options ->\n try\n Ok (Options.marshal options_frame options)\n with\n (* handle the case where we ran out of room in the buffer while attempting\n to write the options *)\n | Invalid_argument s -> Error s\n in\n let options_frame = Cstruct.shift buf sizeof_tcp in\n let* () = check_header_len () in\n let* options_len = insert_options options_frame in\n let* () = check_overall_len (sizeof_tcp + options_len) in\n let buf = Cstruct.sub buf 0 (sizeof_tcp + options_len) in\n unsafe_fill ~pseudoheader ~payload t buf options_len;\n Ok (sizeof_tcp + options_len)\n\n let make_cstruct ~pseudoheader ~payload t =\n let buf = Cstruct.create (sizeof_tcp + 40) in (* more than 40 bytes of options can't\n be signalled in the length field of\n the tcp header *)\n let options_buf = Cstruct.shift buf sizeof_tcp in\n let options_len = Options.marshal options_buf t.options in\n let buf = Cstruct.sub buf 0 (sizeof_tcp + options_len) in\n unsafe_fill ~pseudoheader ~payload t buf options_len;\n buf\nend\n" }, { "path": "src/tcp/tcp_packet.mli", "content": "type t = {\n urg : bool;\n ack : bool;\n psh : bool;\n rst : bool;\n syn : bool;\n fin : bool;\n window : Cstruct.uint16;\n options : Options.t list;\n sequence : Sequence.t;\n ack_number : Sequence.t;\n src_port : Cstruct.uint16;\n dst_port : Cstruct.uint16;\n}\n\nval pp : Format.formatter -> t -> unit\nval equal : t -> t -> bool\n\nmodule Unmarshal : sig\n type error = string\n\n val of_cstruct : Cstruct.t -> (t * Cstruct.t, error) result\nend\n\nmodule Marshal : sig\n type error = string\n\n (** [into_cstruct ~pseudoheader ~payload t buf] attempts to write a valid TCP\n header representing [t] into [buf] at offset 0. [pseudoheader] and\n [payload] are required to calculate a correct checksum but are not\n otherwise reflected in the data written into [buf] -- [buf] will contain\n only a TCP header after a call to [into_cstruct].\n Returns either the number of bytes written into the buffer on success; if\n the buffer supplied is too small to write the entire header, an error is\n returned. *)\n val into_cstruct :\n pseudoheader:Cstruct.t ->\n payload:Cstruct.t ->\n t -> Cstruct.t ->\n (int, error) result\n\n (** [make_cstruct ~pseudoheader ~payload t] allocates, fills, and and returns a buffer\n representing the TCP header corresponding to [t]. If [t.options] is\n non-empty, [t.options] will be concatenated onto the result as part of the\n header.\n A variable amount of memory (at least 20 bytes, and at most 60) will be allocated, but\n [] is not represented in the output. The checksum will be properly\n set to reflect the pseudoheader, header, options, and payload. *)\n val make_cstruct : pseudoheader:Cstruct.t -> payload:Cstruct.t -> t -> Cstruct.t\nend\n" }, { "path": "src/tcp/tcp_wire.ml", "content": "let sizeof_tcp = 20\n\nlet src_port_off = 0\nlet dst_port_off = 2\nlet sequence_off = 4\nlet ack_off = 8\nlet dataoff_off = 12\nlet flags_off = 13\nlet window_off = 14\nlet checksum_off = 16\nlet urg_ptr_off = 18\n\nlet get_src_port buf = Cstruct.BE.get_uint16 buf src_port_off\nlet set_src_port buf v = Cstruct.BE.set_uint16 buf src_port_off v\n\nlet get_dst_port buf = Cstruct.BE.get_uint16 buf dst_port_off\nlet set_dst_port buf v = Cstruct.BE.set_uint16 buf dst_port_off v\n\nlet get_sequence buf = Cstruct.BE.get_uint32 buf sequence_off\nlet set_sequence buf v = Cstruct.BE.set_uint32 buf sequence_off v\n\nlet get_ack_number buf = Cstruct.BE.get_uint32 buf ack_off\nlet set_ack_number buf v = Cstruct.BE.set_uint32 buf ack_off v\n\nlet get_flags buf = Cstruct.get_uint8 buf flags_off\nlet set_flags buf v = Cstruct.set_uint8 buf flags_off v\n\nlet get_window buf = Cstruct.BE.get_uint16 buf window_off\nlet set_window buf v = Cstruct.BE.set_uint16 buf window_off v\n\nlet get_checksum buf = Cstruct.BE.get_uint16 buf checksum_off\nlet set_checksum buf value = Cstruct.BE.set_uint16 buf checksum_off value\n\nlet get_urg_ptr buf = Cstruct.BE.get_uint16 buf urg_ptr_off\nlet set_urg_ptr buf value = Cstruct.BE.set_uint16 buf urg_ptr_off value\n\n(* XXX note that we overwrite the lower half of dataoff\n * with 0, so be careful when implemented CWE flag which\n * sits there *)\nlet get_data_offset buf = ((Cstruct.get_uint8 buf dataoff_off) lsr 4) * 4\nlet set_data_offset buf v = Cstruct.set_uint8 buf dataoff_off (v lsl 4)\n\nlet get_fin buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 0)) > 0\nlet get_syn buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 1)) > 0\nlet get_rst buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 2)) > 0\nlet get_psh buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 3)) > 0\nlet get_ack buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 4)) > 0\nlet get_urg buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 5)) > 0\nlet _get_ece buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 6)) > 0\nlet _get_cwr buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 7)) > 0\n\nlet set_fin buf =\n Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 0))\nlet set_syn buf =\n Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 1))\nlet set_rst buf =\n Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 2))\nlet set_psh buf =\n Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 3))\nlet set_ack buf =\n Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 4))\nlet set_urg buf =\n Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 5))\nlet _set_ece buf =\n Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 6))\nlet _set_cwr buf =\n Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 7))\n" }, { "path": "src/tcp/tcp_wire.mli", "content": "val sizeof_tcp : int\n\nval get_src_port : Cstruct.t -> int\nval set_src_port : Cstruct.t -> int -> unit\n\nval get_dst_port : Cstruct.t -> int\nval set_dst_port : Cstruct.t -> int -> unit\n\nval get_sequence : Cstruct.t -> int32\nval set_sequence : Cstruct.t -> int32 -> unit\n\nval get_ack_number : Cstruct.t -> int32\nval set_ack_number : Cstruct.t -> int32 -> unit\n\nval get_flags : Cstruct.t -> int\nval set_flags : Cstruct.t -> int -> unit\n\nval get_window : Cstruct.t -> int\nval set_window : Cstruct.t -> int -> unit\n\nval get_checksum : Cstruct.t -> int\nval set_checksum : Cstruct.t -> int -> unit\n\nval get_urg_ptr : Cstruct.t -> int\nval set_urg_ptr : Cstruct.t -> int -> unit\n\nval get_data_offset : Cstruct.t -> int\nval set_data_offset : Cstruct.t -> int -> unit\n\nval get_fin : Cstruct.t -> bool\nval get_syn : Cstruct.t -> bool\nval get_rst : Cstruct.t -> bool\nval get_psh : Cstruct.t -> bool\nval get_ack : Cstruct.t -> bool\nval get_urg : Cstruct.t -> bool\n\nval set_fin : Cstruct.t -> unit\nval set_syn : Cstruct.t -> unit\nval set_rst : Cstruct.t -> unit\nval set_psh : Cstruct.t -> unit\nval set_ack : Cstruct.t -> unit\nval set_urg : Cstruct.t -> unit\n" }, { "path": "src/tcp/tcptimer.ml", "content": "(*\n * Copyright (c) 2012 Balraj Singh \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Lwt.Infix\n\nlet src = Logs.Src.create \"tcp.tcptimer\" ~doc:\"Mirage TCP Tcptimer module\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\ntype time = int64\n\ntype tr =\n | Stoptimer\n | Continue of Sequence.t\n | ContinueSetPeriod of (time * Sequence.t)\n\ntype t = {\n expire: (Sequence.t -> tr Lwt.t);\n mutable period_ns: time;\n mutable running: bool;\n}\n\nlet t ~period_ns ~expire =\n let running = false in\n {period_ns; expire; running}\n\nlet timerloop t s =\n Log.debug (fun f -> f \"timerloop\");\n Stats.incr_timer ();\n let rec aux t s =\n Log.debug (fun f -> f \"timerloop: sleeping for %Lu ns\" t.period_ns);\n Mirage_sleep.ns t.period_ns >>= fun () ->\n t.expire s >>= function\n | Stoptimer ->\n Stats.decr_timer ();\n t.running <- false;\n Log.debug (fun f -> f \"timerloop: stoptimer\");\n Lwt.return_unit\n | Continue d ->\n Log.debug (fun f -> f \"timerloop: continuer\");\n aux t d\n | ContinueSetPeriod (p, d) ->\n Log.debug (fun f -> f \"timerloop: continuesetperiod (new period: %Lu ns)\" p);\n t.period_ns <- p;\n aux t d\n in\n aux t s\n\nlet period_ns t = t.period_ns\n\nlet start t ?(p=(period_ns t)) s =\n if not t.running then begin\n t.period_ns <- p;\n t.running <- true;\n Lwt.async (fun () -> timerloop t s);\n Lwt.return_unit\n end else\n Lwt.return_unit\n" }, { "path": "src/tcp/tcptimer.mli", "content": "(*\n * Copyright (c) 2012 Balraj Singh \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\ntype t\n\ntype time = int64\n\ntype tr =\n | Stoptimer\n | Continue of Sequence.t\n | ContinueSetPeriod of (time * Sequence.t)\n\nval t : period_ns: time -> expire: (Sequence.t -> tr Lwt.t) -> t\n\nval start : t -> ?p:time -> Sequence.t -> unit Lwt.t\n" }, { "path": "src/tcp/user_buffer.ml", "content": "(*\n * Copyright (c) 2010 http://github.com/barko 00336ea19fcb53de187740c490f764f4\n * Copyright (c) 2011 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Lwt.Infix\n\nlet lwt_sequence_add_l s seq =\n let (_:'a Lwt_dllist.node) = Lwt_dllist.add_l s seq in\n ()\n\n(* A bounded queue to receive data segments and let readers block on\n receiving them. Also supports a monitor that is informed when the\n queue size changes *)\nmodule Rx = struct\n\n (* TODO: check that flow control works on the rx side - ie if the application\n stops taking data the window closes so the other side stops sending *)\n\n type t = {\n q: Cstruct.t option Lwt_dllist.t;\n wnd: Window.t;\n writers: unit Lwt.u Lwt_dllist.t;\n readers: Cstruct.t option Lwt.u Lwt_dllist.t;\n mutable watcher: int32 Lwt_mvar.t option;\n mutable max_size: int32;\n mutable cur_size: int32;\n }\n\n let create ~max_size ~wnd =\n let q = Lwt_dllist.create () in\n let writers = Lwt_dllist.create () in\n let readers = Lwt_dllist.create () in\n let watcher = None in\n let cur_size = 0l in\n { q; wnd; writers; readers; max_size; cur_size; watcher }\n\n let notify_size_watcher t =\n let rx_wnd = max 0l (Int32.sub t.max_size t.cur_size) in\n Window.set_rx_wnd t.wnd rx_wnd;\n match t.watcher with\n |None -> Lwt.return_unit\n |Some w -> Lwt_mvar.put w t.cur_size\n\n let seglen s =\n match s with\n | None -> 0\n | Some b -> Cstruct.length b\n\n let remove_all t =\n let rec rm = function\n | 0 -> ()\n | n -> ignore (Lwt_dllist.take_l t.q); rm (pred n)\n in\n rm (Lwt_dllist.length t.q)\n\n let add_r t s =\n if t.cur_size > t.max_size then\n let th,u = Lwt.wait () in\n let node = Lwt_dllist.add_r u t.writers in\n Lwt.on_cancel th (fun _ -> Lwt_dllist.remove node);\n (* Update size before blocking, which may push cur_size above max_size *)\n t.cur_size <- Int32.(add t.cur_size (of_int (seglen s)));\n notify_size_watcher t >>= fun () ->\n th >>= fun () ->\n ignore(Lwt_dllist.add_r s t.q);\n Lwt.return_unit\n else match Lwt_dllist.take_opt_l t.readers with\n | None ->\n t.cur_size <- Int32.(add t.cur_size (of_int (seglen s)));\n ignore(Lwt_dllist.add_r s t.q);\n notify_size_watcher t\n | Some u ->\n Lwt.return (Lwt.wakeup u s)\n\n let take_l t =\n if Lwt_dllist.is_empty t.q then begin\n let th,u = Lwt.wait () in\n let node = Lwt_dllist.add_r u t.readers in\n Lwt.on_cancel th (fun _ -> Lwt_dllist.remove node);\n th\n end else begin\n let s = Lwt_dllist.take_l t.q in\n t.cur_size <- Int32.(sub t.cur_size (of_int (seglen s)));\n notify_size_watcher t >>= fun () ->\n if t.cur_size < t.max_size then begin\n match Lwt_dllist.take_opt_l t.writers with\n |None -> ()\n |Some w -> Lwt.wakeup w ()\n end;\n Lwt.return s\n end\n\n let cur_size t = t.cur_size\n let max_size t = t.max_size\n\n let monitor t mvar =\n t.watcher <- Some mvar\n\nend\n\n(* The transmit queue simply advertises how much data is allowed to be\n written, and a wakener for when it is full. It is up to the application\n to decide how to throttle or breakup its data production with this\n information.\n*)\nmodule Tx = struct\n\n module TXS = Segment.Tx\n\n type t = {\n wnd: Window.t;\n writers: unit Lwt.u Lwt_dllist.t;\n txq: TXS.t;\n buffer: Cstruct.t Lwt_dllist.t;\n max_size: int32;\n mutable bufbytes: int32;\n }\n\n let create ~max_size ~wnd ~txq =\n let buffer = Lwt_dllist.create () in\n let writers = Lwt_dllist.create () in\n let bufbytes = 0l in\n { wnd; writers; txq; buffer; max_size; bufbytes }\n\n let len data =\n Int32.of_int (Cstruct.length data)\n\n let lenv datav =\n match datav with\n |[] -> 0l\n |[d] -> Int32.of_int (Cstruct.length d)\n |ds -> Int32.of_int (List.fold_left (fun a b -> Cstruct.length b + a) 0 ds)\n\n (* Check how many bytes are available to write to output buffer *)\n let available t =\n let a = Int32.sub t.max_size t.bufbytes in\n match a < (Int32.of_int (Window.tx_mss t.wnd)) with\n | true -> 0l\n | false -> a\n\n (* Check how many bytes are available to write to wire *)\n let available_cwnd t =\n Window.tx_available t.wnd\n\n (* Wait until at least sz bytes are available in the window *)\n let rec wait_for t sz =\n if (available t) >= sz then begin\n Lwt.return_unit\n end\n else begin\n let th,u = Lwt.wait () in\n let node = Lwt_dllist.add_r u t.writers in\n Lwt.on_cancel th (fun _ -> Lwt_dllist.remove node);\n th >>= fun () ->\n wait_for t sz\n end\n\n let compactbufs bl = Cstruct.concat bl\n\n (* Wait until the user buffer is flushed *)\n let rec wait_for_flushed t =\n if Lwt_dllist.is_empty t.buffer then begin\n Lwt.return_unit\n end\n else begin\n let th,u = Lwt.wait () in\n let node = Lwt_dllist.add_r u t.writers in\n Lwt.on_cancel th (fun _ -> Lwt_dllist.remove node);\n th >>= fun () ->\n wait_for_flushed t\n end\n\n let rec clear_buffer t =\n let rec addon_more curr_data l =\n match Lwt_dllist.take_opt_l t.buffer with\n | None -> List.rev curr_data\n | Some s ->\n let s_len = len s in\n match s_len > l with\n | true ->\n lwt_sequence_add_l s t.buffer;\n List.rev curr_data\n | false ->\n t.bufbytes <- Int32.sub t.bufbytes s_len;\n addon_more (s::curr_data) (Int32.sub l s_len)\n in\n let get_pkt_to_send () =\n let avail_len = min (available_cwnd t) (Int32.of_int (Window.tx_mss t.wnd)) in\n let s = Lwt_dllist.take_l t.buffer in\n let s_len = len s in\n match s_len > avail_len with\n | true -> begin\n match avail_len with\n |0l -> (* return pkt to buffer *)\n lwt_sequence_add_l s t.buffer;\n None\n |_ -> (* split buffer into a partial write *)\n let to_send,remaining = Cstruct.split s (Int32.to_int avail_len) in\n (* queue remaining view *)\n lwt_sequence_add_l remaining t.buffer;\n t.bufbytes <- Int32.sub t.bufbytes avail_len;\n Some [to_send]\n end\n | false ->\n match s_len < avail_len with\n | true ->\n t.bufbytes <- Int32.sub t.bufbytes s_len;\n Some (addon_more (s::[]) (Int32.sub avail_len s_len))\n | false ->\n t.bufbytes <- Int32.sub t.bufbytes s_len;\n Some [s]\n in\n match Lwt_dllist.is_empty t.buffer with\n | true -> Lwt.return_unit\n | false ->\n match get_pkt_to_send () with\n | None -> Lwt.return_unit\n | Some pkt ->\n let b = compactbufs pkt in\n TXS.output ~flags:Segment.Psh t.txq b >>= fun () ->\n clear_buffer t\n\n (* Chunk up the segments into MSS max for transmission *)\n let transmit_segments ~mss ~txq datav =\n let transmit acc =\n let b = compactbufs (List.rev acc) in\n TXS.output ~flags:Segment.Psh txq b\n in\n let rec chunk datav acc =\n match datav with\n |[] -> begin\n match acc with\n |[] -> Lwt.return_unit\n |_ -> transmit acc\n end\n |hd::tl ->\n let curlen = Cstruct.lenv acc in\n let tlen = Cstruct.length hd + curlen in\n if tlen > mss then begin\n let a,b = Cstruct.split hd (mss - curlen) in\n transmit (a::acc) >>= fun () ->\n chunk (b::tl) []\n end else\n chunk tl (hd::acc)\n in\n chunk datav []\n\n let write t datav =\n let l = lenv datav in\n let mss = Int32.of_int (Window.tx_mss t.wnd) in\n match Lwt_dllist.is_empty t.buffer &&\n (l = mss || not (Window.tx_inflight t.wnd)) with\n | false ->\n t.bufbytes <- Int32.add t.bufbytes l;\n List.iter (fun data -> ignore(Lwt_dllist.add_r data t.buffer)) datav;\n if t.bufbytes < mss then\n Lwt.return_unit\n else\n clear_buffer t\n | true ->\n let avail_len = available_cwnd t in\n match avail_len < l with\n | true ->\n t.bufbytes <- Int32.add t.bufbytes l;\n List.iter (fun data -> ignore(Lwt_dllist.add_r data t.buffer)) datav;\n Lwt.return_unit\n | false ->\n let max_size = Window.tx_mss t.wnd in\n transmit_segments ~mss:max_size ~txq:t.txq datav\n\n let write_nodelay t datav =\n let l = lenv datav in\n match Lwt_dllist.is_empty t.buffer with\n | false ->\n t.bufbytes <- Int32.add t.bufbytes l;\n List.iter (fun data -> ignore(Lwt_dllist.add_r data t.buffer)) datav;\n Lwt.return_unit\n | true ->\n let avail_len = available_cwnd t in\n match avail_len < l with\n | true ->\n t.bufbytes <- Int32.add t.bufbytes l;\n List.iter (fun data -> ignore(Lwt_dllist.add_r data t.buffer)) datav;\n Lwt.return_unit\n | false ->\n let max_size = Window.tx_mss t.wnd in\n transmit_segments ~mss:max_size ~txq:t.txq datav\n\n\n let inform_app t =\n match Lwt_dllist.take_opt_l t.writers with\n | None -> Lwt.return_unit\n | Some w ->\n Lwt.wakeup w ();\n (* TODO: check if this should wake all writers not just one *)\n Lwt.return_unit\n\n (* Indicate that more bytes are available for waiting writers.\n Note that sz does not take window scaling into account, and so\n should be passed as unscaled (i.e. from the wire) here.\n Window will internally scale it up. *)\n let free t _sz =\n clear_buffer t >>= fun () ->\n inform_app t\n\n let reset t =\n (* FIXME: duplicated code with Segment.reset_seq *)\n let rec reset_seq segs =\n match Lwt_dllist.take_opt_l segs with\n | None -> ()\n | Some _ -> reset_seq segs\n in\n reset_seq t.buffer;\n inform_app t\n\nend\n" }, { "path": "src/tcp/user_buffer.mli", "content": "(*\n * Copyright (c) 2010 http://github.com/barko 00336ea19fcb53de187740c490f764f4\n * Copyright (c) 2011 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nmodule Rx : sig\n type t\n\n val create : max_size:int32 -> wnd:Window.t -> t\n val remove_all : t -> unit\n val add_r : t -> Cstruct.t option -> unit Lwt.t\n val take_l : t -> Cstruct.t option Lwt.t\n val cur_size : t -> int32\n val max_size : t -> int32\n val monitor: t -> int32 Lwt_mvar.t -> unit\nend\n\nmodule Tx : sig\n\n type t\n\n module TXS : sig\n type t = Segment.Tx.t\n val output : ?flags:Segment.tx_flags -> ?options:Options.t list -> t ->\n Cstruct.t -> unit Lwt.t\n end\n\n val create: max_size:int32 -> wnd:Window.t -> txq:TXS.t -> t\n val available: t -> int32\n val wait_for: t -> int32 -> unit Lwt.t\n val wait_for_flushed: t -> unit Lwt.t\n val write: t -> Cstruct.t list -> unit Lwt.t\n val write_nodelay: t -> Cstruct.t list -> unit Lwt.t\n val free: t -> int -> unit Lwt.t\n val reset: t -> unit Lwt.t\nend\n" }, { "path": "src/tcp/window.ml", "content": "(*\n * Copyright (c) 2010 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nlet src = Logs.Src.create \"tcp.window\" ~doc:\"Mirage TCP Window module\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\ntype time = int64\n\ntype t = {\n tx_mss: int;\n tx_isn: Sequence.t;\n rx_isn: Sequence.t;\n max_rx_wnd: int32; (* Max RX Window size after scaling *)\n tx_wnd_scale: int; (* TX Window scaling option *)\n rx_wnd_scale: int; (* RX Window scaling option *)\n\n mutable ack_serviced: bool;\n mutable ack_seq: Sequence.t;\n mutable ack_win: int;\n\n mutable snd_una: Sequence.t;\n mutable tx_nxt: Sequence.t;\n mutable rx_nxt: Sequence.t;\n mutable rx_nxt_inseq: Sequence.t;\n mutable fast_rec_th: Sequence.t;\n mutable max_tx_wnd : int32; (* Max seen TX window after scaling *)\n mutable tx_wnd: int32; (* TX Window size after scaling *)\n mutable rx_wnd: int32; (* RX Window size after scaling *)\n mutable ssthresh: int32; (* threshold to switch from exponential\n slow start to linear congestion\n avoidance *)\n mutable cwnd: int32; (* congestion window *)\n mutable fast_recovery: bool; (* flag to mark if this tcp is in\n fast recovery *)\n\n mutable rtt_timer_on: bool;\n mutable rtt_timer_reset: bool;\n mutable rtt_timer_seq: Sequence.t;\n mutable rtt_timer_starttime: time;\n mutable srtt: time;\n mutable rttvar: time;\n mutable rto: int64;\n mutable backoff_count: int;\n}\n\n(* To string for debugging *)\nlet pp fmt t =\n Format.fprintf fmt\n \"Window: rx_nxt=%a rx_nxt_inseq=%a tx_nxt=%a rx_wnd=%lu tx_wnd=%lu snd_una=%a backoffs=%d rto=%Lu\"\n Sequence.pp t.rx_nxt\n Sequence.pp t.rx_nxt_inseq\n Sequence.pp t.tx_nxt\n t.rx_wnd t.tx_wnd\n Sequence.pp t.snd_una\n t.backoff_count t.rto\n\n(* Initialise the sequence space *)\nlet t ~rx_wnd_scale ~tx_wnd_scale ~rx_wnd ~tx_wnd ~rx_isn ~tx_mss ~tx_isn =\n let tx_nxt = tx_isn in\n let rx_nxt = Sequence.succ rx_isn in\n let rx_nxt_inseq = Sequence.succ rx_isn in\n let snd_una = tx_nxt in\n let fast_rec_th = tx_nxt in\n let ack_serviced = true in\n let ack_seq = tx_nxt in\n let ack_win = rx_wnd in\n let rx_wnd = Int32.(shift_left (of_int rx_wnd) rx_wnd_scale) in\n let max_rx_wnd = rx_wnd in\n let tx_wnd = Int32.(shift_left (of_int tx_wnd) tx_wnd_scale) in\n let max_tx_wnd = tx_wnd in\n (* ssthresh is initialized per RFC 2581 to a large value so slow-start\n can be used all the way till first loss *)\n let ssthresh = tx_wnd in\n let cwnd = Int32.of_int (tx_mss * 2) in\n let fast_recovery = false in\n let rtt_timer_on = false in\n let rtt_timer_reset = true in\n let rtt_timer_seq = tx_nxt in\n let rtt_timer_starttime = 0L in\n let srtt = (Duration.of_ms 667) in\n let rttvar = 0L in\n let rto = (Duration.of_ms 667) in\n let backoff_count = 0 in\n { tx_isn; rx_isn; max_rx_wnd; max_tx_wnd;\n ack_serviced; ack_seq; ack_win;\n snd_una; tx_nxt; tx_wnd; rx_nxt; rx_nxt_inseq;\n fast_rec_th; rx_wnd; tx_wnd_scale; rx_wnd_scale;\n ssthresh; cwnd; tx_mss; fast_recovery;\n rtt_timer_on; rtt_timer_reset;\n rtt_timer_seq; rtt_timer_starttime; srtt; rttvar; rto; backoff_count }\n\n(* Check if a sequence number is in the right range *)\nlet valid t seq =\n let redge = Sequence.(add t.rx_nxt (of_int32 t.rx_wnd)) in\n let ledge = Sequence.(sub t.rx_nxt (of_int32 t.max_rx_wnd)) in\n let r = Sequence.between seq ledge redge in\n Log.debug (fun f -> f \"sequence validation: seq=%a range=%a[%lu] res=%b\"\n Sequence.pp seq Sequence.pp t.rx_nxt t.rx_wnd r);\n r\n\n(* Advance received packet sequence number *)\nlet rx_advance t b =\n t.rx_nxt <- Sequence.add t.rx_nxt b\n\n(* Early advance received packet sequence number for packet ordering *)\nlet rx_advance_inseq t b =\n t.rx_nxt_inseq <- Sequence.add t.rx_nxt_inseq b\n\n(* Next expected receive sequence number *)\nlet rx_nxt t = t.rx_nxt\nlet rx_nxt_inseq t = t.rx_nxt_inseq\nlet rx_wnd t = t.rx_wnd\nlet rx_wnd_unscaled t = Int32.shift_right t.rx_wnd t.rx_wnd_scale\n\nlet ack_serviced t = t.ack_serviced\nlet ack_seq t = t.ack_seq\nlet ack_win t = t.ack_win\n\nlet set_ack_serviced t v = t.ack_serviced <- v\nlet set_ack_seq_win t s w =\n t.ack_seq <- s;\n t.ack_win <- w\n\n(* TODO: scale the window down so we can advertise it correctly with\n window scaling on the wire *)\nlet set_rx_wnd t sz =\n t.rx_wnd <- max sz (Int32.of_int (3 * t.tx_mss + 1 lsl t.rx_wnd_scale))\n\n(* Take an unscaled value and scale it up *)\nlet set_tx_wnd t sz =\n let wnd = Int32.(shift_left (of_int sz) t.tx_wnd_scale) in\n t.tx_wnd <- wnd;\n if wnd > t.max_tx_wnd then\n t.max_tx_wnd <- wnd\n\n(* transmit MSS of current connection *)\nlet tx_mss t =\n t.tx_mss\n\n(* Advance transmitted packet sequence number *)\nlet tx_advance t b =\n if not t.rtt_timer_on && not t.fast_recovery then begin\n t.rtt_timer_on <- true;\n t.rtt_timer_seq <- t.tx_nxt;\n t.rtt_timer_starttime <- Mirage_mtime.elapsed_ns ();\n end;\n t.tx_nxt <- Sequence.add t.tx_nxt b\n\n(* An ACK was received - use it to adjust cwnd *)\nlet tx_ack t r win =\n set_tx_wnd t win;\n if t.fast_recovery then begin\n if Sequence.gt r t.snd_una then\n t.snd_una <- r;\n if Sequence.geq r t.fast_rec_th then begin\n Log.debug (fun f -> f \"EXITING fast recovery\");\n t.cwnd <- t.ssthresh;\n t.fast_recovery <- false;\n end else begin\n t.cwnd <- (Int32.add t.cwnd (Int32.of_int t.tx_mss));\n end\n end else begin\n if Sequence.gt r t.snd_una then begin\n t.backoff_count <- 0;\n t.snd_una <- r;\n if t.rtt_timer_on && Sequence.gt r t.rtt_timer_seq then begin\n t.rtt_timer_on <- false;\n let rtt_m = Int64.sub (Mirage_mtime.elapsed_ns ()) t.rtt_timer_starttime in\n if t.rtt_timer_reset then begin\n t.rtt_timer_reset <- false;\n t.rttvar <- Int64.div rtt_m 2L;\n t.srtt <- rtt_m;\n end else begin\n let (/) = Int64.div\n and ( * ) = Int64.mul\n and (-) = Int64.sub\n and (+) = Int64.add\n in\n (* RFC2988 2.3 *)\n t.rttvar <- (3L * t.rttvar / 4L) + (Int64.abs (t.srtt - rtt_m) / 4L);\n t.srtt <- (7L * t.srtt / 8L) + (rtt_m / 8L)\n end;\n t.rto <- max (Duration.of_ms 667) Int64.(add t.srtt (mul t.rttvar 4L));\n end;\n end;\n let cwnd_incr = match t.cwnd < t.ssthresh with\n | true -> Int32.of_int t.tx_mss\n | false -> max (Int32.div (Int32.of_int (t.tx_mss * t.tx_mss)) t.cwnd) 1l\n in\n t.cwnd <- Int32.add t.cwnd cwnd_incr\n end\n\nlet tx_nxt t = t.tx_nxt\nlet tx_wnd t = t.tx_wnd\nlet tx_wnd_unscaled t = Int32.shift_right t.tx_wnd t.tx_wnd_scale\nlet max_tx_wnd t = t.max_tx_wnd\nlet tx_una t = t.snd_una\nlet fast_rec t = t.fast_recovery\nlet tx_available t =\n let inflight = Sequence.to_int32 (Sequence.sub t.tx_nxt t.snd_una) in\n let win = min t.cwnd t.tx_wnd in\n let avail_win = Int32.sub win inflight in\n match avail_win < Int32.of_int t.tx_mss with\n | true -> 0l\n | false -> avail_win\n\nlet tx_inflight t =\n t.tx_nxt <> t.snd_una\n\n\nlet alert_fast_rexmit t _ =\n if not t.fast_recovery then begin\n let inflight = Sequence.to_int32 (Sequence.sub t.tx_nxt t.snd_una) in\n let newssthresh = max (Int32.div inflight 2l) (Int32.of_int (t.tx_mss * 2)) in\n let newcwnd = Int32.add inflight (Int32.of_int (t.tx_mss * 2)) in\n Log.debug (fun fmt ->\n fmt \"ENTERING fast recovery inflight=%ld, ssthresh=%ld -> %ld, \\\n cwnd=%ld -> %ld\"\n inflight t.ssthresh newssthresh t.cwnd newcwnd);\n t.fast_recovery <- true;\n t.fast_rec_th <- t.tx_nxt;\n t.ssthresh <- newssthresh;\n t.rtt_timer_on <- false;\n t.cwnd <- newcwnd\n end\n\nlet rto t =\n match t.backoff_count with\n | 0 -> t.rto\n | _ -> Int64.(mul t.rto (shift_left 2L t.backoff_count))\n\nlet backoff_rto t =\n t.backoff_count <- t.backoff_count + 1;\n t.rtt_timer_on <- false;\n t.rtt_timer_reset <- true\n\nlet max_rexmits_done t =\n (t.backoff_count > 5)\n\nlet tx_totalbytes t =\n Sequence.(to_int (sub t.tx_nxt t.tx_isn))\n\nlet rx_totalbytes t =\n (-) Sequence.(to_int (sub t.rx_nxt t.rx_isn)) 1\n" }, { "path": "src/tcp/window.mli", "content": "(*\n * Copyright (c) 2010 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\ntype t\n\nval pp: Format.formatter -> t -> unit\n\nval t : rx_wnd_scale:int -> tx_wnd_scale:int -> rx_wnd:int ->\n tx_wnd:int -> rx_isn:Sequence.t -> tx_mss:int -> tx_isn:Sequence.t -> t\n\nval valid : t -> Sequence.t -> bool\n\nval rx_advance : t -> Sequence.t -> unit\nval rx_advance_inseq : t -> Sequence.t -> unit\nval rx_nxt : t -> Sequence.t\nval rx_nxt_inseq : t -> Sequence.t\n\nval tx_advance : t -> Sequence.t -> unit\nval tx_ack: t -> Sequence.t -> int -> unit\n\nval tx_nxt : t -> Sequence.t\nval tx_una : t -> Sequence.t\nval tx_mss : t -> int\nval fast_rec : t -> bool\n\nval ack_serviced : t -> bool\nval ack_seq : t -> Sequence.t\nval ack_win : t -> int\n\nval set_ack_serviced : t -> bool -> unit\nval set_ack_seq_win : t -> Sequence.t -> int -> unit\n\n(* rx_wnd: number of bytes we are willing to accept *)\nval rx_wnd : t -> int32\nval rx_wnd_unscaled : t -> int32\nval set_rx_wnd : t -> int32 -> unit\n\n(* tx_wnd: number of bytes other side is willing to accept *)\nval tx_wnd : t -> int32\nval tx_wnd_unscaled : t -> int32\n(* tx_available: number of bytes we can currently send after\n accounting for congestion *)\nval tx_available : t -> int32\n(* tx_inflight: is there any data in flight *)\nval tx_inflight : t -> bool\nval set_tx_wnd : t -> int -> unit\nval max_tx_wnd : t -> int32\n\nval alert_fast_rexmit : t -> Sequence.t -> unit\n\nval rto : t -> int64\nval backoff_rto : t -> unit\nval max_rexmits_done : t -> bool\n\nval tx_totalbytes : t -> int\nval rx_totalbytes : t -> int\n" }, { "path": "src/tcp/wire.ml", "content": "(*\n * Copyright (c) 2012 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\nopen Lwt.Infix\n\nlet src = Logs.Src.create \"tcp.wire\" ~doc:\"Mirage TCP Wire module\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nmodule Make (Ip : Tcpip.Ip.S) = struct\n\n type error = Tcpip.Ip.error\n\n let pp_error = Tcpip.Ip.pp_error\n\n type t = {\n dst_port: int; (* Remote TCP port *)\n dst: Ip.ipaddr; (* Remote IP address *)\n src_port: int; (* Local TCP port *)\n src: Ip.ipaddr; (* Local IP address *)\n }\n\n let v ~src ~src_port ~dst ~dst_port = { dst_port ; dst ; src_port ; src }\n\n let src t = t.src\n let dst t = t.dst\n let src_port t = t.src_port\n let dst_port t = t.dst_port\n\n let pp ppf t =\n Fmt.pf ppf \"remote %a,%d to local %a, %d\"\n Ip.pp_ipaddr t.dst t.dst_port Ip.pp_ipaddr t.src t.src_port\n\n let xmit ~ip { src_port; dst_port; src; dst } ?(rst=false) ?(syn=false)\n ?(fin=false) ?(psh=false)\n ~rx_ack ~seq ~window ~options payload\n =\n let (ack, ack_number) = match rx_ack with\n | None -> (false, Sequence.zero)\n | Some n -> (true, n)\n in\n let header = {\n sequence = seq; Tcp_packet.ack_number; window;\n urg = false; ack; psh; rst; syn; fin;\n options;\n src_port; dst_port;\n }\n in\n (* Make a TCP/IP header frame *)\n let tcp_size = Tcp_wire.sizeof_tcp + Options.lenv options + Cstruct.length payload in\n let fill_buffer buf =\n let pseudoheader = Ip.pseudoheader ip ~src dst `TCP tcp_size in\n match Tcp_packet.Marshal.into_cstruct header buf ~pseudoheader ~payload with\n | Error s ->\n Log.err (fun l -> l \"Error writing TCP packet header: %s\" s) ;\n 0\n (* TODO: better to avoid this entirely, now we're sending empty IP\n frame and drop the payload.. oops *)\n | Ok l ->\n Cstruct.blit payload 0 buf l (Cstruct.length payload) ;\n tcp_size\n in\n Ip.write ip ~fragment:false ~src dst `TCP ~size:tcp_size fill_buffer [] >|= function\n | Ok () -> Ok ()\n (* swallow errors so normal recovery mechanisms can be used *)\n (* For errors which aren't transient, or are too long-lived for TCP to recover\n * from, this will eventually result in a higher-level notification\n * that communication over the TCP flow has failed *)\n | Error e ->\n Log.warn (fun l -> l \"Error sending TCP packet via IP: %a\" Ip.pp_error e);\n Ok ()\nend\n" }, { "path": "src/tcp/wire.mli", "content": "(*\n * Copyright (c) 2012 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nmodule Make (Ip : Tcpip.Ip.S) : sig\n\n type error = Tcpip.Ip.error\n (** The type for TCP wire errors. *)\n\n val pp_error: error Fmt.t\n (** [pp_error] is the pretty-printer for TCP wire {!error}s. *)\n\n type t\n (** The type for TCP wire values. *)\n\n val pp: t Fmt.t\n (** [pp] is the pretty-printer for TCP wire values. *)\n\n val dst_port : t -> int\n (** Remote TCP port *)\n\n val dst: t -> Ip.ipaddr\n (** Remote IP address *)\n\n val src_port : t -> int\n (** Local TCP port *)\n\n val src: t -> Ip.ipaddr\n (** Local IP address *)\n\n val v: src:Ip.ipaddr -> src_port:int -> dst:Ip.ipaddr -> dst_port:int -> t\n (** [v ~src ~src_port ~dst ~dst_port] is the wire value [v] with the\n corresponding local and remote IP/TCP parameters. *)\n\n val xmit: ip:Ip.t -> t ->\n ?rst:bool -> ?syn:bool -> ?fin:bool -> ?psh:bool ->\n rx_ack:Sequence.t option -> seq:Sequence.t -> window:int ->\n options:Options.t list ->\n Cstruct.t -> (unit, error) result Lwt.t\n (** [xmit] emits a TCP packet over the network. *)\n\nend\n" }, { "path": "src/tcpip_checksum/checksum_stubs.c", "content": "/*\n * Copyright (c) 2010-2011 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n */\n\n#include \n#include \n#include \n#include \n#include \n#include \n\n#ifdef __x86_64__\n\n/* WARNING: This code assumes that it is running on a little endian machine (x86) */\nstatic inline uint16_t\nlocal_htons(uint16_t v)\n{\n return (((v & 0xFF) << 8) | ((v & 0xFF00) >> 8));\n}\n\nstatic inline uint16_t\nlocal_ntohs(uint16_t v)\n{\n return (local_htons(v));\n}\n\nstatic uint16_t\nones_complement_checksum_bigarray(unsigned char *addr, size_t ofs, size_t count, uint64_t sum64)\n{\n addr += ofs;\n uint64_t *data64 = (uint64_t *) addr;\n while (count >= 8) {\n uint64_t s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n count -= 8;\n }\n\n addr = (unsigned char *) data64;\n while (count > 1) {\n uint16_t v = *((uint16_t *) addr);\n sum64 += v;\n if (sum64 < v) sum64++;\n count -= 2;\n addr += 2;\n }\n\n if (count > 0) {\n uint16_t v = local_ntohs((*addr) << 8);\n sum64 += v;\n if (sum64 < v) sum64++;\n }\n\n while (sum64 >> 16)\n sum64 = (sum64 & 0xffff) + (sum64 >> 16);\n return local_htons(~sum64);\n}\n\nCAMLprim value\nmirage_tcpip_ones_complement_checksum(value v_cstruct)\n{\n CAMLparam1(v_cstruct);\n CAMLlocal3(v_ba, v_ofs, v_len);\n uint16_t checksum = 0;\n v_ba = Field(v_cstruct, 0);\n v_ofs = Field(v_cstruct, 1);\n v_len = Field(v_cstruct, 2);\n checksum = ones_complement_checksum_bigarray(Caml_ba_data_val(v_ba), Int_val(v_ofs), Int_val(v_len), 0);\n CAMLreturn(Val_int(checksum));\n}\n\n/* Checksum a list of cstruct.ts. The complexity of overflow is due to\n * having potentially odd-sized buffers, and the odd byte must be carried\n * forward as 16-byte 1s complement addition if there are more buffers in\n * the chain. */\nCAMLprim value\nmirage_tcpip_ones_complement_checksum_list(value v_cstruct_list)\n{\n CAMLparam1(v_cstruct_list);\n CAMLlocal4(v_hd, v_ba, v_ofs, v_len);\n uint16_t checksum = 0;\n uint16_t overflow_val = 0;\n uint16_t overflow = 0;\n size_t count = 0;\n struct caml_ba_array *a = NULL;\n unsigned char *addr;\n uint64_t *data64;\n uint64_t sum64 = 0;\n const size_t sizeof_ll = 8; /* sizeof (uint64_t) */\n while (v_cstruct_list != Val_emptylist) {\n v_hd = Field(v_cstruct_list, 0);\n v_cstruct_list = Field(v_cstruct_list, 1);\n v_ba = Field(v_hd, 0);\n v_ofs = Field(v_hd, 1);\n v_len = Field(v_hd, 2);\n a = Caml_ba_array_val(v_ba);\n addr = a->data + Int_val(v_ofs);\n count = Int_val(v_len);\n if (count <= 0) continue;\n if (overflow != 0) {\n overflow_val = local_ntohs((overflow_val << 8) + (*addr));\n sum64 += overflow_val;\n if (sum64 < overflow_val) sum64++;\n overflow = 0;\n addr++;\n count--;\n }\n\n data64 = (uint64_t *) addr;\n\n#define checksum_DO_PARTIAL_LOOP_UNROLL\n#ifdef checksum_DO_PARTIAL_LOOP_UNROLL\n while (count >= (20 * sizeof_ll)) {\n uint64_t s;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n\n count -= (20 * sizeof_ll);\n }\n#endif\n\n while (count >= sizeof_ll)\t{\n uint64_t s = *data64++;\n sum64 += s;\n if (sum64 < s) sum64++;\n count -= sizeof_ll;\n }\n\n addr = (unsigned char *) data64;\n while (count > 1) {\n uint16_t v = *((uint16_t *) addr);\n sum64 += v;\n if (sum64 < v) sum64++;\n count -= 2;\n addr += 2;\n }\n\n if (count > 0) {\n overflow_val = *addr;\n overflow = 1;\n }\n\n }\n\n if (overflow != 0) {\n overflow_val = local_ntohs(overflow_val << 8);\n sum64 += overflow_val;\n if (sum64 < overflow_val) sum64++;\n }\n\n while (sum64 >> 16)\n sum64 = (sum64 & 0xffff) + (sum64 >> 16);\n checksum = local_htons(~sum64);\n CAMLreturn(Val_int(checksum));\n}\n\n#else\t\t/* Generic implementation */\n\nstatic uint32_t\nchecksum_bigarray(unsigned char *addr, size_t ofs, size_t count, uint32_t sum)\n{\n addr += ofs;\n while (count > 1) {\n uint16_t v = (*addr << 8) + (*(addr+1));\n sum += v;\n count -= 2;\n addr += 2;\n }\n if (count > 0)\n sum += (*(unsigned char *)addr) << 8;\n while (sum >> 16)\n sum = (sum & 0xffff) + (sum >> 16);\n return sum;\n}\n\nCAMLprim value\nmirage_tcpip_ones_complement_checksum(value v_cstruct)\n{\n CAMLparam1(v_cstruct);\n CAMLlocal3(v_ba, v_ofs, v_len);\n uint32_t sum = 0;\n uint16_t checksum = 0;\n v_ba = Field(v_cstruct, 0);\n v_ofs = Field(v_cstruct, 1);\n v_len = Field(v_cstruct, 2);\n sum = checksum_bigarray(Caml_ba_data_val(v_ba), Int_val(v_ofs), Int_val(v_len), 0);\n checksum = ~sum;\n CAMLreturn(Val_int(checksum));\n}\n\n/* Checksum a list of cstruct.ts. The complexity of overflow is due to\n * having potentially odd-sized buffers, and the odd byte must be carried\n * forward as 16-byte 1s complement addition if there are more buffers in\n * the chain. */\nCAMLprim value\nmirage_tcpip_ones_complement_checksum_list(value v_cstruct_list)\n{\n CAMLparam1(v_cstruct_list);\n CAMLlocal4(v_hd, v_ba, v_ofs, v_len);\n uint32_t sum = 0;\n uint16_t checksum = 0;\n uint16_t overflow = 0;\n size_t count = 0;\n struct caml_ba_array *a = NULL;\n unsigned char *addr;\n while (v_cstruct_list != Val_emptylist) {\n v_hd = Field(v_cstruct_list, 0);\n v_cstruct_list = Field(v_cstruct_list, 1);\n v_ba = Field(v_hd, 0);\n v_ofs = Field(v_hd, 1);\n v_len = Field(v_hd, 2);\n a = Caml_ba_array_val(v_ba);\n addr = (unsigned char *) (a->data) + Int_val(v_ofs);\n count = Int_val(v_len);\n if (count <= 0) continue;\n if (overflow != 0) {\n sum += (overflow << 8) + (*addr);\n overflow = 0;\n addr++;\n count--;\n }\n while (count > 1) {\n uint16_t v = (*addr << 8) + (*(addr+1));\n sum += v;\n count -= 2;\n addr += 2;\n }\n if (count > 0) {\n if (v_cstruct_list == Val_emptylist)\n sum += (*(unsigned char *)addr) << 8;\n else\n overflow = *addr;\n }\n }\n if (overflow != 0)\n sum += overflow << 8;\n while (sum >> 16)\n sum = (sum & 0xffff) + (sum >> 16);\n checksum = ~sum;\n CAMLreturn(Val_int(checksum));\n}\n\n#endif\n" }, { "path": "src/tcpip_checksum/dune", "content": "(library\n (name tcpip_checksum)\n (public_name tcpip.checksum)\n (modules tcpip_checksum)\n (instrumentation\n (backend bisect_ppx))\n (libraries cstruct)\n (foreign_stubs\n (language c)\n (names checksum_stubs)\n (flags :standard))\n (wrapped false))\n" }, { "path": "src/tcpip_checksum/tcpip_checksum.ml", "content": "(*\n * Copyright (c) 2010-2011 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\n(** One's complement checksum, RFC1071 *)\nexternal ones_complement: Cstruct.t -> int = \"mirage_tcpip_ones_complement_checksum\"\n\nexternal ones_complement_list: Cstruct.t list -> int = \"mirage_tcpip_ones_complement_checksum_list\"\n" }, { "path": "src/tcpip_checksum/tcpip_checksum.mli", "content": "(*\n * Copyright (c) 2010-2011 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\n(** Checksum functions for TCP/IP *)\n\n(** One's complement checksum, RFC1071 *)\nval ones_complement: Cstruct.t -> int\n\nval ones_complement_list: Cstruct.t list -> int\n" }, { "path": "src/udp/dune", "content": "(library\n (name tcpip_udpv4)\n (public_name tcpip.udp)\n (instrumentation\n (backend bisect_ppx))\n (libraries mirage-crypto-rng logs tcpip randomconv tcpip.checksum)\n (wrapped false))\n" }, { "path": "src/udp/udp.ml", "content": "(*\n * Copyright (c) 2010-2014 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Lwt.Infix\n\nlet src = Logs.Src.create \"udp\" ~doc:\"Mirage UDP\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nmodule Make (Ip : Tcpip.Ip.S) = struct\n\n type ipaddr = Ip.ipaddr\n type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t\n\n type error = [ `Ip of Ip.error ]\n let pp_error ppf (`Ip e) = Ip.pp_error ppf e\n\n type t = {\n ip : Ip.t;\n listeners : (int, callback) Hashtbl.t;\n }\n\n let pp_ip = Ip.pp_ipaddr\n\n let listen t ~port callback =\n if port < 0 || port > 65535 then\n raise (Invalid_argument (Printf.sprintf \"invalid port number (%d)\" port))\n else\n Hashtbl.replace t.listeners port callback\n\n let unlisten t ~port = Hashtbl.remove t.listeners port\n\n (* TODO: ought we to check to make sure the destination is relevant\n here? Currently we process all incoming packets without making\n sure they're either unicast for us or otherwise interesting. *)\n let input t ~src ~dst buf =\n match Udp_packet.Unmarshal.of_cstruct buf with\n | Error s ->\n Log.debug (fun f ->\n f \"Discarding received UDP message: error parsing: %s\" s);\n Lwt.return_unit\n | Ok ({ Udp_packet.src_port; dst_port}, payload) ->\n match Hashtbl.find_opt t.listeners dst_port with\n | None -> Lwt.return_unit\n | Some fn -> fn ~src ~dst ~src_port payload\n\n let writev ?src ?src_port ?ttl ~dst ~dst_port t bufs =\n let src_port = match src_port with\n | None ->\n Randomconv.int ~bound:65535 (fun x -> Mirage_crypto_rng.generate x)\n | Some p -> p\n in\n let fill_hdr buf =\n let payload_size = Cstruct.lenv bufs in\n let ph =\n Ip.pseudoheader t.ip ?src dst `UDP (payload_size + Udp_wire.sizeof_udp)\n in\n let udp_header = Udp_packet.({ src_port; dst_port; }) in\n match Udp_packet.Marshal.into_cstruct udp_header buf ~pseudoheader:ph ~payload:(Cstruct.concat bufs) with\n | Ok () -> 8\n | Error msg ->\n Logs.err (fun m -> m \"error while assembling udp header: %s, ignoring\" msg);\n 8\n in\n Ip.write t.ip ?src dst ?ttl `UDP ~size:8 fill_hdr bufs >|= function\n | Ok () -> Ok ()\n | Error e ->\n Log.err (fun f -> f \"IP module couldn't send UDP packet to %a: %a\"\n pp_ip dst Ip.pp_error e);\n (* we're supposed to make our best effort, and we did *)\n Ok ()\n\n let write ?src ?src_port ?ttl ~dst ~dst_port t buf =\n writev ?src ?src_port ?ttl ~dst ~dst_port t [buf]\n\n let connect ip =\n Log.info (fun f -> f \"UDP layer connected on %a\"\n Fmt.(list ~sep:(any \", \") Ip.pp_prefix)\n (Ip.configured_ips ip));\n let t = { ip ; listeners = Hashtbl.create 7 } in\n Lwt.return t\n\n let disconnect t =\n Log.info (fun f -> f \"UDP layer disconnected on %a\"\n Fmt.(list ~sep:(any \", \") Ip.pp_prefix)\n (Ip.configured_ips t.ip));\n Lwt.return_unit\n\nend\n" }, { "path": "src/udp/udp.mli", "content": "(*\n * Copyright (c) 2010 Anil Madhavapeddy \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nmodule Make (IP : Tcpip.Ip.S) : sig\n include Tcpip.Udp.S with type ipaddr = IP.ipaddr\n val connect : IP.t -> t Lwt.t\nend\n" }, { "path": "src/udp/udp_packet.ml", "content": "type t = {\n src_port : Cstruct.uint16;\n dst_port : Cstruct.uint16;\n}\n\nlet equal {src_port; dst_port} q =\n src_port = q.src_port &&\n dst_port = q.dst_port\n\nlet pp fmt t =\n Format.fprintf fmt \"UDP port %d -> %d\" t.src_port t.dst_port\n\nmodule Unmarshal = struct\n\n type error = string\n\n let ( let* ) = Result.bind\n\n let of_cstruct buf =\n let open Udp_wire in\n let check_header_length () =\n if Cstruct.length buf < sizeof_udp then Error \"UDP header too short\" else Ok ()\n in\n let check_payload_length length_from_header length_of_buffer =\n if length_from_header < sizeof_udp then\n Error \"UDP header claimed a total length < the size of just the header\"\n else begin\n let payload_len = length_from_header - sizeof_udp in\n if payload_len > (length_of_buffer - sizeof_udp)\n then Error (Printf.sprintf\n\t \"UDP header claimed a payload longer than the supplied buffer: %d vs %d.\"\n payload_len length_of_buffer)\n else Ok payload_len\n end\n in\n let* () = check_header_length () in\n let total_length_from_header = get_length buf in\n let* payload_len = check_payload_length total_length_from_header (Cstruct.length buf) in\n let src_port = get_src_port buf in\n let dst_port = get_dst_port buf in\n let payload = Cstruct.sub buf sizeof_udp payload_len in\n Ok ({ src_port; dst_port; }, payload)\nend\nmodule Marshal = struct\n type error = string\n\n let unsafe_fill ~pseudoheader ~payload {src_port; dst_port} udp_buf len =\n let open Udp_wire in\n let udp_buf = Cstruct.sub udp_buf 0 sizeof_udp in\n set_src_port udp_buf src_port;\n set_dst_port udp_buf dst_port;\n set_length udp_buf len;\n set_checksum udp_buf 0;\n (* if we've been passed a buffer larger than sizeof_udp, make sure we\n * consider only the portion which will actually contain the header\n * when calculating this bit of the checksum *)\n let csum = Tcpip_checksum.ones_complement_list [ pseudoheader ; udp_buf ; payload ] in\n (* Convert zero checksum to the equivalent 0xffff, to prevent it\n * seeming like no checksum at all. From RFC768: \"If the computed\n * checksum is zero, it is transmitted as all ones (the equivalent\n * in one's complement arithmetic).\" *)\n let csum = if csum = 0 then 0xffff else csum in\n set_checksum udp_buf csum\n\n let into_cstruct ~pseudoheader ~payload t udp_buf =\n let open Udp_wire in\n let check_header_len () =\n if Cstruct.length udp_buf < sizeof_udp then\n Error \"Not enough space for a UDP header\"\n else\n Ok ()\n in\n Result.bind (check_header_len ())\n (fun () ->\n let len = Cstruct.length payload + sizeof_udp in\n let buf = Cstruct.sub udp_buf 0 sizeof_udp in\n unsafe_fill ~pseudoheader ~payload t buf len;\n Ok ())\n\n let make_cstruct ~pseudoheader ~payload t =\n let buf = Cstruct.create Udp_wire.sizeof_udp in\n let len = Udp_wire.sizeof_udp + Cstruct.length payload in\n unsafe_fill ~pseudoheader ~payload t buf len;\n buf\nend\n" }, { "path": "src/udp/udp_packet.mli", "content": "type t = {\n src_port : Cstruct.uint16;\n dst_port : Cstruct.uint16;\n}\n\nval pp : Format.formatter -> t -> unit\nval equal : t -> t -> bool\n\nmodule Unmarshal : sig\n\n type error = string\n\n(** [of_cstruct buf] attempts to interpret [buf] as a UDP header. If\n successful, it returns [Ok (header, payload)], although [payload] may be an\n empty Cstruct.t . *)\n val of_cstruct : Cstruct.t -> (t * Cstruct.t, error) result\nend\nmodule Marshal : sig\n\n type error = string\n\n (** [into_cstruct ~pseudoheader ~payload t buf] attempts to\n assemble a UDP header in [buf] with [t.src_port] and [t.dst_port] set,\n along with the correct length and checksum.\n It does not write [pseudoheader] or [payload] into the buffer,\n but requires them to calculate the correct checksum. *)\n val into_cstruct :\n pseudoheader:Cstruct.t ->\n payload:Cstruct.t ->\n t -> Cstruct.t ->\n (unit, error) result\n\n (** [make_cstruct ~pseudoheader ~payload t] allocates, fills, and and returns a buffer\n representing the UDP header corresponding to [t]. [make_cstruct] will\n allocate 8 bytes for the UDP header.\n [payload] and [pseudoheader] are not directly represented in the output,\n and are required for correct computation of the UDP checksum only.\n The checksum will be properly set to reflect the pseudoheader, header, and payload. *)\n val make_cstruct : pseudoheader:Cstruct.t -> payload:Cstruct.t -> t -> Cstruct.t\nend\n" }, { "path": "src/udp/udp_wire.ml", "content": "let sizeof_udp = 8\n\nlet src_port_offset = 0\nlet dst_port_offset = 2\nlet length_offset = 4\nlet checksum_offset = 6\n\nlet get_src_port buf = Cstruct.BE.get_uint16 buf src_port_offset\nlet set_src_port buf v = Cstruct.BE.set_uint16 buf src_port_offset v\n\nlet get_dst_port buf = Cstruct.BE.get_uint16 buf dst_port_offset\nlet set_dst_port buf v = Cstruct.BE.set_uint16 buf dst_port_offset v\n\nlet get_length buf = Cstruct.BE.get_uint16 buf length_offset\nlet set_length buf v = Cstruct.BE.set_uint16 buf length_offset v\n\nlet get_checksum buf = Cstruct.BE.get_uint16 buf checksum_offset\nlet set_checksum buf value = Cstruct.BE.set_uint16 buf checksum_offset value\n" }, { "path": "src/udp/udp_wire.mli", "content": "val sizeof_udp : int\n\nval get_src_port : Cstruct.t -> int\nval set_src_port : Cstruct.t -> int -> unit\n\nval get_dst_port : Cstruct.t -> int\nval set_dst_port : Cstruct.t -> int -> unit\n\nval get_length : Cstruct.t -> int\nval set_length : Cstruct.t -> int -> unit\n\nval get_checksum : Cstruct.t -> int\nval set_checksum : Cstruct.t -> int -> unit\n" }, { "path": "tcpip.opam", "content": "opam-version: \"2.0\"\nmaintainer: \"anil@recoil.org\"\nhomepage: \"https://github.com/mirage/mirage-tcpip\"\ndev-repo: \"git+https://github.com/mirage/mirage-tcpip.git\"\nbug-reports: \"https://github.com/mirage/mirage-tcpip/issues\"\ndoc: \"https://mirage.github.io/mirage-tcpip/\"\nauthors: [\n \"Anil Madhavapeddy\" \"Balraj Singh\" \"Richard Mortier\" \"Nicolas Ojeda Bar\"\n \"Thomas Gazagnaire\" \"Vincent Bernardoff\" \"Magnus Skjegstad\" \"Mindy Preston\"\n \"Thomas Leonard\" \"David Scott\" \"Gabor Pali\" \"Hannes Mehnert\" \"Haris Rotsos\"\n \"Kia\" \"Luke Dunstan\" \"Pablo Polvorin\" \"Tim Cuthbertson\" \"lnmx\" \"pqwy\" ]\nlicense: \"ISC\"\ntags: [\"org:mirage\"]\nx-maintenance-intent: [ \"(latest)\" ]\n\nbuild: [\n [\"dune\" \"subst\"] {dev}\n [\"dune\" \"build\" \"-p\" name \"-j\" jobs]\n [\"dune\" \"runtest\" \"-p\" name \"-j\" jobs] {with-test}\n]\nconflicts: [\n \"mirage-xen\" {< \"6.0.0\"}\n \"ocaml-freestanding\"\n \"result\" {< \"1.5\"}\n]\ndepends: [\n \"dune\" {>= \"2.7.0\"}\n \"bisect_ppx\" {dev & >= \"2.5.0\"}\n \"ocaml\" {>= \"4.08.0\"}\n \"cstruct\" {>= \"6.2.0\"}\n \"cstruct-lwt\"\n \"mirage-net\" {>= \"3.0.0\"}\n \"mirage-mtime\" {>= \"4.0.0\"}\n \"mirage-crypto-rng\" {>= \"1.2.0\"}\n \"mirage-sleep\" {>= \"4.0.0\"}\n \"ipaddr\" {>= \"5.6.0\"}\n \"macaddr\" {>=\"4.0.0\"}\n \"macaddr-cstruct\"\n \"fmt\" {>= \"0.8.7\"}\n \"lwt\" {>= \"4.0.0\"}\n \"lwt-dllist\"\n \"logs\" {>= \"0.6.0\"}\n \"duration\"\n \"randomconv\" {>= \"0.2.0\"}\n \"ethernet\" {>= \"3.0.0\"}\n \"arp\" {>= \"4.0.0\"}\n \"mirage-flow\" {>= \"4.0.0\"}\n \"mirage-vnetif\" {with-test & >= \"0.6.2\"}\n \"alcotest\" {with-test & >=\"1.5.0\"}\n \"pcap-format\" {with-test}\n \"ipaddr-cstruct\"\n \"macaddr-cstruct\"\n \"lru\" {>= \"0.3.0\"}\n \"metrics\"\n \"cmdliner\" {>= \"1.1.0\"}\n]\nsynopsis: \"OCaml TCP/IP networking stack, used in MirageOS\"\ndescription: \"\"\"\n`mirage-tcpip` provides a networking stack for the [Mirage operating\nsystem](https://mirage.io). It provides implementations for the following module types\n(which correspond with the similarly-named protocols):\n\n* IP (via the IPv4 and IPv6 modules)\n* ICMP\n* UDP\n* TCP\n\"\"\"\n" }, { "path": "test/common.ml", "content": "open Lwt.Infix\n\nlet failf fmt = Fmt.kstr (fun s -> Alcotest.fail s) fmt\n\nlet ( let* ) = Result.bind\n\nlet or_error name fn t =\n fn t >>= function\n | Error _ -> failf \"or_error starting %s\" name\n | Ok t -> Lwt.return t\n\nlet expect_error error name fn t =\n fn t >>= function\n | Error error2 when error2 = error -> Lwt.return t\n | _ -> failf \"expected error on %s\" name\n\nlet ipv4_packet = Alcotest.testable Ipv4_packet.pp Ipv4_packet.equal\nlet udp_packet = Alcotest.testable Udp_packet.pp Udp_packet.equal\nlet tcp_packet = Alcotest.testable Tcp.Tcp_packet.pp Tcp.Tcp_packet.equal\nlet cstruct = Alcotest.testable Cstruct.hexdump_pp Cstruct.equal\n\nlet sequence =\n let eq x y = Tcp.Sequence.compare x y = 0 in\n Alcotest.testable Tcp.Sequence.pp eq\n\nlet options = Alcotest.testable Tcp.Options.pp Tcp.Options.equal\n" }, { "path": "test/dune", "content": "(test\n (name test)\n (libraries alcotest mirage-crypto-rng mirage-crypto-rng.unix lwt.unix logs logs.fmt\n mirage-flow mirage-vnetif mirage-mtime pcap-format duration\n arp arp.mirage ethernet tcpip.ipv4 tcpip.tcp tcpip.udp\n tcpip.stack-direct tcpip.icmpv4 tcpip.udpv4v6-socket tcpip.tcpv4v6-socket\n tcpip.icmpv4-socket tcpip.stack-socket tcpip.ipv6 ipaddr-cstruct\n macaddr-cstruct tcpip)\n (action\n (run %{test} -q -e --color=always)))\n" }, { "path": "test/low_level.ml", "content": "open Lwt.Infix\n\n(*\n * Connects two stacks to the same backend.\n * One is a complete v4 stack (the system under test, referred to as [sut]).\n * The other gives us low level access to inject crafted TCP packets,\n * and sends and receives crafted packets to check the [sut] behavior.\n *)\nmodule VNETIF_STACK = Vnetif_common.VNETIF_STACK(Vnetif_backends.Basic)\n\nmodule V = Vnetif.Make(Vnetif_backends.Basic)\nmodule E = Ethernet.Make(V)\nmodule A = Arp.Make(E)\nmodule I = Static_ipv4.Make(E)(A)\nmodule Wire = Tcp.Wire\nmodule WIRE = Wire.Make(I)\nmodule Tcp_wire = Tcp.Tcp_wire\nmodule Tcp_unmarshal = Tcp.Tcp_packet.Unmarshal\nmodule Sequence = Tcp.Sequence\n\nlet sut_cidr = Ipaddr.V4.Prefix.of_string_exn \"10.0.0.101/24\"\nlet server_ip = Ipaddr.V4.of_string_exn \"10.0.0.100\"\nlet server_cidr = Ipaddr.V4.Prefix.make 24 server_ip\nlet gateway = Ipaddr.V4.of_string_exn \"10.0.0.1\"\n\nlet header_size = Ethernet.Packet.sizeof_ethernet\n\n\n\n(* defaults when injecting packets *)\nlet options = []\nlet window = 5120\n\n(* Helper functions *)\nlet reply_id_from ~src ~dst data =\n let sport = Tcp_wire.get_src_port data in\n let dport = Tcp_wire.get_dst_port data in\n WIRE.v ~dst_port:sport ~dst:src ~src_port:dport ~src:dst\n\nlet ack_for data =\n match Tcp_unmarshal.of_cstruct data with\n | Error s -> Alcotest.fail (\"attempting to ack data: \" ^ s)\n | Ok (packet, data) ->\n let open Tcp.Tcp_packet in\n let data_len =\n Sequence.of_int ((Cstruct.length data) +\n\t\t (if packet.fin then 1 else 0) +\n\t\t (if packet.syn then 1 else 0)) in\n let sequence = packet.sequence in\n let ack_n = Sequence.(add sequence data_len) in\n ack_n\n\nlet ack data =\n Some(ack_for data)\n\nlet ack_in_future data off =\n Some Sequence.(add (ack_for data) (of_int off))\n\nlet ack_from_past data off =\n Some Sequence.(sub (ack_for data) (of_int off))\n\nlet fail_result_not_expected fail = function\n | Error _err ->\n fail \"error not expected\"\n | Ok `Eof ->\n fail \"eof\"\n | Ok (`Data data) ->\n Alcotest.fail (Format.asprintf \"data not expected but received: %a\"\n\t\t Cstruct.hexdump_pp data)\n\n\n\nlet create_sut_stack backend =\n VNETIF_STACK.create_stack ~cidr:sut_cidr ~gateway backend\n\nlet create_raw_stack backend =\n V.connect backend >>= fun netif ->\n E.connect netif >>= fun ethif ->\n A.connect ethif >>= fun arpv4 ->\n I.connect ~cidr:server_cidr ~gateway ethif arpv4 >>= fun ip ->\n Lwt.return (netif, ethif, arpv4, ip)\n\ntype 'state fsm_result =\n | Fsm_next of 'state\n | Fsm_done\n | Fsm_error of string\n\n(* This could be moved to a common module and reused for other low level tcp tests *)\n\n(* setups network and run a given sut and raw fsm *)\nlet run backend fsm sut () =\n let initial_state, fsm_handler = fsm in\n create_sut_stack backend >>= fun stack ->\n create_raw_stack backend >>= fun (netif, ethif, arp, rawip) ->\n let error_mbox = Lwt_mvar.create_empty () in\n let stream, pushf = Lwt_stream.create () in\n Lwt.pick [\n VNETIF_STACK.Stack.listen stack;\n\n (* Consume TCP packets one by one, in sequence *)\n let rec fsm_thread state =\n Lwt_stream.next stream >>= fun (src, dst, data) ->\n fsm_handler rawip state ~src ~dst data >>= function\n | Fsm_next s ->\n fsm_thread s\n | Fsm_done ->\n Lwt.return_unit\n | Fsm_error err ->\n Lwt_mvar.put error_mbox err >>= fun () ->\n (* it will be terminated anyway when the error is picked up *)\n fsm_thread state in\n\n Lwt.async (fun () ->\n (V.listen netif ~header_size\n (E.input\n ~arpv4:(A.input arp)\n ~ipv4:(I.input\n ~tcp: (fun ~src ~dst data -> pushf (Some(src,dst,data)); Lwt.return_unit)\n ~udp:(fun ~src:_ ~dst:_ _data -> Lwt.return_unit)\n ~default:(fun ~proto ~src ~dst _data ->\n Logs.debug (fun f -> f \"default handler invoked for packet from %a to %a, protocol %d -- dropping\" Ipaddr.V4.pp src Ipaddr.V4.pp dst proto); Lwt.return_unit)\n rawip\n )\n ~ipv6:(fun _buf ->\n Logs.debug (fun f -> f \"IPv6 packet -- dropping\");\n Lwt.return_unit)\n ethif) ) >|= fun _ -> ());\n\n (* Either both fsm and the sut terminates, or a timeout occurs, or one of the sut/fsm informs an error *)\n Lwt.pick [\n (Mirage_sleep.ns (Duration.of_sec 5) >>= fun () ->\n Lwt.return_some \"timed out\");\n\n (Lwt.join [\n (fsm_thread initial_state);\n\n (* time to let the other end connects to the network and listen.\n * Otherwise initial syn might need to be repeated slowing down the test *)\n (Mirage_sleep.ns (Duration.of_ms 100) >>= fun () ->\n sut stack (Lwt_mvar.put error_mbox) >>= fun _ ->\n Mirage_sleep.ns (Duration.of_ms 100));\n ] >>= fun () -> Lwt.return_none);\n\n (Lwt_mvar.take error_mbox >>= fun cause ->\n Lwt.return_some cause);\n ] >|= function\n | None -> ()\n | Some err -> Alcotest.fail err\n ]\n" }, { "path": "test/mock-clock/dune", "content": "(test\n (name test_tcp_window)\n (libraries alcotest mirage-crypto-rng mirage-crypto-rng.unix lwt.unix logs logs.fmt\n mirage-mtime.mock tcpip.tcp)\n (action\n (run %{test} -q -e --color=always)))\n" }, { "path": "test/mock-clock/test_tcp_window.ml", "content": "let default_window () =\n Tcp.Window.t ~tx_wnd_scale:2 ~rx_wnd_scale:2 ~rx_wnd:65535 ~tx_wnd:65535 ~rx_isn:Tcp.Sequence.zero ~tx_mss:1460 ~tx_isn:Tcp.Sequence.zero\n\nlet fresh_window () =\n let window = default_window () in\n Alcotest.(check bool) \"should be no data in flight\" false @@ Tcp.Window.tx_inflight window;\n Alcotest.(check bool) \"no rexmits yet\" false @@ Tcp.Window.max_rexmits_done window;\n Alcotest.(check int) \"no traffic transferred yet\" 0 @@ Tcp.Window.tx_totalbytes window;\n Alcotest.(check int) \"no traffic received yet\" 0 @@ Tcp.Window.rx_totalbytes window;\n Alcotest.(check int32) \"should be able to send 65535 <<= 2 bytes\" Int32.(mul 65535l 4l) @@ Tcp.Window.tx_wnd window;\n Alcotest.(check int32) \"should be able to receive 65535 <<= 2 bytes\" Int32.(mul 65535l 4l) @@ Tcp.Window.rx_wnd window;\n Alcotest.(check int64) \"initial rto is 2/3 second\" (Duration.of_ms 667) @@ Tcp.Window.rto window;\n Lwt.return_unit\n\nlet increase_congestion_window window goal =\n (* simulate a successful slow start, which primes the congestion window to be relatively large *)\n let receive_window = Tcp.Window.ack_win window in\n let rec successful_transmission goal =\n let max_send = Tcp.Window.tx_available window |> Tcp.Sequence.of_int32 in\n match Tcp.Sequence.geq max_send goal with\n | true -> max_send\n | false ->\n let sz = Tcp.Sequence.add max_send @@ Tcp.Window.tx_nxt window in\n Mirage_mtime_set.tick ();\n Tcp.Window.tx_advance window @@ Tcp.Window.tx_nxt window;\n Mirage_mtime_set.tick ();\n (* need to acknowledge the full size of the data *)\n Tcp.Window.tx_ack window sz receive_window;\n successful_transmission goal\n in\n successful_transmission goal\n\nlet n_segments window n =\n Int32.mul n @@ Int32.of_int @@ Tcp.Window.tx_mss window |> Tcp.Sequence.of_int32\n\n(* attempt to ensure that fast recovery is working as described in rfc5681 *)\nlet recover_fast () =\n let window = default_window () in\n let receive_window = Tcp.Window.ack_win window in\n Alcotest.(check bool) \"don't start in fast recovery\" false @@ Tcp.Window.fast_rec window;\n\n (* get a large congestion window to avoid confounding factors *)\n let cwnd_goal = 262140l in\n let _ = increase_congestion_window window (Tcp.Sequence.of_int32 cwnd_goal) in\n let available_to_send = Tcp.Window.tx_available window in\n let big_enough x = Int32.compare x cwnd_goal > 0 in\n Alcotest.(check bool) \"congestion window is big enough\" true @@ big_enough available_to_send;\n\n (* get ready to send another burst of data *)\n let seq = Tcp.Window.tx_nxt window in\n Mirage_mtime_set.tick ();\n (* say that we sent the full amount of data *)\n let sz = Tcp.Sequence.(add (of_int32 available_to_send) seq) in\n Tcp.Window.tx_advance window sz;\n (* but receive an ack indicating that we missed a segment *)\n let nonfull_ack = Tcp.Sequence.add seq @@ n_segments window 4l in\n (* 1st ack *)\n Mirage_mtime_set.tick ();\n Tcp.Window.tx_ack window nonfull_ack receive_window;\n (* 1st duplicate ack *)\n Mirage_mtime_set.tick ();\n Tcp.Window.tx_ack window nonfull_ack receive_window;\n (* 2nd duplicate ack *)\n Mirage_mtime_set.tick ();\n Tcp.Window.tx_ack window nonfull_ack receive_window;\n (* 3rd duplicate ack *)\n Mirage_mtime_set.tick ();\n Tcp.Window.tx_ack window nonfull_ack receive_window;\n (* request that we go into fast retransmission *)\n Tcp.Window.alert_fast_rexmit window @@ n_segments window 4l;\n\n Alcotest.(check bool) \"fast retransmit when we wanted it\" true @@ Tcp.Window.fast_rec window;\n\n Alcotest.(check bool) \"once entering fast recovery, we can send >0 packets\" true ((Int32.compare (Tcp.Window.tx_available window) 0l) > 0);\n\n Lwt.return_unit\n\nlet rto_calculation () =\n let window = default_window () in\n (* RFC 2988 2.1 *)\n Alcotest.(check int64) \"initial rto is 2/3 second\" (Duration.of_ms 667) @@ Tcp.Window.rto window;\n let receive_window = Tcp.Window.ack_win window in\n Tcp.Window.tx_advance window (Tcp.Window.tx_nxt window);\n Mirage_mtime_set.tick_for (Duration.of_ms 400);\n let max_size = Tcp.Window.tx_available window |> Tcp.Sequence.of_int32 in\n let sz = Tcp.Sequence.add max_size @@ (Tcp.Window.tx_nxt window) in\n Tcp.Window.tx_ack window sz receive_window;\n (* RFC 2988 2.2 *)\n Alcotest.(check int64) \"After one RTT measurement, the calculated rto is 400 + (4 * 200) = 1200ms\" (Duration.of_ms 1200) @@ Tcp.Window.rto window;\n\n (* RFC 2988 2.3 *)\n Tcp.Window.tx_advance window (Tcp.Window.tx_nxt window);\n let receive_window = Tcp.Window.ack_win window in\n Mirage_mtime_set.tick_for (Duration.of_ms 300);\n let max_size = Tcp.Window.tx_available window |> Tcp.Sequence.of_int32 in\n let sz = Tcp.Sequence.add max_size @@ (Tcp.Window.tx_nxt window) in\n Tcp.Window.tx_ack window sz receive_window;\n Alcotest.(check int64) \"After subsequent RTT measurement, the calculated rto is 1087.5ms\" (Duration.of_us 1087500) @@ Tcp.Window.rto window;\n\n Lwt.return_unit\n\n\nlet suite = [\n \"fresh window is sensible\", `Quick, fresh_window;\n \"fast recovery recovers fast\", `Quick, recover_fast;\n \"smoothed rtt, rtt variation and retransmission timer are calculated according to RFC2988\", `Quick, rto_calculation;\n]\n\nlet suite = [\n \"tcp_window\" , suite ;\n]\n\nlet run test () =\n Lwt_main.run (test ())\n\nlet () =\n Printexc.record_backtrace true;\n Mirage_crypto_rng_unix.use_default ();\n (* enable logging to stdout for all modules *)\n Logs.set_reporter (Logs_fmt.reporter ());\n Logs.set_level ~all:true (Some Logs.Debug);\n let suite = List.map (fun (n, s) ->\n n, List.map (fun (d, s, f) -> d, s, run f) s\n ) suite\n in\n Alcotest.run \"tcpip\" suite\n" }, { "path": "test/static_arp.ml", "content": "open Lwt.Infix\n\nmodule Make(E : Ethernet.S) = struct\n module A = Arp.Make(E)\n (* generally repurpose A, but substitute input and query, and add functions\n for adding/deleting entries *)\n type error = A.error\n\n type t = {\n base : A.t;\n table : (Ipaddr.V4.t, Macaddr.t) Hashtbl.t;\n }\n\n let pp_error = A.pp_error\n let add_ip t = A.add_ip t.base\n let remove_ip t = A.remove_ip t.base\n let set_ips t = A.set_ips t.base\n let get_ips t = A.get_ips t.base\n\n let pp ppf t =\n let print ip entry =\n Fmt.pf ppf \"IP %a : MAC %a\" Ipaddr.V4.pp ip Macaddr.pp entry\n in\n Hashtbl.iter print t.table\n\n let connect e = A.connect e >>= fun base ->\n Lwt.return ({ base; table = (Hashtbl.create 7) })\n\n let disconnect t = A.disconnect t.base\n\n let query t ip =\n match Hashtbl.mem t.table ip with\n | false -> Lwt.return @@ Error `Timeout\n | true -> Lwt.return (Ok (Hashtbl.find t.table ip))\n\n let input t buffer =\n (* disregard responses, but reply to queries *)\n let open Arp_packet in\n match decode buffer with\n | Ok arp when arp.operation = Request -> A.input t.base buffer\n | Ok _ -> Lwt.return_unit\n | Error e ->\n Format.printf \"Arp decoding failed %a\" pp_error e ;\n Lwt.return_unit\n\n let add_entry t ip mac =\n Hashtbl.add t.table ip mac\nend\n" }, { "path": "test/test.ml", "content": "(*\n * Copyright (c) 2013 Thomas Gazagnaire \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nlet suite = [\n \"checksums\" , Test_checksums.suite ;\n \"ipv4\" , Test_ipv4.suite ;\n \"ipv6\" , Test_ipv6.suite ;\n \"icmpv4\" , Test_icmpv4.suite ;\n \"udp\" , Test_udp.suite ;\n \"tcp_options\" , Test_tcp_options.suite ;\n \"mtu+tcp\" , Test_mtus.suite ;\n \"rfc5961\" , Test_rfc5961.suite ;\n \"socket\" , Test_socket.suite ;\n \"connect\" , Test_connect.suite ;\n \"connect_ipv6\" , Test_connect_ipv6.suite ;\n \"deadlock\" , Test_deadlock.suite ;\n \"iperf\" , Test_iperf.suite ;\n \"iperf_ipv6\" , Test_iperf_ipv6.suite ;\n \"keepalive\" , Test_keepalive.suite ;\n \"simultaneous_close\", Test_simulatenous_close.suite\n]\n\nlet run test () =\n Lwt_main.run (test ())\n\nlet () =\n Printexc.record_backtrace true;\n Mirage_crypto_rng_unix.use_default ();\n (* enable logging to stdout for all modules *)\n Logs.set_reporter (Logs_fmt.reporter ());\n Logs.set_level ~all:true (Some Logs.Debug);\n let suite = List.map (fun (n, s) ->\n n, List.map (fun (d, s, f) -> d, s, run f) s\n ) suite\n in\n let filter ~name ~index =\n (* Lwt_bytes (as of 5.5.0) on Windows doesn't support UDP. *)\n let skip = [\n 3 (* no_leak_fds_in_udpv4 *);\n 5 (* no_leak_fds_in_udpv6 *);\n 7 (* no_leak_fds_in_udpv4v6 *);\n 9 (* no_leak_fds_in_udpv4v6_2 *);\n 11 (* no_leak_fds_in_udpv4v6_3 *);\n 13 (* no_leak_fds_in_udpv4v6_4 *);\n 15 (* no_leak_fds_in_udpv4v6_5 *);\n ] in\n if Sys.win32 && name = \"socket\" && List.mem index skip then `Skip else `Run\n in\n Alcotest.run \"tcpip\" suite ~filter\n" }, { "path": "test/test_checksums.ml", "content": "let unwrap_ipv4 buf = Ipv4_packet.Unmarshal.of_cstruct buf |> Result.get_ok\nlet verify_ipv4_udp = Ipv4_packet.Unmarshal.verify_transport_checksum ~proto:`UDP\nlet verify_ipv4_tcp = Ipv4_packet.Unmarshal.verify_transport_checksum ~proto:`TCP\n\nlet example_ipv4_udp = \"\\\n\\x45\\xb8\\x00\\x4c\\xbf\\x7c\\x40\\x00\\x34\\x11\\xdf\\x65\\x90\\x5c\\x09\\x16\\\n\\x0a\\x89\\x03\\x0c\\x00\\x7b\\x00\\x7b\\x00\\x38\\xf4\\xfb\\x24\\x01\\x03\\xee\\\n\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x43\\x47\\x50\\x53\\x00\\xdc\\x03\\xd0\\x04\\\n\\x53\\x76\\x73\\x95\\xdc\\x03\\xd0\\x06\\xcb\\xd2\\x4f\\xfb\\xdc\\x03\\xd0\\x06\\\n\\xcd\\x57\\x43\\xa0\\xdc\\x03\\xd0\\x06\\xcd\\xb6\\x2e\\x51\"\n\nlet example_ipv4_tcp = \"\\\n\\x45\\x00\\x00\\x34\\x00\\x00\\x40\\x00\\x2d\\x06\\x47\\x91\\x93\\x4b\\x65\\x53\\\n\\x0a\\x89\\x03\\x0c\\x01\\xbb\\xe5\\xd0\\x6f\\x75\\x20\\x55\\xf6\\x5e\\xdb\\xef\\\n\\x80\\x12\\x72\\x10\\xad\\x83\\x00\\x00\\x02\\x04\\x05\\x48\\x01\\x01\\x04\\x02\\\n\\x01\\x03\\x03\\x08\"\n\nlet udp_ipv4_correct_positive () =\n let buf = Cstruct.of_string example_ipv4_udp in\n let (ipv4_header, transport_packet) = unwrap_ipv4 buf in\n Alcotest.(check bool) \"for a correct UDP checksum, return true\"\n true @@ verify_ipv4_udp ~ipv4_header ~transport_packet;\n Lwt.return_unit\n\nlet udp_ipv4_correct_negative () =\n let buf = Cstruct.of_string example_ipv4_udp in\n Cstruct.BE.set_uint32 buf ((Cstruct.length buf) - 4) 0x1234l;\n let (ipv4_header, transport_packet) = unwrap_ipv4 buf in\n Alcotest.(check bool) \"mutating the packet w/o fixing checksum causes verification to fail\"\n false @@ verify_ipv4_udp ~ipv4_header ~transport_packet;\n Lwt.return_unit\n\nlet udp_ipv4_allows_zero () =\n let buf = Cstruct.of_string example_ipv4_udp in\n let (ipv4_header, transport_packet) = unwrap_ipv4 buf in\n Udp_wire.set_checksum transport_packet 0x0000;\n Alcotest.(check bool) \"0x0000 checksum is OK for UDP\"\n true @@ verify_ipv4_udp ~ipv4_header ~transport_packet;\n Lwt.return_unit\n\nlet udp_ipv4_zero_checksum () =\n let src = Ipaddr.V4.make 127 0 0 1 in\n let dst = src in\n let proto = `UDP in\n let ttl = 38 in\n let options = Cstruct.empty in\n let payload = Cstruct.of_hex \"01 84\" in\n let payload_len = Cstruct.length payload in\n let ipv4_header = Ipv4_packet.{\n src; dst;\n proto = Ipv4_packet.Marshal.protocol_to_int proto;\n ttl; id = 0 ; off = 0 ; options } in\n let pseudoheader = Ipv4_packet.Marshal.pseudoheader\n ~src\n ~dst\n ~proto\n (payload_len + 8) in\n let packet = Cstruct.concat [\n Ipv4_packet.Marshal.make_cstruct ~payload_len:(payload_len + 8) ipv4_header;\n Udp_packet.Marshal.make_cstruct ~pseudoheader ~payload\n { src_port = 42; dst_port = 42 };\n payload] in\n let (_ipv4_header', transport_packet) = unwrap_ipv4 packet in\n\n Alcotest.(check bool) \"UDP packets with zero checksums pass verification\"\n true @@ verify_ipv4_udp ~ipv4_header ~transport_packet;\n\n Cstruct.set_char transport_packet (Cstruct.length transport_packet - 1) '\\000';\n Alcotest.(check bool) \"Corrupted UDP packets with zero checksum fail verification\"\n false @@ verify_ipv4_udp ~ipv4_header ~transport_packet;\n\n Lwt.return_unit\n\n\nlet tcp_ipv4_correct_positive () =\n let buf = Cstruct.of_string example_ipv4_tcp in\n let (ipv4_header, transport_packet) = unwrap_ipv4 buf in\n Alcotest.(check bool) \"for a correct TCP checksum, return true\"\n true @@ verify_ipv4_tcp ~ipv4_header ~transport_packet;\n Lwt.return_unit\n\nlet tcp_ipv4_correct_negative () =\n let buf = Cstruct.of_string example_ipv4_tcp in\n Cstruct.BE.set_uint32 buf ((Cstruct.length buf) - 4) 0x1234l;\n let (ipv4_header, transport_packet) = unwrap_ipv4 buf in\n Alcotest.(check bool) \"mutating a TCP packet w/o fixing checksum causes verification to fail\"\n false @@ verify_ipv4_tcp ~ipv4_header ~transport_packet;\n Lwt.return_unit\n\nlet suite =\n[\n \"correct UDP IPV4 checksums are recognized\", `Quick, udp_ipv4_correct_positive;\n \"incorrect UDP IPV4 checksums are recognized\", `Quick, udp_ipv4_correct_negative;\n \"0x00 UDP checksum is valid\", `Quick, udp_ipv4_allows_zero;\n \"correct but zero UDP IPV4 checksums are recognized\", `Quick, udp_ipv4_zero_checksum;\n \"correct TCP IPV4 checksums are recognized\", `Quick, tcp_ipv4_correct_positive;\n \"incorrect TCP IPV4 checksums are recognized\", `Quick, tcp_ipv4_correct_negative;\n]\n" }, { "path": "test/test_connect.ml", "content": "(*\n * Copyright (c) 2015 Magnus Skjegstad \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Common\nopen Vnetif_common\n\nlet (>>=) = Lwt.(>>=)\n\nlet src = Logs.Src.create \"test_connect\" ~doc:\"connect tests\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nmodule Test_connect (B : Vnetif_backends.Backend) = struct\n module V = VNETIF_STACK (B)\n\n let gateway = Ipaddr.V4.of_string_exn \"10.0.0.1\"\n let client_cidr = Ipaddr.V4.Prefix.of_string_exn \"10.0.0.101/24\"\n let server_cidr = Ipaddr.V4.Prefix.of_string_exn \"10.0.0.100/24\"\n let test_string = \"Hello world from Mirage 123456789....\"\n let backend = V.create_backend ()\n\n let err_read_eof () = failf \"accept got EOF while reading\"\n let err_write_eof () = failf \"client tried to write, got EOF\"\n\n let err_read e =\n let err = Format.asprintf \"%a\" V.Stack.TCP.pp_error e in\n failf \"Error while reading: %s\" err\n\n let err_write e =\n let err = Format.asprintf \"%a\" V.Stack.TCP.pp_write_error e in\n failf \"client tried to write, got %s\" err\n\n let accept flow expected =\n let ip, port = V.Stack.TCP.dst flow in\n Log.debug (fun f -> f \"Accepted connection from %s:%d\" (Ipaddr.to_string ip) port);\n V.Stack.TCP.read flow >>= function\n | Error e -> err_read e\n | Ok `Eof -> err_read_eof ()\n | Ok (`Data b) ->\n Lwt_unix.sleep 0.1 >>= fun () ->\n (* sleep first to capture data in pcap *)\n Alcotest.(check string) \"accept\" expected (Cstruct.to_string b);\n Log.debug (fun f -> f \"Connection closed\");\n Lwt.return_unit\n\n let test_tcp_connect_two_stacks () =\n let timeout = 15.0 in\n Lwt.pick [\n (Lwt_unix.sleep timeout >>= fun () ->\n failf \"connect test timedout after %f seconds\" timeout) ;\n\n (V.create_stack ~cidr:server_cidr ~gateway backend >>= fun s1 ->\n V.Stack.TCP.listen (V.Stack.tcp s1) ~port:80 (fun f -> accept f test_string);\n V.Stack.listen s1) ;\n\n (Lwt_unix.sleep 0.1 >>= fun () ->\n V.create_stack ~cidr:client_cidr ~gateway backend >>= fun s2 ->\n Lwt.pick [\n V.Stack.listen s2;\n (let conn = V.Stack.TCP.create_connection (V.Stack.tcp s2) in\n or_error \"connect\" conn (Ipaddr.V4 (Ipaddr.V4.Prefix.address server_cidr), 80) >>= fun flow ->\n Log.debug (fun f -> f \"Connected to other end...\");\n\n V.Stack.TCP.write flow (Cstruct.of_string test_string) >>= function\n | Error `Closed -> err_write_eof ()\n | Error e -> err_write e\n | Ok () ->\n Log.debug (fun f -> f \"wrote hello world\");\n V.Stack.TCP.close flow >>= fun () ->\n Lwt_unix.sleep 1.0 >>= fun () -> (* record some traffic after close *)\n Lwt.return_unit)]) ] >>= fun () ->\n\n Lwt.return_unit\n\n let record_pcap =\n V.record_pcap backend\n\nend\n\nlet test_tcp_connect_two_stacks_basic () =\n let module Test = Test_connect(Vnetif_backends.Basic) in\n Test.record_pcap\n \"tcp_connect_two_stacks_basic.pcap\"\n Test.test_tcp_connect_two_stacks\n\nlet test_tcp_connect_two_stacks_x100_uniform_no_payload_packet_loss () =\n let rec loop = function\n | 0 -> Lwt.return_unit\n | n -> Log.info (fun f -> f \"%d/100\" (101-n));\n let module Test = Test_connect(Vnetif_backends.Uniform_no_payload_packet_loss) in\n Test.record_pcap\n (Printf.sprintf\n \"tcp_connect_two_stacks_no_payload_packet_loss_%d_of_100.pcap\" n)\n Test.test_tcp_connect_two_stacks >>= fun () ->\n loop (n - 1)\n in\n loop 100\n\nlet test_tcp_connect_two_stacks_trailing_bytes () =\n let module Test = Test_connect(Vnetif_backends.Trailing_bytes) in\n Test.record_pcap\n \"tcp_connect_two_stacks_trailing_bytes.pcap\"\n Test.test_tcp_connect_two_stacks\n\nlet suite = [\n\n \"connect two stacks, basic test\", `Quick,\n test_tcp_connect_two_stacks_basic;\n\n \"connect two stacks, uniform packet loss of packets with no payload x 100\", `Slow,\n test_tcp_connect_two_stacks_x100_uniform_no_payload_packet_loss;\n\n \"connect two stacks, with trailing bytes\", `Quick,\n test_tcp_connect_two_stacks_trailing_bytes;\n\n]\n" }, { "path": "test/test_connect_ipv6.ml", "content": "(*\n * Copyright (c) 2015 Magnus Skjegstad \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Common\nopen Vnetif_common\n\nlet (>>=) = Lwt.(>>=)\n\nlet src = Logs.Src.create \"test_connect\" ~doc:\"connect tests\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nmodule Test_connect_ipv6 (B : Vnetif_backends.Backend) = struct\n module V = VNETIF_STACK (B)\n\n let client_address = Ipaddr.V6.of_string_exn \"fc00::23\"\n let client_cidr = Ipaddr.V6.Prefix.make 64 client_address\n let server_address = Ipaddr.V6.of_string_exn \"fc00::45\"\n let server_cidr = Ipaddr.V6.Prefix.make 64 server_address\n let test_string = \"Hello world from Mirage 123456789....\"\n let backend = V.create_backend ()\n\n let err_read_eof () = failf \"accept got EOF while reading\"\n let err_write_eof () = failf \"client tried to write, got EOF\"\n\n let err_read e =\n let err = Format.asprintf \"%a\" V.Stack.TCP.pp_error e in\n failf \"Error while reading: %s\" err\n\n let err_write e =\n let err = Format.asprintf \"%a\" V.Stack.TCP.pp_write_error e in\n failf \"client tried to write, got %s\" err\n\n let accept flow expected =\n let ip, port = V.Stack.TCP.dst flow in\n Log.debug (fun f -> f \"Accepted connection from %s:%d\" (Ipaddr.to_string ip) port);\n V.Stack.TCP.read flow >>= function\n | Error e -> err_read e\n | Ok `Eof -> err_read_eof ()\n | Ok (`Data b) ->\n Lwt_unix.sleep 0.1 >>= fun () ->\n (* sleep first to capture data in pcap *)\n Alcotest.(check string) \"accept\" expected (Cstruct.to_string b);\n Log.debug (fun f -> f \"Connection closed\");\n Lwt.return_unit\n\n let cidr = Ipaddr.V4.Prefix.of_string_exn \"10.0.0.2/24\"\n\n let test_tcp_connect_two_stacks () =\n let timeout = 15.0 in\n Lwt.pick [\n (Lwt_unix.sleep timeout >>= fun () ->\n failf \"connect test timedout after %f seconds\" timeout) ;\n\n (V.create_stack ~cidr ~cidr6:server_cidr backend >>= fun s1 ->\n V.Stack.TCP.listen (V.Stack.tcp s1) ~port:80 (fun f -> accept f test_string);\n V.Stack.listen s1) ;\n\n (Lwt_unix.sleep 0.1 >>= fun () ->\n V.create_stack ~cidr ~cidr6:client_cidr backend >>= fun s2 ->\n Lwt.pick [\n V.Stack.listen s2;\n (let conn = V.Stack.TCP.create_connection (V.Stack.tcp s2) in\n or_error \"connect\" conn (Ipaddr.V6 server_address, 80) >>= fun flow ->\n Log.debug (fun f -> f \"Connected to other end...\");\n\n V.Stack.TCP.write flow (Cstruct.of_string test_string) >>= function\n | Error `Closed -> err_write_eof ()\n | Error e -> err_write e\n | Ok () ->\n Log.debug (fun f -> f \"wrote hello world\");\n V.Stack.TCP.close flow >>= fun () ->\n Lwt_unix.sleep 1.0 >>= fun () -> (* record some traffic after close *)\n Lwt.return_unit)]) ] >>= fun () ->\n\n Lwt.return_unit\n\n let record_pcap =\n V.record_pcap backend\n\nend\n\nlet test_tcp_connect_two_stacks_basic () =\n let module Test = Test_connect_ipv6(Vnetif_backends.Basic) in\n Test.record_pcap\n \"tcp_connect_ipv6_two_stacks_basic.pcap\"\n Test.test_tcp_connect_two_stacks\n\nlet test_tcp_connect_two_stacks_x100_uniform_no_payload_packet_loss () =\n let rec loop = function\n | 0 -> Lwt.return_unit\n | n -> Log.info (fun f -> f \"%d/100\" (101-n));\n let module Test = Test_connect_ipv6(Vnetif_backends.Uniform_no_payload_packet_loss) in\n Test.record_pcap\n (Printf.sprintf\n \"tcp_connect_ipv6_two_stacks_no_payload_packet_loss_%d_of_100.pcap\" n)\n Test.test_tcp_connect_two_stacks >>= fun () ->\n loop (n - 1)\n in\n loop 100\n\nlet test_tcp_connect_two_stacks_trailing_bytes () =\n let module Test = Test_connect_ipv6(Vnetif_backends.Trailing_bytes) in\n Test.record_pcap\n \"tcp_connect_ipv6_two_stacks_trailing_bytes.pcap\"\n Test.test_tcp_connect_two_stacks\n\nlet suite = [\n\n \"connect two stacks, basic test\", `Quick,\n test_tcp_connect_two_stacks_basic;\n\n \"connect two stacks, uniform packet loss of packets with no payload x 100\", `Slow,\n test_tcp_connect_two_stacks_x100_uniform_no_payload_packet_loss;\n\n \"connect two stacks, with trailing bytes\", `Quick,\n test_tcp_connect_two_stacks_trailing_bytes;\n\n]\n" }, { "path": "test/test_deadlock.ml", "content": "open Lwt.Infix\n\nlet mtu = 4000\n\nlet server_log = Logs.Src.create \"test_deadlock_server\" ~doc:\"tcp deadlock tests: server\"\nmodule Server_log = (val Logs.src_log server_log : Logs.LOG)\n\nlet client_log = Logs.Src.create \"test_deadlock_client\" ~doc:\"tcp deadlock tests: client\"\nmodule Client_log = (val Logs.src_log client_log : Logs.LOG)\n\nmodule TCPIP =\nstruct\n module RANDOM = Mirage_crypto_rng\n\n module M =\n struct\n module B = Basic_backend.Make\n module NETIF = Vnetif.Make(B)\n module ETHIF = Ethernet.Make(NETIF)\n module ARPV4 = Arp.Make(ETHIF)\n module IPV4 = Static_ipv4.Make(ETHIF)(ARPV4)\n module IPV6 = Ipv6.Make(NETIF)(ETHIF)\n module IP = Tcpip_stack_direct.IPV4V6(IPV4)(IPV6)\n module ICMPV4 = Icmpv4.Make(IPV4)\n module UDP = Udp.Make(IP)\n module TCP = Tcp.Flow.Make(IP)\n module TCPIP = Tcpip_stack_direct.MakeV4V6(NETIF)(ETHIF)(ARPV4)(IP)(ICMPV4)(UDP)(TCP)\n end\n open M\n\n type stack = TCPIP.t\n\n let server_ip = Ipaddr.V4.of_string_exn \"192.168.10.10\"\n let server_cidr = Ipaddr.V4.Prefix.make 24 server_ip\n let client_ip = Ipaddr.V4.of_string_exn \"192.168.10.20\"\n let client_cidr = Ipaddr.V4.Prefix.make 24 client_ip\n\n let make ~cidr ?gateway netif =\n ETHIF.connect netif >>= fun ethif ->\n ARPV4.connect ethif >>= fun arpv4 ->\n IPV4.connect ~cidr ?gateway ethif arpv4 >>= fun ipv4 ->\n IPV6.connect netif ethif >>= fun ipv6 ->\n IP.connect ~ipv4_only:false ~ipv6_only:false ipv4 ipv6 >>= fun ip ->\n ICMPV4.connect ipv4 >>= fun icmpv4 ->\n UDP.connect ip >>= fun udp ->\n TCP.connect ip >>= fun tcp ->\n TCPIP.connect netif ethif arpv4 ip icmpv4 udp tcp >>= fun tcpip ->\n Lwt.return tcpip\n\n include TCPIP\n\n let tcpip t = t\n\n let make role netif = match role with\n | `Server -> make ~cidr:server_cidr netif\n | `Client -> make ~cidr:client_cidr netif\n\n type conn = M.NETIF.t\n\n let get_stats _t =\n { Mirage_net.rx_pkts = 0l; rx_bytes = 0L;\n tx_pkts = 0l; tx_bytes = 0L;\n }\n\n let reset_stats _t = ()\nend\n\nlet port = 10000\n\nlet test_digest netif1 netif2 =\n TCPIP.make `Client netif1 >>= fun client_stack ->\n TCPIP.make `Server netif2 >>= fun server_stack ->\n\n let send_data () =\n let data = Mirage_crypto_rng.generate 100_000_000 in\n let t0 = Unix.gettimeofday () in\n TCPIP.TCP.create_connection\n TCPIP.(tcp @@ tcpip server_stack) (Ipaddr.V4 TCPIP.client_ip, port) >>= function\n | Error _ -> failwith \"could not establish tunneled connection\"\n | Ok flow ->\n Server_log.debug (fun f -> f \"established conn\");\n let rec read_digest chunks =\n TCPIP.TCP.read flow >>= function\n | Error _ -> failwith \"read error\"\n | Ok (`Data data) -> read_digest (data :: chunks)\n | Ok `Eof ->\n Server_log.debug (fun f -> f \"EOF\");\n let dt = Unix.gettimeofday () -. t0 in\n Server_log.warn (fun f -> f \"!!!!!!!!!! XXXX needed %.2fs (%.1f MB/s)\"\n dt (float (String.length data) /. dt /. 1024. ** 2.));\n Lwt.return_unit\n in\n Lwt.pick\n [ read_digest [];\n begin\n let rec send_data data =\n if Cstruct.length data < mtu then\n (TCPIP.TCP.write flow data >>= fun _ -> Lwt.return_unit)\n else\n let sub, data = Cstruct.split data mtu in\n Lwt.pick\n [\n (TCPIP.TCP.write flow sub >>= fun _ -> Lwt.return_unit);\n (Lwt_unix.sleep 5. >>= fun () ->\n Common.failf \"=========== DEADLOCK!!! =============\");\n ]\n >>= fun () ->\n send_data data in\n send_data @@ Cstruct.of_string data >>= fun () ->\n Server_log.debug (fun f -> f \"wrote data\");\n TCPIP.TCP.close flow\n end\n ]\n in\n TCPIP.TCP.listen TCPIP.(tcp (tcpip client_stack)) ~port\n (fun flow ->\n Client_log.debug (fun f -> f \"client got conn\");\n let rec consume () =\n TCPIP.TCP.read flow >>= function\n | Error _ ->\n Client_log.debug (fun f -> f \"XXXX client read error\");\n TCPIP.TCP.close flow\n | Ok `Eof ->\n TCPIP.TCP.write flow @@ Cstruct.of_string \"thanks for all the fish\"\n >>= fun _ ->\n TCPIP.TCP.close flow\n | Ok (`Data _data) ->\n (if Random.float 1.0 < 0.01 then Lwt_unix.sleep 0.01\n else Lwt.return_unit) >>= fun () ->\n consume ()\n in\n consume ());\n Lwt.pick\n [\n send_data ();\n TCPIP.listen @@ TCPIP.tcpip server_stack;\n TCPIP.listen @@ TCPIP.tcpip client_stack;\n ]\n\nlet run_vnetif () =\n let backend = Basic_backend.Make.create\n ~use_async_readers:true ~yield:Lwt.pause () in\n TCPIP.M.NETIF.connect ~size_limit:mtu backend >>= fun c1 ->\n TCPIP.M.NETIF.connect ~size_limit:mtu backend >>= fun c2 ->\n test_digest c1 c2\n\nlet suite = [\n \"test tcp deadlock with slow receiver\", `Slow, run_vnetif\n]\n" }, { "path": "test/test_icmpv4.ml", "content": "open Common\n\nlet src = Logs.Src.create \"test_icmpv4\" ~doc:\"ICMP tests\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nmodule B = Basic_backend.Make\nmodule V = Vnetif.Make(B)\nmodule E = Ethernet.Make(V)\nmodule Static_arp = Static_arp.Make(E)\n\nopen Lwt.Infix\n\ntype decomposed = {\n ipv4_payload : Cstruct.t;\n ipv4_header : Ipv4_packet.t;\n ethernet_payload : Cstruct.t;\n ethernet_header : Ethernet.Packet.t;\n}\n\nmodule Ip = Static_ipv4.Make(E)(Static_arp)\nmodule Icmp = Icmpv4.Make(Ip)\n\nmodule Udp = Udp.Make(Ip)\n\ntype stack = {\n backend : B.t;\n netif : V.t;\n ethif : E.t;\n arp : Static_arp.t;\n ip : Ip.t;\n icmp : Icmp.t;\n udp : Udp.t;\n}\n\nlet testbind x y =\n match x with\n | Ok p -> y p\n | Error s -> Alcotest.fail s\nlet (>>=?) = testbind\n\n(* some default addresses which will be on the same class C *)\nlet listener_address = Ipaddr.V4.of_string_exn \"192.168.222.1\"\nlet speaker_address = Ipaddr.V4.of_string_exn \"192.168.222.10\"\n\nlet header_size = Ethernet.Packet.sizeof_ethernet\n\nlet get_stack ?(backend = B.create ~use_async_readers:true\n ~yield:(fun() -> Lwt.pause ()) ())\n ip =\n let cidr = Ipaddr.V4.Prefix.make 24 ip in\n V.connect backend >>= fun netif ->\n E.connect netif >>= fun ethif ->\n Static_arp.connect ethif >>= fun arp ->\n Ip.connect ~cidr ethif arp >>= fun ip ->\n Icmp.connect ip >>= fun icmp ->\n Udp.connect ip >>= fun udp ->\n Lwt.return { backend; netif; ethif; arp; ip; icmp; udp }\n\nlet icmp_listen stack fn =\n let noop = fun ~src:_ ~dst:_ _buf -> Lwt.return_unit in\n V.listen stack.netif ~header_size (* some buffer -> (unit, error) result io *)\n ( E.input stack.ethif ~arpv4:(Static_arp.input stack.arp)\n ~ipv6:(fun _ -> Lwt.return_unit)\n ~ipv4:\n ( Ip.input stack.ip\n ~tcp:noop ~udp:noop\n ~default:(fun ~proto -> match proto with | 1 -> fn | _ -> noop))) >|= fun _ -> ()\n\n\nlet inform_arp stack = Static_arp.add_entry stack.arp\nlet mac_of_stack stack = E.mac stack.ethif\n\nlet short_read () =\n let too_short = Cstruct.create 4 in\n match Icmpv4_packet.Unmarshal.of_cstruct too_short with\n | Ok (icmp, _) ->\n Alcotest.fail (Format.asprintf \"processed something too short to be real: %a produced %a\"\n\t\t Cstruct.hexdump_pp too_short Icmpv4_packet.pp icmp)\n | Error str -> Printf.printf \"short packet rejected successfully! msg: %s\\n\" str;\n Lwt.return_unit\n\nlet echo_request () =\n let seq_no = 0x01 in\n let id_no = 0x1234 in\n let request_payload = Cstruct.of_string \"plz reply i'm so lonely\" in\n get_stack speaker_address >>= fun speaker ->\n get_stack ~backend:speaker.backend listener_address >>= fun listener ->\n inform_arp speaker listener_address (mac_of_stack listener);\n inform_arp listener speaker_address (mac_of_stack speaker);\n let req = Icmpv4_packet.({code = 0x00; ty = Icmpv4_wire.Echo_request;\n subheader = Id_and_seq (id_no, seq_no)}) in\n let echo_request = Cstruct.create 2048 in\n Icmpv4_packet.Marshal.into_cstruct req echo_request ~payload:request_payload >>=? fun () ->\n Cstruct.blit request_payload 0 echo_request (Icmpv4_wire.sizeof_icmpv4) (Cstruct.length request_payload);\n let echo_request = Cstruct.sub echo_request 0 (Icmpv4_wire.sizeof_icmpv4 + Cstruct.length request_payload) in\n let check buf =\n let open Icmpv4_packet in\n Log.debug (fun f -> f \"Incoming ICMP message: %a\" Cstruct.hexdump_pp buf);\n Cstruct.hexdump buf;\n Unmarshal.of_cstruct buf >>=? fun (reply, payload) ->\n match reply.subheader with\n | Next_hop_mtu _ | Pointer _ | Address _ | Unused ->\n Alcotest.fail \"received an ICMP message which wasn't an echo-request or reply\"\n | Id_and_seq (id, seq) ->\n Alcotest.(check int) \"icmp response type\" 0x00 (Icmpv4_wire.ty_to_int reply.ty); (* expect an icmp echo reply *)\n Alcotest.(check int) \"icmp echo-reply code\" 0x00 reply.code; (* should be code 0 *)\n Alcotest.(check int) \"icmp echo-reply id\" id_no id;\n Alcotest.(check int) \"icmp echo-reply seq\" seq_no seq;\n Alcotest.(check cstruct) \"icmp echo-reply payload\" payload request_payload;\n Lwt.return_unit\n in\n Lwt.async (fun () -> Lwt.pick [\n icmp_listen listener (fun ~src ~dst buf ->\n Logs.debug (fun f -> f \"listener's ICMP listener invoked\");\n Icmp.input listener.icmp ~src ~dst buf);\n icmp_listen speaker (fun ~src:_ ~dst:_ -> check)\n ]);\n Icmp.write speaker.icmp ~dst:listener_address echo_request >>= function\n | Error e -> Alcotest.failf \"ICMP echo request write: %a\" Icmp.pp_error e\n | Ok () -> Lwt.return_unit\n\nlet echo_silent () =\n let open Icmpv4_packet in\n get_stack speaker_address >>= fun speaker ->\n get_stack ~backend:speaker.backend listener_address >>= fun listener ->\n let req = ({code = 0x00; ty = Icmpv4_wire.Echo_request;\n\t subheader = Id_and_seq (0xff, 0x4341)}) in\n let echo_request = Marshal.make_cstruct req ~payload:Cstruct.(create 0) in\n let check buf =\n Unmarshal.of_cstruct buf >>=? fun (message, _) ->\n match message.ty with\n | Icmpv4_wire.Echo_reply ->\n Alcotest.fail \"received an ICMP echo reply even though we shouldn't have\"\n | msg_ty ->\n Printf.printf \"received an unexpected ICMP message (type %s); ignoring it\"\n (Icmpv4_wire.ty_to_string msg_ty);\n Lwt.return_unit\n in\n let nobody_home = Ipaddr.V4.of_string_exn \"192.168.222.90\" in\n inform_arp speaker listener_address (mac_of_stack listener);\n inform_arp listener speaker_address (mac_of_stack speaker);\n (* set up an ARP mapping so the listener is more likely to see the echo-request *)\n inform_arp speaker nobody_home (mac_of_stack listener);\n Lwt.async (fun () ->\n Lwt.pick [\n icmp_listen listener (fun ~src ~dst buf -> Icmp.input listener.icmp ~src ~dst buf);\n icmp_listen speaker (fun ~src:_ ~dst:_ -> check);\n ]);\n Icmp.write speaker.icmp ~dst:nobody_home echo_request >>= function\n | Error e -> Alcotest.failf \"ICMP echo request write: %a\" Icmp.pp_error e\n | Ok () -> Lwt.return_unit\n\nlet write_errors () =\n let decompose buf =\n let open Ethernet.Packet in\n let* ethernet_header, ethernet_payload = of_cstruct buf in\n match ethernet_header.ethertype with\n | `IPv6 | `ARP -> Error \"not an ipv4 packet\"\n | `IPv4 ->\n let* ipv4_header, ipv4_payload =\n Ipv4_packet.Unmarshal.of_cstruct ethernet_payload\n in\n Ok { ethernet_header; ethernet_payload; ipv4_header; ipv4_payload }\n in\n (* for any incoming packet, reject it with would_fragment *)\n let reject_all stack =\n let reject buf =\n match decompose buf with\n | Error s -> Alcotest.fail s\n | Ok decomposed ->\n let reply = Icmpv4_packet.({\n ty = Icmpv4_wire.Destination_unreachable;\n code = Icmpv4_wire.(unreachable_reason_to_int Would_fragment);\n subheader = Next_hop_mtu 576;\n }) in\n let header = Icmpv4_packet.Marshal.make_cstruct reply\n ~payload:decomposed.ethernet_payload in\n let header_and_payload = Cstruct.concat ([header ; decomposed.ethernet_payload]) in\n let open Ipv4_packet in\n Icmp.write stack.icmp ~dst:decomposed.ipv4_header.src header_and_payload >|= Result.get_ok\n in\n V.listen stack.netif ~header_size reject >|= fun _ -> ()\n in\n let check_packet buf : unit Lwt.t =\n let aux buf =\n let open Icmpv4_packet in\n let* icmp, icmp_payload = Unmarshal.of_cstruct buf in\n Alcotest.check Alcotest.int \"ICMP message type\" 0x03 (Icmpv4_wire.ty_to_int icmp.ty);\n Alcotest.check Alcotest.int \"ICMP message code\" 0x04 icmp.code;\n match Cstruct.length icmp_payload with\n | 0 -> Alcotest.fail \"Error message should've had a payload\"\n | _n ->\n (* TODO: packet should have an IP header in it *)\n Alcotest.(check int) \"Payload first byte\" 0x45 (Cstruct.get_uint8 icmp_payload 0);\n Ok ()\n in\n match aux buf with\n | Error s -> Alcotest.fail s\n | Ok () -> Lwt.return_unit\n in\n let check_rejection stack dst =\n let payload = Cstruct.of_string \"!@#$\" in\n Lwt.pick [\n icmp_listen stack (fun ~src:_ ~dst:_ buf -> check_packet buf >>= fun () ->\n V.disconnect stack.netif);\n Mirage_sleep.ns (Duration.of_ms 500) >>= fun () ->\n Udp.write stack.udp ~dst ~src_port:1212 ~dst_port:123 payload\n >|= Result.get_ok >>= fun () ->\n Mirage_sleep.ns (Duration.of_sec 1) >>= fun () ->\n Alcotest.fail \"writing thread completed first\";\n ]\n in\n get_stack speaker_address >>= fun speaker ->\n get_stack ~backend:speaker.backend listener_address >>= fun listener ->\n inform_arp speaker listener_address (mac_of_stack listener);\n inform_arp listener speaker_address (mac_of_stack speaker);\n Lwt.pick [\n reject_all listener;\n check_rejection speaker listener_address;\n ]\n\nlet suite = [\n \"short read\", `Quick, short_read;\n \"echo requests elicit an echo reply\", `Quick, echo_request;\n \"echo requests for other ips don't elicit an echo reply\", `Quick, echo_silent;\n \"error messages are written\", `Quick, write_errors;\n]\n" }, { "path": "test/test_iperf.ml", "content": "(*\n * Copyright (c) 2011 Richard Mortier \n * Copyright (c) 2012 Balraj Singh \n * Copyright (c) 2015 Magnus Skjegstad \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Common\nopen Vnetif_common\nopen Lwt.Infix\n\nmodule Test_iperf (B : Vnetif_backends.Backend) = struct\n\n module V = VNETIF_STACK (B)\n\n let gateway = Ipaddr.V4.of_string_exn \"10.0.0.1\"\n let client_cidr = Ipaddr.V4.Prefix.of_string_exn \"10.0.0.101/24\"\n let server_cidr = Ipaddr.V4.Prefix.of_string_exn \"10.0.0.100/24\"\n\n type stats = {\n mutable bytes: int64;\n mutable packets: int64;\n mutable bin_bytes:int64;\n mutable bin_packets: int64;\n mutable start_time: int64;\n mutable last_time: int64;\n }\n\n type network = {\n backend : B.t;\n server : V.Stack.t;\n client : V.Stack.t;\n }\n\n let default_network ?mtu ?(backend = B.create ()) () =\n V.create_stack ?mtu ~cidr:client_cidr ~gateway backend >>= fun client ->\n V.create_stack ?mtu ~cidr:server_cidr ~gateway backend >>= fun server ->\n Lwt.return {backend; server; client}\n\n let msg =\n let m = \"01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\" in\n let rec build l = function\n | 0 -> l\n | n -> build (m :: l) (n - 1)\n in\n String.concat \"\" @@ build [] 60\n\n let mlen = String.length msg\n\n let err_eof () = failf \"EOF while writing to TCP flow\"\n\n let err_connect e ip port () =\n let err = Format.asprintf \"%a\" V.Stack.TCP.pp_error e in\n let ip = Ipaddr.to_string ip in\n failf \"Unable to connect to %s:%d: %s\" ip port err\n\n let err_write e () =\n let err = Format.asprintf \"%a\" V.Stack.TCP.pp_write_error e in\n failf \"Error while writing to TCP flow: %s\" err\n\n let err_read e () =\n let err = Format.asprintf \"%a\" V.Stack.TCP.pp_error e in\n failf \"Error in server while reading: %s\" err\n\n let write_and_check flow buf =\n V.Stack.TCP.write flow buf >>= function\n | Ok () -> Lwt.return_unit\n | Error `Closed -> V.Stack.TCP.close flow >>= err_eof\n | Error e -> V.Stack.TCP.close flow >>= err_write e\n\n let tcp_connect t (ip, port) =\n V.Stack.TCP.create_connection t (ip, port) >>= function\n | Error e -> err_connect e ip port ()\n | Ok f -> Lwt.return f\n\n let iperfclient s amt dest_ip dport =\n let iperftx flow =\n Logs.info (fun f -> f \"Iperf client: Made connection to server.\");\n let a = Cstruct.create mlen in\n Cstruct.blit_from_string msg 0 a 0 mlen;\n let rec loop = function\n | 0 -> Lwt.return_unit\n | n -> write_and_check flow a >>= fun () -> loop (n-1)\n in\n loop (amt / mlen) >>= fun () ->\n let a = Cstruct.sub a 0 (amt - (mlen * (amt/mlen))) in\n write_and_check flow a >>= fun () ->\n V.Stack.TCP.close flow\n in\n Logs.info (fun f -> f \"Iperf client: Attempting connection.\");\n tcp_connect (V.Stack.tcp s) (dest_ip, dport) >>= fun flow ->\n iperftx flow >>= fun () ->\n Logs.debug (fun f -> f \"Iperf client: Done.\");\n Lwt.return_unit\n\n let print_data st ts_now =\n let server = Int64.sub ts_now st.start_time in\n let rate_in_mbps =\n let t_in_s = Int64.(to_float (sub ts_now st.last_time)) /. 1_000_000_000. in\n (Int64.to_float st.bin_bytes) /. t_in_s /. 125000.\n in\n let live_words = Gc.((stat()).live_words) in\n Logs.info (fun f -> f \"Iperf server: t = %.0Lu, avg_rate = %0.2f MBits/s, totbytes = %Ld, \\\n live_words = %d\" server rate_in_mbps st.bytes live_words);\n st.last_time <- ts_now;\n st.bin_bytes <- 0L;\n st.bin_packets <- 0L;\n Lwt.return_unit\n\n let iperf _s server_done_u flow =\n (* debug is too much for us here *)\n Logs.set_level ~all:true (Some Logs.Info);\n Logs.info (fun f -> f \"Iperf server: Received connection.\");\n let t0 = Mirage_mtime.elapsed_ns () in\n let st = {\n bytes=0L; packets=0L; bin_bytes=0L; bin_packets=0L; start_time = t0;\n last_time = t0\n } in\n let rec iperf_h flow =\n V.Stack.TCP.read flow >|= Result.get_ok >>= function\n | `Eof ->\n let ts_now = Mirage_mtime.elapsed_ns () in\n st.bin_bytes <- st.bytes;\n st.bin_packets <- st.packets;\n st.last_time <- st.start_time;\n print_data st ts_now >>= fun () ->\n V.Stack.TCP.close flow >>= fun () ->\n Logs.info (fun f -> f \"Iperf server: Done - closed connection.\");\n Lwt.return_unit\n | `Data data ->\n begin\n let l = Cstruct.length data in\n st.bytes <- (Int64.add st.bytes (Int64.of_int l));\n st.packets <- (Int64.add st.packets 1L);\n st.bin_bytes <- (Int64.add st.bin_bytes (Int64.of_int l));\n st.bin_packets <- (Int64.add st.bin_packets 1L);\n let ts_now = Mirage_mtime.elapsed_ns () in\n (if (Int64.sub ts_now st.last_time >= 1_000_000_000L) then\n print_data st ts_now\n else\n Lwt.return_unit) >>= fun () ->\n iperf_h flow\n end\n in\n iperf_h flow >>= fun () ->\n Lwt.wakeup server_done_u ();\n Lwt.return_unit\n\n let tcp_iperf ~server ~client amt timeout () =\n let port = 5001 in\n\n let server_ready, server_ready_u = Lwt.wait () in\n let server_done, server_done_u = Lwt.wait () in\n let server_s, client_s = server, client in\n\n let ip_of s =\n V.Stack.ip s |> V.Stack.IP.configured_ips |>\n List.filter (function Ipaddr.V4 _ -> true | Ipaddr.V6 _ -> false) |>\n List.hd |> Ipaddr.Prefix.address\n in\n\n Lwt.pick [\n (Lwt_unix.sleep timeout >>= fun () -> (* timeout *)\n failf \"iperf test timed out after %f seconds\" timeout);\n\n (server_ready >>= fun () ->\n Lwt_unix.sleep 0.1 >>= fun () -> (* Give server 0.1 s to call listen *)\n Logs.info (fun f -> f \"I am client with IP %a, trying to connect to server @ %a:%d\"\n Ipaddr.pp (ip_of client_s) Ipaddr.pp (ip_of server_s) port);\n Lwt.async (fun () -> V.Stack.listen client_s);\n iperfclient client_s amt (ip_of server) port);\n\n (Logs.info (fun f -> f \"I am server with IP %a, expecting connections on port %d\"\n V.Stack.IP.pp_prefix (V.Stack.IP.configured_ips (V.Stack.ip server_s) |> List.hd)\n port);\n V.Stack.TCP.listen (V.Stack.tcp server_s) ~port (iperf server_s server_done_u);\n Lwt.wakeup server_ready_u ();\n V.Stack.listen server_s) ] >>= fun () ->\n\n Logs.info (fun f -> f \"Waiting for server_done...\");\n server_done >>= fun () ->\n Lwt.return_unit (* exit cleanly *)\nend\n\nlet test_tcp_iperf_two_stacks_basic amt timeout () =\n let module Test = Test_iperf (Vnetif_backends.Basic) in\n Test.default_network () >>= fun { backend; Test.client; Test.server } ->\n Test.V.record_pcap backend\n (Printf.sprintf \"tcp_iperf_two_stacks_basic_%d.pcap\" amt)\n (Test.tcp_iperf ~server ~client amt timeout)\n\nlet test_tcp_iperf_two_stacks_mtu amt timeout () =\n let mtu = 1500 in\n let module Test = Test_iperf (Vnetif_backends.Frame_size_enforced) in\n let backend = Vnetif_backends.Frame_size_enforced.create () in\n Vnetif_backends.Frame_size_enforced.set_max_ip_mtu backend mtu;\n Test.default_network ?mtu:(Some mtu) ?backend:(Some backend) () >>= fun { backend; Test.client; Test.server } ->\n Test.V.record_pcap backend\n (Printf.sprintf \"tcp_iperf_two_stacks_mtu_%d.pcap\" amt)\n (Test.tcp_iperf ~server ~client amt timeout)\n\nlet test_tcp_iperf_two_stacks_trailing_bytes amt timeout () =\n let module Test = Test_iperf (Vnetif_backends.Trailing_bytes) in\n Test.default_network () >>= fun { backend; Test.client; Test.server } ->\n Test.V.record_pcap backend\n (Printf.sprintf \"tcp_iperf_two_stacks_trailing_bytes_%d.pcap\" amt)\n (Test.tcp_iperf ~server ~client amt timeout)\n\nlet test_tcp_iperf_two_stacks_uniform_packet_loss amt timeout () =\n let module Test = Test_iperf (Vnetif_backends.Uniform_packet_loss) in\n Test.default_network () >>= fun { backend; Test.client; Test.server } ->\n Test.V.record_pcap backend\n (Printf.sprintf \"tcp_iperf_two_stacks_uniform_packet_loss_%d.pcap\" amt)\n (Test.tcp_iperf ~server ~client amt timeout)\n\nlet test_tcp_iperf_two_stacks_uniform_packet_loss_no_payload amt timeout () =\n let module Test = Test_iperf (Vnetif_backends.Uniform_no_payload_packet_loss) in\n Test.default_network () >>= fun { backend; Test.client; Test.server } ->\n Test.V.record_pcap backend\n (Printf.sprintf \"tcp_iperf_two_stacks_uniform_packet_loss_no_payload_%d.pcap\" amt)\n (Test.tcp_iperf ~server ~client amt timeout)\n\nlet test_tcp_iperf_two_stacks_drop_1sec_after_1mb amt timeout () =\n let module Test = Test_iperf (Vnetif_backends.Drop_1_second_after_1_megabyte) in\n Test.default_network () >>= fun { backend; Test.client; Test.server } ->\n Test.V.record_pcap backend\n \"tcp_iperf_two_stacks_drop_1sec_after_1mb.pcap\"\n (Test.tcp_iperf ~server ~client amt timeout)\n\nlet amt_quick = 100_000\nlet amt_slow = amt_quick * 1000\n\nlet suite = [\n\n \"iperf with two stacks, basic tests\", `Quick,\n test_tcp_iperf_two_stacks_basic amt_quick 120.0;\n\n \"iperf with two stacks, over an MTU-enforcing backend\", `Quick,\n test_tcp_iperf_two_stacks_mtu amt_quick 120.0;\n\n \"iperf with two stacks, testing trailing_bytes\", `Quick,\n test_tcp_iperf_two_stacks_trailing_bytes amt_quick 120.0;\n\n \"iperf with two stacks and uniform packet loss\", `Quick,\n test_tcp_iperf_two_stacks_uniform_packet_loss amt_quick 120.0;\n\n \"iperf with two stacks and uniform packet loss of packets with no payload\", `Quick,\n test_tcp_iperf_two_stacks_uniform_packet_loss_no_payload amt_quick 240.0;\n\n \"iperf with two stacks and uniform packet loss of packets with no payload, longer\", `Slow,\n test_tcp_iperf_two_stacks_uniform_packet_loss_no_payload amt_slow 240.0;\n\n \"iperf with two stacks, basic tests, longer\", `Slow,\n test_tcp_iperf_two_stacks_basic amt_slow 240.0;\n\n \"iperf with two stacks and uniform packet loss, longer\", `Slow,\n test_tcp_iperf_two_stacks_uniform_packet_loss amt_slow 240.0;\n\n \"iperf with two stacks drop 1 sec after 1 mb\", `Quick,\n test_tcp_iperf_two_stacks_drop_1sec_after_1mb amt_quick 120.0;\n\n]\n" }, { "path": "test/test_iperf_ipv6.ml", "content": "(*\n * Copyright (c) 2011 Richard Mortier \n * Copyright (c) 2012 Balraj Singh \n * Copyright (c) 2015 Magnus Skjegstad \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Common\nopen Vnetif_common\nopen Lwt.Infix\n\nmodule Test_iperf_ipv6 (B : Vnetif_backends.Backend) = struct\n\n module V = VNETIF_STACK (B)\n\n let client_ip = Ipaddr.V6.of_string_exn \"fc00::23\"\n let client_cidr = Ipaddr.V6.Prefix.make 64 client_ip\n let server_ip = Ipaddr.V6.of_string_exn \"fc00::45\"\n let server_cidr = Ipaddr.V6.Prefix.make 64 server_ip\n\n type stats = {\n mutable bytes: int64;\n mutable packets: int64;\n mutable bin_bytes:int64;\n mutable bin_packets: int64;\n mutable start_time: int64;\n mutable last_time: int64;\n }\n\n type network = {\n backend : B.t;\n server : V.Stack.t;\n client : V.Stack.t;\n }\n\n let cidr = Ipaddr.V4.Prefix.of_string_exn \"10.0.0.2/24\"\n\n let default_network ?mtu ?(backend = B.create ()) () =\n V.create_stack ?mtu ~cidr ~cidr6:client_cidr backend >>= fun client ->\n V.create_stack ?mtu ~cidr ~cidr6:server_cidr backend >>= fun server ->\n Lwt.return {backend; server; client}\n\n let msg =\n let m = \"01234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\" in\n let rec build l = function\n | 0 -> l\n | n -> build (m :: l) (n - 1)\n in\n String.concat \"\" @@ build [] 60\n\n let mlen = String.length msg\n\n let err_eof () = failf \"EOF while writing to TCP flow\"\n\n let err_connect e ip port () =\n let err = Format.asprintf \"%a\" V.Stack.TCP.pp_error e in\n let ip = Ipaddr.to_string ip in\n failf \"Unable to connect to %s:%d: %s\" ip port err\n\n let err_write e () =\n let err = Format.asprintf \"%a\" V.Stack.TCP.pp_write_error e in\n failf \"Error while writing to TCP flow: %s\" err\n\n let err_read e () =\n let err = Format.asprintf \"%a\" V.Stack.TCP.pp_error e in\n failf \"Error in server while reading: %s\" err\n\n let write_and_check flow buf =\n V.Stack.TCP.write flow buf >>= function\n | Ok () -> Lwt.return_unit\n | Error `Closed -> V.Stack.TCP.close flow >>= err_eof\n | Error e -> V.Stack.TCP.close flow >>= err_write e\n\n let tcp_connect t (ip, port) =\n V.Stack.TCP.create_connection t (ip, port) >>= function\n | Error e -> err_connect e ip port ()\n | Ok f -> Lwt.return f\n\n let iperfclient s amt dest_ip dport =\n let iperftx flow =\n Logs.info (fun f -> f \"Iperf client: Made connection to server.\");\n let a = Cstruct.create mlen in\n Cstruct.blit_from_string msg 0 a 0 mlen;\n let rec loop = function\n | 0 -> Lwt.return_unit\n | n -> write_and_check flow a >>= fun () -> loop (n-1)\n in\n loop (amt / mlen) >>= fun () ->\n let a = Cstruct.sub a 0 (amt - (mlen * (amt/mlen))) in\n write_and_check flow a >>= fun () ->\n V.Stack.TCP.close flow\n in\n Logs.info (fun f -> f \"Iperf client: Attempting connection.\");\n tcp_connect (V.Stack.tcp s) (dest_ip, dport) >>= fun flow ->\n iperftx flow >>= fun () ->\n Logs.debug (fun f -> f \"Iperf client: Done.\");\n Lwt.return_unit\n\n let print_data st ts_now =\n let server = Int64.sub ts_now st.start_time in\n let rate_in_mbps =\n let t_in_s = Int64.(to_float (sub ts_now st.last_time)) /. 1_000_000_000. in\n (Int64.to_float st.bin_bytes) /. t_in_s /. 125000.\n in\n let live_words = Gc.((stat()).live_words) in\n Logs.info (fun f -> f \"Iperf server: t = %.0Lu, avg_rate = %0.2f MBits/s, totbytes = %Ld, \\\n live_words = %d\" server rate_in_mbps st.bytes live_words);\n st.last_time <- ts_now;\n st.bin_bytes <- 0L;\n st.bin_packets <- 0L;\n Lwt.return_unit\n\n let iperf _s server_done_u flow =\n (* debug is too much for us here *)\n Logs.set_level ~all:true (Some Logs.Info);\n Logs.info (fun f -> f \"Iperf server: Received connection.\");\n let t0 = Mirage_mtime.elapsed_ns () in\n let st = {\n bytes=0L; packets=0L; bin_bytes=0L; bin_packets=0L; start_time = t0;\n last_time = t0\n } in\n let rec iperf_h flow =\n V.Stack.TCP.read flow >|= Result.get_ok >>= function\n | `Eof ->\n let ts_now = Mirage_mtime.elapsed_ns () in\n st.bin_bytes <- st.bytes;\n st.bin_packets <- st.packets;\n st.last_time <- st.start_time;\n print_data st ts_now >>= fun () ->\n V.Stack.TCP.close flow >>= fun () ->\n Logs.info (fun f -> f \"Iperf server: Done - closed connection.\");\n Lwt.return_unit\n | `Data data ->\n begin\n let l = Cstruct.length data in\n st.bytes <- (Int64.add st.bytes (Int64.of_int l));\n st.packets <- (Int64.add st.packets 1L);\n st.bin_bytes <- (Int64.add st.bin_bytes (Int64.of_int l));\n st.bin_packets <- (Int64.add st.bin_packets 1L);\n let ts_now = Mirage_mtime.elapsed_ns () in\n (if (Int64.sub ts_now st.last_time >= 1_000_000_000L) then\n print_data st ts_now\n else\n Lwt.return_unit) >>= fun () ->\n iperf_h flow\n end\n in\n iperf_h flow >>= fun () ->\n Lwt.wakeup server_done_u ();\n Lwt.return_unit\n\n let tcp_iperf ~server ~client amt timeout () =\n let port = 5001 in\n\n let server_ready, server_ready_u = Lwt.wait () in\n let server_done, server_done_u = Lwt.wait () in\n let server_s, client_s = server, client in\n\n let ip_of s =\n V.Stack.ip s |> V.Stack.IP.configured_ips |>\n List.filter (function Ipaddr.V4 _ -> false | Ipaddr.V6 _ -> true) |>\n List.rev |> List.hd |> Ipaddr.Prefix.address\n in\n\n Lwt.pick [\n (Lwt_unix.sleep timeout >>= fun () -> (* timeout *)\n failf \"iperf test timed out after %f seconds\" timeout);\n\n (server_ready >>= fun () ->\n Lwt_unix.sleep 0.1 >>= fun () -> (* Give server 0.1 s to call listen *)\n Logs.info (fun f -> f \"I am client with IP %a, trying to connect to server @ %a:%d\"\n Ipaddr.pp (ip_of client_s) Ipaddr.pp (ip_of server_s) port);\n Lwt.async (fun () -> V.Stack.listen client_s);\n iperfclient client_s amt (ip_of server) port);\n\n (Logs.info (fun f -> f \"I am server with IP %a, expecting connections on port %d\"\n V.Stack.IP.pp_prefix (V.Stack.IP.configured_ips (V.Stack.ip server_s) |> List.hd)\n port);\n V.Stack.TCP.listen (V.Stack.tcp server_s) ~port (iperf server_s server_done_u);\n Lwt.wakeup server_ready_u ();\n V.Stack.listen server_s) ] >>= fun () ->\n\n Logs.info (fun f -> f \"Waiting for server_done...\");\n server_done >>= fun () ->\n Lwt.return_unit (* exit cleanly *)\nend\n\nlet test_tcp_iperf_ipv6_two_stacks_basic amt timeout () =\n let module Test = Test_iperf_ipv6 (Vnetif_backends.Basic) in\n Test.default_network () >>= fun { backend; Test.client; Test.server } ->\n Test.V.record_pcap backend\n (Printf.sprintf \"tcp_iperf_ipv6_two_stacks_basic_%d.pcap\" amt)\n (Test.tcp_iperf ~server ~client amt timeout)\n\nlet test_tcp_iperf_ipv6_two_stacks_mtu amt timeout () =\n let mtu = 1500 in\n let module Test = Test_iperf_ipv6 (Vnetif_backends.Frame_size_enforced) in\n let backend = Vnetif_backends.Frame_size_enforced.create () in\n Vnetif_backends.Frame_size_enforced.set_max_ip_mtu backend mtu;\n Test.default_network ?mtu:(Some mtu) ?backend:(Some backend) () >>= fun { backend; Test.client; Test.server } ->\n Test.V.record_pcap backend\n (Printf.sprintf \"tcp_iperf_ipv6_two_stacks_mtu_%d.pcap\" amt)\n (Test.tcp_iperf ~server ~client amt timeout)\n\nlet test_tcp_iperf_ipv6_two_stacks_trailing_bytes amt timeout () =\n let module Test = Test_iperf_ipv6 (Vnetif_backends.Trailing_bytes) in\n Test.default_network () >>= fun { backend; Test.client; Test.server } ->\n Test.V.record_pcap backend\n (Printf.sprintf \"tcp_iperf_ipv6_two_stacks_trailing_bytes_%d.pcap\" amt)\n (Test.tcp_iperf ~server ~client amt timeout)\n\nlet test_tcp_iperf_ipv6_two_stacks_uniform_packet_loss amt timeout () =\n let module Test = Test_iperf_ipv6 (Vnetif_backends.Uniform_packet_loss) in\n Test.default_network () >>= fun { backend; Test.client; Test.server } ->\n Test.V.record_pcap backend\n (Printf.sprintf \"tcp_iperf_ipv6_two_stacks_uniform_packet_loss_%d.pcap\" amt)\n (Test.tcp_iperf ~server ~client amt timeout)\n\nlet test_tcp_iperf_ipv6_two_stacks_uniform_packet_loss_no_payload amt timeout () =\n let module Test = Test_iperf_ipv6 (Vnetif_backends.Uniform_no_payload_packet_loss) in\n Test.default_network () >>= fun { backend; Test.client; Test.server } ->\n Test.V.record_pcap backend\n (Printf.sprintf \"tcp_iperf_ipv6_two_stacks_uniform_packet_loss_no_payload_%d.pcap\" amt)\n (Test.tcp_iperf ~server ~client amt timeout)\n\nlet test_tcp_iperf_ipv6_two_stacks_drop_1sec_after_1mb amt timeout () =\n let module Test = Test_iperf_ipv6 (Vnetif_backends.Drop_1_second_after_1_megabyte) in\n Test.default_network () >>= fun { backend; Test.client; Test.server } ->\n Test.V.record_pcap backend\n \"tcp_iperf_ipv6_two_stacks_drop_1sec_after_1mb.pcap\"\n (Test.tcp_iperf ~server ~client amt timeout)\n\nlet amt_quick = 100_000\nlet amt_slow = amt_quick * 1000\n\nlet suite = [\n\n \"iperf with two stacks, basic tests\", `Quick,\n test_tcp_iperf_ipv6_two_stacks_basic amt_quick 120.0;\n\n \"iperf with two stacks, over an MTU-enforcing backend\", `Quick,\n test_tcp_iperf_ipv6_two_stacks_mtu amt_quick 120.0;\n\n \"iperf with two stacks, testing trailing_bytes\", `Quick,\n test_tcp_iperf_ipv6_two_stacks_trailing_bytes amt_quick 120.0;\n\n \"iperf with two stacks and uniform packet loss\", `Quick,\n test_tcp_iperf_ipv6_two_stacks_uniform_packet_loss amt_quick 120.0;\n\n \"iperf with two stacks and uniform packet loss of packets with no payload\", `Slow,\n test_tcp_iperf_ipv6_two_stacks_uniform_packet_loss_no_payload amt_quick 240.0;\n\n \"iperf with two stacks and uniform packet loss of packets with no payload, longer\", `Slow,\n test_tcp_iperf_ipv6_two_stacks_uniform_packet_loss_no_payload amt_slow 240.0;\n\n \"iperf with two stacks, basic tests, longer\", `Slow,\n test_tcp_iperf_ipv6_two_stacks_basic amt_slow 240.0;\n\n \"iperf with two stacks and uniform packet loss, longer\", `Slow,\n test_tcp_iperf_ipv6_two_stacks_uniform_packet_loss amt_slow 240.0;\n\n \"iperf with two stacks drop 1 sec after 1 mb\", `Quick,\n test_tcp_iperf_ipv6_two_stacks_drop_1sec_after_1mb amt_quick 120.0;\n\n]\n" }, { "path": "test/test_ipv4.ml", "content": "open Common\n\nlet test_unmarshal_with_options () =\n let datagram = Cstruct.create 40 in\n Cstruct.blit_from_string (\"\\x46\\xc0\\x00\\x28\\x00\\x00\\x40\\x00\\x01\\x02\" ^\n \"\\x42\\x49\\xc0\\xa8\\x01\\x08\\xe0\\x00\\x00\\x16\\x94\\x04\\x00\\x00\\x22\" ^\n \"\\x00\\xfa\\x02\\x00\\x00\\x00\\x01\\x03\\x00\\x00\\x00\\xe0\\x00\\x00\\xfb\") 0 datagram 0 40;\n match Ipv4_packet.Unmarshal.of_cstruct datagram with\n | Ok ({Ipv4_packet.options ; _}, payload) ->\n Alcotest.(check int) \"options\" (Cstruct.length options) 4;\n Alcotest.(check int) \"payload\" (Cstruct.length payload) 16;\n Lwt.return_unit\n | _ ->\n Alcotest.fail \"Fail to parse ip packet with options\"\n\n\nlet test_unmarshal_without_options () =\n let datagram = Cstruct.create 40 in\n Cstruct.blit_from_string (\"\\x45\\x00\\x00\\x28\\x19\\x29\\x40\\x00\\x34\\x06\\x98\\x75\\x36\\xb7\" ^\n \"\\x9c\\xca\\xc0\\xa8\\x01\\x08\\x00\\x50\\xca\\xa6\\x6f\\x19\\xf4\\x76\" ^\n \"\\x00\\x00\\x00\\x00\\x50\\x04\\x00\\x00\\xec\\x27\\x00\\x00\") 0 datagram 0 40;\n match Ipv4_packet.Unmarshal.of_cstruct datagram with\n | Ok ({Ipv4_packet.options ; _}, payload) ->\n Alcotest.(check int) \"options\" (Cstruct.length options) 0;\n Alcotest.(check int) \"payload\" (Cstruct.length payload) 20;\n Lwt.return_unit\n | _ ->\n Alcotest.fail \"Fail to parse ip packet with options\"\n\nlet test_unmarshal_regression () =\n let p = Cstruct.of_string \"\\x49\\x30\\x30\\x30\\x30\\x30\\x30\\x30\\x30\\x30\\x30\\x30\\x30\\x30\\x30\\x30\\x30\\x30\\x30\\x30\" in\n Alcotest.(check (result reject pass))\n \"correctly return error for bad packet\"\n (Error \"any\") (Ipv4_packet.Unmarshal.of_cstruct p);\n Lwt.return_unit\n\nlet test_size () =\n let src = Ipaddr.V4.of_string_exn \"127.0.0.1\" in\n let dst = Ipaddr.V4.of_string_exn \"127.0.0.2\" in\n let ttl = 64 in\n let ip = { Ipv4_packet.src; dst; proto = 17; ttl; id = 0 ; off = 0 ; options = (Cstruct.of_string \"aaaa\") } in\n let payload = Cstruct.of_string \"abcdefgh\" in\n let tmp = Ipv4_packet.Marshal.make_cstruct ~payload_len:(Cstruct.length payload) ip in\n let tmp = Cstruct.concat [tmp; payload] in\n Ipv4_packet.Unmarshal.of_cstruct tmp\n |> Alcotest.(check (result (pair ipv4_packet cstruct) string)) \"Loading an IP packet with IP options\" (Ok (ip, payload));\n Lwt.return_unit\n\nlet test_packet =\n let src = Ipaddr.V4.of_string_exn \"127.0.0.1\" in\n let dst = Ipaddr.V4.of_string_exn \"127.0.0.2\" in\n let ttl = 64 in\n { Ipv4_packet.src; dst; proto = 17; ttl; id = 0 ; off = 0 ; options = (Cstruct.of_string \"aaaa\") }\n\nlet mf = 0x2000\n\nlet white = Cstruct.create 16\nlet black =\n let buf = Cstruct.create 16 in\n Cstruct.memset buf 0xFF ;\n buf\nlet gray =\n let buf = Cstruct.create 16 in\n Cstruct.memset buf 0x55 ;\n buf\n\nlet empty_cache = Fragments.Cache.empty 1000\n\nlet basic_fragments payload () =\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__\n (Some (test_packet, payload))\n (snd @@ Fragments.process empty_cache 0L test_packet payload)) ;\n let off_packet = { test_packet with off = 1 } in\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__\n None\n (snd @@ Fragments.process empty_cache 0L off_packet payload)) ;\n Lwt.return_unit\n\nlet basic_reassembly () =\n let more_frags = { test_packet with off = mf } in\n let cache, res = Fragments.process empty_cache 0L more_frags black in\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;\n let off_packet = { test_packet with off = 2 } in\n Alcotest.(check (option (pair ipv4_packet cstruct)) \"reassembly of two segments works\"\n (Some (test_packet, Cstruct.append black white))\n (snd @@ Fragments.process cache 0L off_packet white)) ;\n Lwt.return_unit\n\nlet basic_reassembly_timeout () =\n let more_frags = { test_packet with off = mf } in\n let cache, res = Fragments.process empty_cache 0L more_frags black in\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;\n let off_packet = { test_packet with off = 2 } in\n let below_max = Int64.sub Fragments.max_duration 1L in\n Alcotest.(check (option (pair ipv4_packet cstruct)) \"even after just before max duration\"\n (Some (test_packet, Cstruct.append black white))\n (snd @@ Fragments.process cache below_max off_packet white)) ;\n Alcotest.(check (option (pair ipv4_packet cstruct)) \"none after max duration\"\n None\n (snd @@ Fragments.process cache Fragments.max_duration off_packet white)) ;\n let more_off_packet = { test_packet with off = mf lor 2 } in\n let cache, res = Fragments.process cache below_max more_off_packet gray in\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;\n let final_packet = { test_packet with off = 4 } in\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__\n (Some (test_packet, Cstruct.concat [ black; gray; white]))\n (snd @@ Fragments.process cache below_max final_packet white)) ;\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__\n None\n (snd @@ Fragments.process cache Fragments.max_duration off_packet white)) ;\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;\n Lwt.return_unit\n\nlet reassembly_out_of_order () =\n let more_frags = { test_packet with off = mf } in\n let off_packet = { test_packet with off = 2 } in\n let cache, res = Fragments.process empty_cache 0L off_packet gray in\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;\n Alcotest.(check (option (pair ipv4_packet cstruct)) \"reassembly of two segments works\"\n (Some (test_packet, Cstruct.append black gray))\n (snd @@ Fragments.process cache 0L more_frags black)) ;\n Lwt.return_unit\n\nlet reassembly_multiple_out_of_order packets final_payload () =\n let _, res = List.fold_left (fun (cache, res) (off, payload) ->\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;\n let packet = { test_packet with off } in\n Fragments.process cache 0L packet payload)\n (empty_cache, None) packets\n in\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__\n (Some (test_packet, final_payload))\n res) ;\n Lwt.return_unit\n\nlet basic_overlaps () =\n let more_frags = { test_packet with off = mf } in\n let off_packet = { test_packet with off = 1 } in\n let cache, res = Fragments.process empty_cache 0L off_packet black in\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None\n (snd @@ Fragments.process cache 0L more_frags white)) ;\n Lwt.return_unit\n\nlet basic_other_ip_flow () =\n let more_frags = { test_packet with off = mf } in\n let cache, res = Fragments.process empty_cache 0L more_frags black in\n let off_packet = { test_packet with off = 2 ; src = Ipaddr.V4.of_string_exn \"127.0.0.2\" } in\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None\n (snd @@ Fragments.process cache 0L off_packet white)) ;\n let off_packet' = { test_packet with off = 2 ; proto = 25 } in\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None\n (snd @@ Fragments.process cache 0L off_packet' white)) ;\n Lwt.return_unit\n\nlet max_fragment () =\n let all_16 = [ white; gray; black; white;\n white; gray; black; white;\n white; gray; black; white;\n white; gray; black ; gray ]\n in\n let (cache, res), off =\n List.fold_left (fun ((cache, res), off) payload ->\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;\n let r = Fragments.process cache 0L { test_packet with off = off lor mf } payload in\n (r, Cstruct.length payload / 8 + off))\n ((empty_cache, None), 0)\n all_16\n in\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__\n (Some (test_packet, Cstruct.concat (all_16 @ [white ])))\n (snd @@ Fragments.process cache 0L { test_packet with off } white)) ;\n let cache, res = Fragments.process cache 0L { test_packet with off = off lor mf } white in\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__\n None\n (snd @@ Fragments.process cache 0L { test_packet with off = off + 2 } black)) ;\n Lwt.return_unit\n\nlet none_returned packets () =\n let _, res = List.fold_left (fun (cache, res) (off, payload) ->\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;\n let packet = { test_packet with off } in\n Fragments.process cache 0L packet payload)\n (empty_cache, None) packets\n in\n Alcotest.(check (option (pair ipv4_packet cstruct)) __LOC__ None res) ;\n Lwt.return_unit\n\nlet ins_all_positions x l =\n let rec aux prev acc = function\n | [] -> List.rev ((prev @ [x]) :: acc)\n | hd::tl as l -> aux (prev @ [hd]) ((prev @ [x] @ l) :: acc) tl\n in\n aux [] [] l\n\nlet rec permutations = function\n | [] -> []\n | [x] -> [[x]]\n | x::xs -> List.fold_left (fun acc p -> acc @ ins_all_positions x p ) []\n (permutations xs)\n\nlet fragment_simple () =\n let hdr =\n { Ipv4_packet.src = Ipaddr.V4.localhost ; dst = Ipaddr.V4.localhost ;\n id = 0x42 ; off = 0 ; ttl = 10 ; proto = 10 ; options = Cstruct.empty }\n in\n let payload = Cstruct.create 1030 in\n let fs = Fragments.fragment ~mtu:36 hdr payload in\n (* 16 byte per packet -> 64 fragments (a 16 byte) + 1 (6 byte) *)\n Alcotest.(check int __LOC__ 65 (List.length fs));\n let second, last = List.hd fs, List.(hd (rev fs)) in\n Alcotest.(check int __LOC__ 26 (Cstruct.length last));\n match\n Ipv4_packet.Unmarshal.of_cstruct second,\n Ipv4_packet.Unmarshal.of_cstruct last\n with\n | Error e, _ -> Alcotest.fail (\"failed to decode second fragment \" ^ e)\n | _, Error e -> Alcotest.fail (\"failed to decode last fragment \" ^ e)\n | Ok (hdr, _payload), Ok (hdr', _payload') ->\n Alcotest.(check int __LOC__ (0x2000 lor 2) hdr.Ipv4_packet.off);\n Alcotest.(check int __LOC__ 0x42 hdr.Ipv4_packet.id);\n Alcotest.(check int __LOC__ 130 hdr'.Ipv4_packet.off);\n Alcotest.(check int __LOC__ 0x42 hdr'.Ipv4_packet.id);\n let fs' = Fragments.fragment ~mtu:36 hdr (Cstruct.sub payload 0 1024) in\n (* 16 byte per packet -> 64 fragments (a 16 byte) *)\n Alcotest.(check int __LOC__ 64 (List.length fs'));\n let second', last' = List.hd fs', List.(hd (rev fs')) in\n Alcotest.(check int __LOC__ 36 (Cstruct.length last'));\n match\n Ipv4_packet.Unmarshal.of_cstruct second',\n Ipv4_packet.Unmarshal.of_cstruct last'\n with\n | Error e, _ -> Alcotest.fail (\"failed to decode second fragment' \" ^ e)\n | _, Error e -> Alcotest.fail (\"failed to decode last fragment' \" ^ e)\n | Ok (hdr'', _payload''), Ok (hdr''', _payload''') ->\n Alcotest.(check int __LOC__ (0x2000 lor 2) hdr''.Ipv4_packet.off);\n Alcotest.(check int __LOC__ 0x42 hdr''.Ipv4_packet.id);\n Alcotest.(check int __LOC__ 128 hdr'''.Ipv4_packet.off);\n Alcotest.(check int __LOC__ 0x42 hdr'''.Ipv4_packet.id)\n\nlet suite = [\n \"unmarshal ip datagram with options\", `Quick, test_unmarshal_with_options;\n \"unmarshal ip datagram without options\", `Quick, test_unmarshal_without_options;\n \"unmarshal ip datagram with no payload & hlen > 5\", `Quick, test_unmarshal_regression;\n \"size\", `Quick, test_size ] @\n List.mapi (fun i size ->\n Printf.sprintf \"basic fragment %d: payload %d\" i size, `Quick, basic_fragments (Cstruct.create size))\n [ 0 ; 1 ; 2 ; 10 ; 100 ; 1000 ; 5000 ; 10000 ] @ [\n \"basic reassembly\", `Quick, basic_reassembly;\n \"basic reassembly timeout\", `Quick, basic_reassembly_timeout;\n \"reassembly out of order\", `Quick, reassembly_out_of_order ;\n \"other ip flow\", `Quick, basic_other_ip_flow ;\n \"maximum amount of fragments\", `Quick, max_fragment ] @\n List.mapi (fun i (packets, final) ->\n Printf.sprintf \"reassembly multiple %d\" i, `Quick,\n reassembly_multiple_out_of_order packets final)\n ([\n ([ (mf, white); (2, black) ], Cstruct.concat [white;black]);\n ([ (mf, black); (2, white) ], Cstruct.concat [black;white]);\n ([ (2, black); (mf, white) ], Cstruct.concat [white;black]);\n ([ (2, white); (mf, black) ], Cstruct.concat [black;white]);\n ([ (mf, Cstruct.create 984); (123, black)], Cstruct.concat [Cstruct.create 984;black]);\n ([ (mf, Cstruct.create 984); (123 lor mf, black); (125, gray)],\n Cstruct.concat [Cstruct.create 984;black;gray]);\n ([ (mf, Cstruct.create 1000); (125, (Cstruct.concat [black;black;black]))],\n Cstruct.concat [Cstruct.create 1000;black;black;black]);\n ]@\n List.map (fun x -> (x, Cstruct.concat [gray;white;black]))\n (permutations [ (mf, gray); (2 lor mf, white); (4, black)]) @\n List.map (fun x -> (x, Cstruct.concat [gray;white;black;Cstruct.create 10]))\n (permutations [ (mf, gray); (2 lor mf, white); (4 lor mf, black); (6, Cstruct.create 10)]) @\n List.map (fun x -> (x, Cstruct.concat [black;gray;white;black;gray]))\n (permutations [ (mf, black); (2 lor mf, gray); (4 lor mf, white); (6 lor mf, black); (8, gray)])\n ) @\n [ \"nothing returned\", `Quick, basic_overlaps ] @\n List.mapi (fun i packets ->\n Printf.sprintf \"nothing returned %d\" i, `Quick,\n none_returned packets)\n ([\n [ (mf, white); (1, black) ];\n [ (mf, black); (3, white) ];\n [ (mf, Cstruct.create 992); (124 lor mf, black);(126, gray)];\n [ (mf, Cstruct.create 1024); (128, black)];\n ] @\n permutations [ (mf, gray); (2 lor mf, white); (3, black)] @\n permutations [ (mf, gray); (2 lor mf, white); (5, black)] @\n permutations [ (mf, gray); (3 lor mf, white); (4, black)] @\n permutations [ (mf, gray); (3 lor mf, white); (5, black)] @\n permutations [ (mf, gray); (1 lor mf, white); (3, black)] @\n permutations [ (mf, gray); (1 lor mf, white); (4, black)] @\n permutations [ (mf, (Cstruct.append gray gray)); (3 lor mf, white)] @\n permutations [ (mf, (Cstruct.append gray gray)); (2 lor mf, white)] @\n permutations [ (mf, gray); (2 lor mf, white); (4 lor mf, black); (6 lor mf, gray)] @\n permutations [ (mf, gray); (2 lor mf, white); (4 lor mf, black); (5, gray)] @\n permutations [ (mf, gray); (4 lor mf, white); (4 lor mf, black); (6, gray)] @\n permutations [ (mf, gray); (1 lor mf, white); (3 lor mf, black); (5, gray)] @\n permutations [ (mf, gray); (2 lor mf, white); (4 lor mf, black); (7, gray)]\n ) @ [\n \"simple fragment\", `Quick, (fun () -> Lwt.return (fragment_simple ()))\n ]\n" }, { "path": "test/test_ipv6.ml", "content": "open Common\nmodule B = Vnetif_backends.Basic\nmodule V = Vnetif.Make(B)\nmodule E = Ethernet.Make(V)\n\nmodule Ipv6 = Ipv6.Make(V)(E)\nmodule Udp = Udp.Make(Ipv6)\nopen Lwt.Infix\n\nlet ip =\n let module M = struct\n type t = Ipaddr.V6.t\n let pp = Ipaddr.V6.pp\n let equal p q = (Ipaddr.V6.compare p q) = 0\n end in\n (module M : Alcotest.TESTABLE with type t = M.t)\n\ntype stack = {\n backend : B.t;\n netif : V.t;\n ethif : E.t;\n ip : Ipv6.t;\n udp : Udp.t\n}\n\nlet get_stack backend address =\n let cidr = Ipaddr.V6.Prefix.make 64 address in\n V.connect backend >>= fun netif ->\n E.connect netif >>= fun ethif ->\n Ipv6.connect ~cidr netif ethif >>= fun ip ->\n Udp.connect ip >>= fun udp ->\n Lwt.return { backend; netif; ethif; ip; udp }\n\nlet noop = fun ~src:_ ~dst:_ _ -> Lwt.return_unit\n\nlet listen ?(tcp = noop) ?(udp = noop) ?(default = noop) stack =\n V.listen stack.netif ~header_size:Ethernet.Packet.sizeof_ethernet\n ( E.input stack.ethif\n ~arpv4:(fun _ -> Lwt.return_unit)\n ~ipv4:(fun _ -> Lwt.return_unit)\n ~ipv6:(\n Ipv6.input stack.ip\n ~tcp:tcp\n ~udp:udp\n ~default:(fun ~proto:_ -> default))) >>= fun _ -> Lwt.return_unit\n\nlet udp_message = Cstruct.of_string \"hello on UDP over IPv6\"\n\nlet check_for_one_udp_packet on_received_one ~src ~dst buf =\n (match Udp_packet.Unmarshal.of_cstruct buf with\n | Ok (_, payload) ->\n Alcotest.(check ip) \"sender address\" (Ipaddr.V6.of_string_exn \"fc00::23\") src;\n Alcotest.(check ip) \"receiver address\" (Ipaddr.V6.of_string_exn \"fc00::45\") dst;\n Alcotest.(check cstruct) \"payload is correct\" udp_message payload\n | Error m -> Alcotest.fail m);\n (try Lwt.wakeup_later on_received_one () with _ -> () (* the first succeeds, the rest raise *));\n Lwt.return_unit\n\nlet send_forever sender receiver_address udp_message =\n let rec loop () =\n Udp.write sender.udp ~dst:receiver_address ~dst_port:1234 udp_message\n >|= Result.get_ok >>= fun () ->\n Mirage_sleep.ns (Duration.of_ms 50) >>= fun () ->\n loop () in\n loop ()\n\nlet pass_udp_traffic () =\n let sender_address = Ipaddr.V6.of_string_exn \"fc00::23\" in\n let receiver_address = Ipaddr.V6.of_string_exn \"fc00::45\" in\n let backend = B.create () in\n get_stack backend sender_address >>= fun sender ->\n get_stack backend receiver_address >>= fun receiver ->\n let received_one, on_received_one = Lwt.task () in\n Lwt.pick [\n listen receiver ~udp:(check_for_one_udp_packet on_received_one);\n listen sender;\n send_forever sender receiver_address udp_message;\n received_one; (* stop on the first packet *)\n Mirage_sleep.ns (Duration.of_ms 3000) >>= fun () ->\n Alcotest.fail \"UDP packet should have been received\";\n ]\n\nlet create_ethernet backend =\n V.connect backend >>= fun netif ->\n E.connect netif >|= fun ethif ->\n (fun ipv6 ->\n V.listen netif ~header_size:Ethernet.Packet.sizeof_ethernet\n (E.input ethif\n ~arpv4:(fun _ -> Lwt.return_unit)\n ~ipv4:(fun _ -> Lwt.return_unit)\n ~ipv6) >|= fun _ -> ()),\n (fun dst ?size f -> E.write ethif dst `IPv6 ?size f),\n E.mac ethif\n\nlet solicited_node_prefix =\n Ipaddr.V6.(Prefix.make 104 (of_int16 (0xff02, 0, 0, 0, 0, 1, 0xff00, 0)))\n\nlet dad_na_is_sent () =\n let address = Ipaddr.V6.of_string_exn \"fc00::23\" in\n let backend = B.create () in\n get_stack backend address >>= fun stack ->\n create_ethernet backend >>= fun (listen_raw, write_raw, _) ->\n let received_one, on_received_one = Lwt.task () in\n let nd_size = Ipv6_wire.sizeof_ipv6 + Ipv6_wire.Ns.sizeof_ns in\n let nd buf =\n Ipv6_wire.set_version_flow buf 0x60000000l; (* IPv6 *)\n Ipv6_wire.set_len buf Ipv6_wire.Ns.sizeof_ns;\n Ipaddr_cstruct.V6.write_cstruct_exn Ipaddr.V6.unspecified (Cstruct.shift buf 8);\n Ipaddr_cstruct.V6.write_cstruct_exn (Ipaddr.V6.Prefix.network_address solicited_node_prefix address) (Cstruct.shift buf 24);\n Ipv6_wire.set_hlim buf 255;\n Ipv6_wire.set_nhdr buf (Ipv6_wire.protocol_to_int `ICMP);\n let hdr, icmpbuf = Cstruct.split buf Ipv6_wire.sizeof_ipv6 in\n Ipv6_wire.set_ty icmpbuf 135; (* NS *)\n Ipv6_wire.set_code icmpbuf 0;\n Ipv6_wire.Ns.set_reserved icmpbuf 0l;\n Ipaddr_cstruct.V6.write_cstruct_exn address (Cstruct.shift icmpbuf 8);\n Ipv6_wire.Icmpv6.set_checksum icmpbuf 0;\n Ipv6_wire.Icmpv6.set_checksum icmpbuf @@ Ndpv6.checksum hdr [icmpbuf];\n nd_size\n and is_na buf =\n let icmpbuf = Cstruct.shift buf Ipv6_wire.sizeof_ipv6 in\n Ipv6_wire.get_version_flow buf = 0x60000000l && (* IPv6 *)\n Ipaddr.V6.compare\n (Ipaddr_cstruct.V6.of_cstruct_exn (Cstruct.shift buf 8))\n address = 0 &&\n Ipaddr.V6.compare\n (Ipaddr_cstruct.V6.of_cstruct_exn (Cstruct.shift buf 24))\n Ipaddr.V6.link_nodes = 0 &&\n Ipv6_wire.get_hlim buf = 255 &&\n Ipv6_wire.get_nhdr buf = Ipv6_wire.protocol_to_int `ICMP &&\n Ipv6_wire.get_ty icmpbuf = 136 &&\n Ipv6_wire.get_code icmpbuf = 0 &&\n Ipaddr.V6.compare\n (Ipaddr_cstruct.V6.of_cstruct_exn (Cstruct.shift icmpbuf 8))\n address = 0\n in\n Lwt.pick [\n listen stack;\n listen_raw (fun buf ->\n if is_na buf then\n Lwt.wakeup_later on_received_one ();\n Lwt.return_unit);\n (write_raw (E.mac stack.ethif) ~size:nd_size nd >|= fun _ -> ());\n received_one;\n (Mirage_sleep.ns (Duration.of_ms 1000) >>= fun () ->\n Alcotest.fail \"NA packet should have been received\")\n ]\n\nlet multicast_mac =\n let pbuf = Cstruct.create 6 in\n Cstruct.BE.set_uint16 pbuf 0 0x3333;\n fun ip ->\n let _, _, _, n = Ipaddr.V6.to_int32 ip in\n Cstruct.BE.set_uint32 pbuf 2 n;\n Macaddr_cstruct.of_cstruct_exn pbuf\n\nlet dad_na_is_received () =\n let address = Ipaddr.V6.of_string_exn \"fc00::23\" in\n let backend = B.create () in\n create_ethernet backend >>= fun (listen_raw, write_raw, mac) ->\n let na_size = Ipv6_wire.sizeof_ipv6 + Ipv6_wire.Na.sizeof_na + Ipv6_wire.Llopt.sizeof_llopt in\n let is_ns buf =\n let icmpbuf = Cstruct.shift buf Ipv6_wire.sizeof_ipv6 in\n if\n Ipv6_wire.get_version_flow buf = 0x60000000l && (* IPv6 *)\n Ipaddr.V6.compare\n (Ipaddr_cstruct.V6.of_cstruct_exn (Cstruct.shift buf 8))\n Ipaddr.V6.unspecified = 0 &&\n Ipaddr.V6.Prefix.mem\n (Ipaddr_cstruct.V6.of_cstruct_exn (Cstruct.shift buf 24))\n solicited_node_prefix &&\n Ipv6_wire.get_hlim buf = 255 &&\n Ipv6_wire.get_nhdr buf = Ipv6_wire.protocol_to_int `ICMP &&\n Ipv6_wire.get_ty icmpbuf = 135 &&\n Ipv6_wire.get_code icmpbuf = 0\n then\n Some (Ipaddr_cstruct.V6.of_cstruct_exn (Cstruct.shift icmpbuf 8))\n else\n None\n in\n let na addr buf =\n Ipv6_wire.set_version_flow buf 0x60000000l; (* IPv6 *)\n Ipv6_wire.set_len buf (Ipv6_wire.Na.sizeof_na + Ipv6_wire.Llopt.sizeof_llopt);\n Ipaddr_cstruct.V6.write_cstruct_exn addr (Cstruct.shift buf 8);\n Ipaddr_cstruct.V6.write_cstruct_exn Ipaddr.V6.link_nodes (Cstruct.shift buf 24);\n Ipv6_wire.set_hlim buf 255;\n Ipv6_wire.set_nhdr buf (Ipv6_wire.protocol_to_int `ICMP);\n let hdr, icmpbuf = Cstruct.split buf Ipv6_wire.sizeof_ipv6 in\n Ipv6_wire.set_ty icmpbuf 136; (* NA *)\n Ipv6_wire.set_code icmpbuf 0;\n Ipv6_wire.Na.set_reserved icmpbuf 0x20000000l;\n Ipaddr_cstruct.V6.write_cstruct_exn addr (Cstruct.shift icmpbuf 8);\n let optbuf = Cstruct.shift icmpbuf Ipv6_wire.Na.sizeof_na in\n Ipv6_wire.set_ty optbuf 2;\n Ipv6_wire.Llopt.set_len optbuf 1;\n Macaddr_cstruct.write_cstruct_exn mac (Cstruct.shift optbuf 2);\n Ipv6_wire.Icmpv6.set_checksum icmpbuf 0;\n Ipv6_wire.Icmpv6.set_checksum icmpbuf @@ Ndpv6.checksum hdr [icmpbuf];\n na_size\n in\n Lwt.pick [\n (listen_raw (fun buf ->\n match is_ns buf with\n | None -> Lwt.return_unit\n | Some addr ->\n let dst = multicast_mac Ipaddr.V6.link_nodes in\n write_raw dst ~size:na_size (na addr) >|= fun _ -> ()));\n (Lwt.catch\n (fun () -> get_stack backend address >|= fun _ -> Error ())\n (fun _ -> Lwt.return (Ok ())) >|= function\n | Ok () -> ()\n | Error () -> Alcotest.fail \"Expected stack initialization failure\");\n (Mirage_sleep.ns (Duration.of_ms 5000) >>= fun () ->\n Alcotest.fail \"stack initialization should have failed\")\n ]\n\nlet suite = [\n \"Send a UDP packet from one IPV6 stack and check it is received by another\", `Quick, pass_udp_traffic;\n \"NA is sent when a ND is received\", `Quick, dad_na_is_sent;\n \"NA is received, stack fails to initialise\", `Quick, dad_na_is_received;\n]\n" }, { "path": "test/test_keepalive.ml", "content": "(* Test the functional part *)\n\n(* Linux default *)\nlet default = Tcpip.Tcp.Keepalive.({\n after = Duration.of_sec 7200; (* 2 hours *)\n interval = Duration.of_sec 75; (* 75 seconds *)\n probes = 9;\n})\n\nlet simulate configuration iterations nprobes ns state =\n let rec loop iterations nprobes ns state =\n if iterations > 3 * configuration.Tcpip.Tcp.Keepalive.probes\n then Alcotest.fail (Printf.sprintf \"too many iteractions: loop in keep-alive test? iterations = %d nprobes = %d ns=%Ld\" iterations nprobes ns);\n let action, state' = Tcp.Keepalive.next ~configuration ~ns state in\n match action with\n | `SendProbe ->\n Logs.info (fun f -> f \"iteration %d, ns %Ld: SendProbe\" iterations ns);\n loop (iterations + 1) (nprobes + 1) ns state'\n | `Wait ns' ->\n Logs.info (fun f -> f \"iteration %d, ns %Ld: Wait %Ld\" iterations ns ns');\n loop (iterations + 1) nprobes (Int64.add ns ns') state'\n | `Close ->\n Logs.info (fun f -> f \"iteration %d, ns %Ld: Close\" iterations ns);\n nprobes in\n loop iterations nprobes ns state\n\n(* check we send the expected number of probes if everything does as expected *)\nlet test_keepalive_sequence () =\n let configuration = default in\n let state = Tcp.Keepalive.alive in\n let nprobes = simulate configuration 0 0 0L state in\n Alcotest.(check int) \"number of probes\" (configuration.probes) nprobes\n\n(* check what happens if we miss a probe *)\nlet test_keepalive_miss_probes () =\n let configuration = default in\n let state = Tcp.Keepalive.alive in\n (* skip sending the first 1 or 2 probes *)\n let ns = Int64.(add configuration.Tcpip.Tcp.Keepalive.after (mul 2L configuration.Tcpip.Tcp.Keepalive.interval)) in\n let nprobes = simulate configuration 0 0 ns state in\n if nprobes >= configuration.Tcpip.Tcp.Keepalive.probes\n then Alcotest.fail (Printf.sprintf \"too many probes: max was %d but we sent %d and we should have skipped the first 1 or 2\" configuration.probes nprobes)\n\n(* check what happens if we exceed the maximum timeout *)\nlet test_keepalive_miss_everything () =\n let configuration = default in\n let state = Tcp.Keepalive.alive in\n (* massive delay *)\n let ns = Int64.(add configuration.Tcpip.Tcp.Keepalive.after (mul 2L (mul (of_int configuration.Tcpip.Tcp.Keepalive.probes) configuration.Tcpip.Tcp.Keepalive.interval))) in\n let nprobes = simulate configuration 0 0 ns state in\n if nprobes <> 0\n then Alcotest.fail (Printf.sprintf \"too many probes: max was %d but we sent %d and we should have skipped all\" configuration.probes nprobes)\n\nlet suite_1 = [\n \"correct number of keepalives\", `Quick, test_keepalive_sequence;\n \"we don't try to send old keepalives\", `Quick, test_keepalive_miss_probes;\n \"check we close if we miss all probes\", `Slow, test_keepalive_miss_everything;\n]\n\nlet suite_1 =\n List.map (fun (n, s, f) -> n, s, (fun () -> Lwt.return (f ()))) suite_1\n\n(* Test the end-to-end protocol behaviour *)\nopen Common\nopen Vnetif_common\n\nlet (>>=) = Lwt.(>>=)\n\nlet src = Logs.Src.create \"test_keepalive\" ~doc:\"keepalive tests\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\n(* Establish a TCP connection, enable keepalives on the connection, tell the network\n to drop all packets and check that the keep-alives detect the failure. *)\nmodule Test_connect = struct\n module V = VNETIF_STACK (Vnetif_backends.On_off_switch)\n\n let gateway = Ipaddr.V4.of_string_exn \"10.0.0.1\"\n let client_cidr = Ipaddr.V4.Prefix.of_string_exn \"10.0.0.101/24\"\n let server_cidr = Ipaddr.V4.Prefix.of_string_exn \"10.0.0.100/24\"\n let backend = V.create_backend ()\n\n let err_read_eof () = failf \"accept got EOF while reading\"\n let err_write_eof () = failf \"client tried to write, got EOF\"\n\n let err_read e =\n let err = Format.asprintf \"%a\" V.Stack.TCP.pp_error e in\n failf \"Error while reading: %s\" err\n\n let accept flow =\n let ip, port = V.Stack.TCP.dst flow in\n Logs.debug (fun f -> f \"Accepted connection from %s:%d\" (Ipaddr.to_string ip) port);\n V.Stack.TCP.read flow >>= function\n | Error e -> err_read e\n | Ok `Eof -> Lwt.return_unit\n | Ok (`Data _) -> failf \"accept: expected to get EOF in read, but got data\"\n\n let test_tcp_keepalive_timeout () =\n let timeout = 15.0 in\n Lwt.pick [\n (Lwt_unix.sleep timeout >>= fun () ->\n failf \"connect test timedout after %f seconds\" timeout) ;\n\n (V.create_stack ~cidr:server_cidr ~gateway backend >>= fun s1 ->\n V.Stack.TCP.listen (V.Stack.tcp s1) ~port:80 (fun f -> accept f);\n V.Stack.listen s1) ;\n\n (Lwt_unix.sleep 0.1 >>= fun () ->\n V.create_stack ~cidr:client_cidr ~gateway backend >>= fun s2 ->\n Lwt.pick [\n V.Stack.listen s2;\n let keepalive = { Tcpip.Tcp.Keepalive.after = 0L; interval = Duration.of_sec 1; probes = 3 } in\n (let conn = V.Stack.TCP.create_connection ~keepalive (V.Stack.tcp s2) in\n or_error \"connect\" conn (Ipaddr.V4 (Ipaddr.V4.Prefix.address server_cidr), 80) >>= fun flow ->\n Logs.debug (fun f -> f \"Connected to other end...\");\n Vnetif_backends.On_off_switch.send_packets := false;\n V.Stack.TCP.read flow >>= function\n | Error e -> err_read e\n | Ok (`Data _) -> failf \"read: expected to get EOF, but got data\"\n | Ok `Eof ->\n Logs.debug (fun f -> f \"connection read EOF as expected\");\n V.Stack.TCP.close flow >>= fun () ->\n Lwt_unix.sleep 1.0 >>= fun () -> (* record some traffic after close *)\n Lwt.return_unit)]) ] >>= fun () ->\n\n Lwt.return_unit\n\n let record_pcap =\n V.record_pcap backend\n\nend\n\nlet test_tcp_keepalive_timeout () =\n Test_connect.record_pcap\n \"test_tcp_keepalive_timeout.pcap\"\n Test_connect.test_tcp_keepalive_timeout\n\nlet suite_2 = [\n \"check that TCP keepalives detect a network failure\", `Slow,\n test_tcp_keepalive_timeout;\n]\n\nlet suite = suite_1 @ suite_2\n" }, { "path": "test/test_mtus.ml", "content": "open Lwt.Infix\n\nlet server_cidr = Ipaddr.V4.Prefix.of_string_exn \"192.168.1.254/24\"\nlet client_cidr = Ipaddr.V4.Prefix.of_string_exn \"192.168.1.10/24\"\n\nlet server_port = 7\n\nmodule Backend = Vnetif_backends.Frame_size_enforced\nmodule Stack = Vnetif_common.VNETIF_STACK(Backend)\n\nlet default_mtu = 1500\n\nlet err_fail e =\n let err = Format.asprintf \"%a\" Stack.Stack.TCP.pp_error e in\n Alcotest.fail err\n\nlet write_err_fail e =\n let err = Format.asprintf \"%a\" Stack.Stack.TCP.pp_write_error e in\n Alcotest.fail err\n\nlet rec read_all flow so_far =\n Stack.Stack.TCP.read flow >>= function\n | Error e -> err_fail e\n | Ok `Eof -> Lwt.return @@ List.rev so_far\n | Ok (`Data s) -> read_all flow (s :: so_far)\n\nlet read_one flow =\n Stack.Stack.TCP.read flow >>= function\n | Error e -> err_fail e\n | Ok `Eof -> Alcotest.fail \"received EOF when we expected at least some data from read\"\n | Ok (`Data s) -> Lwt.return s\n\nlet get_stacks ?client_mtu ?server_mtu backend =\n let or_default = function | None -> default_mtu | Some n -> n in\n let client_mtu, server_mtu = or_default client_mtu, or_default server_mtu in\n Stack.create_stack ~cidr:client_cidr ~mtu:client_mtu backend >>= fun client ->\n Stack.create_stack ~cidr:server_cidr ~mtu:server_mtu backend >>= fun server ->\n let max_mtu = max client_mtu server_mtu in\n Backend.set_max_ip_mtu backend max_mtu;\n Lwt.return (server, client)\n\nlet start_server ~f server =\n Stack.Stack.TCP.listen (Stack.Stack.tcp server) ~port:server_port f;\n Stack.Stack.listen server\n\nlet start_client client =\n Stack.Stack.TCP.create_connection (Stack.Stack.tcp client) (Ipaddr.V4 (Ipaddr.V4.Prefix.address server_cidr), server_port) >>= function\n | Ok connection -> Lwt.return connection\n | Error e -> err_fail e\n\nlet connect () =\n let backend = Backend.create () in\n get_stacks ~server_mtu:9000 backend >>= fun (server, client) ->\n Lwt.async (fun () -> start_server ~f:(fun _ -> Lwt.return_unit) server);\n start_client client >>= fun flow ->\n Stack.Stack.TCP.close flow\n\nlet big_server_response () =\n let response = Cstruct.create 7000 in\n Cstruct.memset response 255;\n let backend = Backend.create () in\n get_stacks ~client_mtu:1500 ~server_mtu:9000 backend >>= fun (server, client) ->\n let f flow =\n Stack.Stack.TCP.write flow response >>= function\n | Error e -> write_err_fail e\n | Ok () -> Stack.Stack.TCP.close flow\n in\n Lwt.async (fun () -> start_server ~f server);\n start_client client >>= fun flow -> read_all flow [] >>= fun l ->\n Alcotest.(check int) \"received size matches sent size\" (Cstruct.length response) (Cstruct.length (Cstruct.concat l));\n Stack.Stack.TCP.close flow\n\nlet big_client_request_chunked () =\n let request = Cstruct.create 3750 in\n Cstruct.memset request 255;\n let backend = Backend.create () in\n get_stacks ~client_mtu:1500 ~server_mtu:9000 backend >>= fun (server, client) ->\n let f flow =\n Stack.Stack.TCP.write flow request >>= function\n | Error e -> write_err_fail e\n | Ok () -> Stack.Stack.TCP.close flow\n in\n Lwt.async (fun () -> start_server ~f:(fun _flow -> Lwt.return_unit) server);\n start_client client >>= f\n\nlet big_server_response_not_chunked () =\n let response = Cstruct.create 7000 in\n Cstruct.memset response 255;\n let backend = Backend.create () in\n get_stacks ~client_mtu:9000 ~server_mtu:9000 backend >>= fun (server, client) ->\n let f flow =\n Stack.Stack.TCP.write flow response >>= function\n | Error e -> write_err_fail e\n | Ok () -> Stack.Stack.TCP.close flow\n in\n Lwt.async (fun () -> start_server ~f server);\n start_client client >>= fun flow -> read_one flow >>= fun buf ->\n Alcotest.(check int) \"received size matches sent size\" (Cstruct.length response) (Cstruct.length buf);\n Stack.Stack.TCP.close flow\n\nlet long_comms amt timeout () =\n (* use the iperf tests to test long-running communication between\n * the two stacks with their different link settings.\n * this helps us find bugs in situations like the TCP window expanding\n * to be larger than the MTU, and the implementation failing to\n * limit the size of the sent packet in that case. *)\n let module Test = Test_iperf.Test_iperf(Backend) in\n let backend = Backend.create () in\n get_stacks ~client_mtu:1500 ~server_mtu:9000 backend >>= fun (server, client) ->\n Test.V.record_pcap backend\n (Printf.sprintf \"tcp_mtus_long_comms_%d.pcap\" amt)\n (Test.tcp_iperf ~server ~client amt timeout)\n\nlet suite = [\n \"connections work\", `Quick, connect;\n \"large server responses are received\", `Quick, big_server_response;\n \"large client requests are chunked properly\", `Quick, big_client_request_chunked;\n \"large messages aren't unnecessarily segmented\", `Quick, big_server_response_not_chunked;\n \"iperf test doesn't crash\", `Quick, long_comms Test_iperf.amt_quick 120.0;\n]\n" }, { "path": "test/test_rfc5961.ml", "content": "(*\n * Copyright (c) 2016 Pablo Polvorin \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\nopen Common\nopen Lwt.Infix\n\nopen Low_level\n\n(* Test scenarios *)\n\n\n(* Common sut: able to connect, connection not reset, no data received *)\nlet sut_connects_and_remains_connected stack fail_callback =\n let conn = VNETIF_STACK.Stack.TCP.create_connection (VNETIF_STACK.Stack.tcp stack) in\n or_error \"connect\" conn (Ipaddr.V4 server_ip, 80) >>= fun flow ->\n (* We must remain blocked on read, connection shouldn't be terminated.\n * If after half second that remains true, assume test succeeds *)\n Lwt.pick [\n (VNETIF_STACK.Stack.TCP.read flow >>= fail_result_not_expected fail_callback);\n Mirage_sleep.ns (Duration.of_ms 500) ]\n\n\nlet blind_rst_on_syn_scenario =\n let fsm ip state ~src ~dst data =\n match state with\n | `WAIT_FOR_SYN ->\n let syn = Tcp_wire.get_syn data in\n if syn then (\n let id = reply_id_from ~src ~dst data in\n (* This -blind- reset must be ignored because of invalid ack. *)\n WIRE.xmit ~ip id ~rst:true ~rx_ack:(ack_from_past data 1)\n ~seq:(Sequence.of_int32 0l) ~window ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n (* The syn-ack must be received and connection established *)\n WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data) ~seq:(Sequence.of_int32 0l) ~window\n ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_ACK)\n ) else\n Lwt.return (Fsm_error \"Expected initial syn request\")\n | `WAIT_FOR_ACK ->\n if Tcp_wire.get_ack data then (\n Lwt.return Fsm_done\n ) else\n Lwt.return (Fsm_error \"Expected final ack of three step dance\")\n | `END ->\n Lwt.return (Fsm_error \"nothing expected\") in\n (`WAIT_FOR_SYN, fsm), sut_connects_and_remains_connected\n\nlet connection_refused_scenario =\n let fsm ip state ~src ~dst data =\n match state with\n | `WAIT_FOR_SYN ->\n let syn = Tcp_wire.get_syn data in\n if syn then (\n let id = reply_id_from ~src ~dst data in\n (* refused *)\n WIRE.xmit ~ip id ~rst:true ~rx_ack:(ack data) ~seq:(Sequence.of_int32 0l) ~window\n ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return Fsm_done\n ) else\n Lwt.return (Fsm_error \"Expected initial syn request\") in\n let sut stack _fail =\n let conn = VNETIF_STACK.Stack.TCP.create_connection (VNETIF_STACK.Stack.tcp stack) in\n (* connection must be rejected *)\n expect_error `Refused \"connect\" conn (Ipaddr.V4 server_ip, 80) in\n (`WAIT_FOR_SYN, fsm), sut\n\n\nlet blind_rst_on_established_scenario =\n let fsm ip state ~src ~dst data =\n match state with\n | `WAIT_FOR_SYN ->\n let syn = Tcp_wire.get_syn data in\n if syn then (\n let id = reply_id_from ~src ~dst data in\n WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data) ~seq:(Sequence.of_int32 0l) ~window\n ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_ACK)\n ) else\n Lwt.return (Fsm_error \"Expected initial syn request\")\n | `WAIT_FOR_ACK ->\n if Tcp_wire.get_ack data then (\n (* This -blind- reset is acceptable, but don't exactly match the next sequence (we started at 0, this is 10).\n * Must trigger a challenge ack and not tear down the connection *)\n let id = reply_id_from ~src ~dst data in\n WIRE.xmit ~ip id ~rst:true ~rx_ack:None ~seq:(Sequence.of_int32 10l)\n ~window ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_CHALLENGE)\n ) else\n Lwt.return (Fsm_error \"Expected final ack of three way handshake\")\n | `WAIT_FOR_CHALLENGE ->\n if (Tcp_wire.get_ack data) && (Tcp_wire.get_ack_number data = 1l) then\n Lwt.return Fsm_done\n else\n Lwt.return (Fsm_error \"Challenge ack expected\") in\n (`WAIT_FOR_SYN, fsm), sut_connects_and_remains_connected\n\nlet rst_on_established_scenario =\n let fsm ip state ~src ~dst data =\n match state with\n | `WAIT_FOR_SYN ->\n let syn = Tcp_wire.get_syn data in\n if syn then (\n let id = reply_id_from ~src ~dst data in\n WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data)\n ~seq:(Sequence.of_int32 0l) ~window\n ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_ACK)\n ) else\n Lwt.return (Fsm_error \"Expected initial syn request\")\n | `WAIT_FOR_ACK ->\n if Tcp_wire.get_ack data then (\n let id = reply_id_from ~src ~dst data in\n (* This reset is acceptable and exactly in sequence. Must trigger a reset on the other end *)\n WIRE.xmit ~ip id ~rst:true ~rx_ack:None ~seq:(Sequence.of_int32 1l)\n ~window ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return Fsm_done\n ) else\n Lwt.return (Fsm_error \"Expected final ack of three step dance\") in\n\n let sut stack fail_callback =\n let conn = VNETIF_STACK.Stack.TCP.create_connection (VNETIF_STACK.Stack.tcp stack) in\n or_error \"connect\" conn (Ipaddr.V4 server_ip, 80) >>= fun flow ->\n VNETIF_STACK.Stack.TCP.read flow >>= function\n | Ok `Eof ->\n (* This is the expected when the other end resets *)\n Lwt.return_unit\n | other ->\n fail_result_not_expected fail_callback other in\n (`WAIT_FOR_SYN, fsm), sut\n\nlet blind_syn_on_established_scenario =\n let fsm ip state ~src ~dst data =\n match state with\n | `WAIT_FOR_SYN ->\n let syn = Tcp_wire.get_syn data in\n if syn then (\n let id = reply_id_from ~src ~dst data in\n WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data)\n ~seq:(Sequence.of_int32 0l) ~window\n ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_ACK)\n ) else\n Lwt.return (Fsm_error \"Expected initial syn request\")\n | `WAIT_FOR_ACK ->\n if Tcp_wire.get_ack data then (\n let id = reply_id_from ~src ~dst data in\n\n (* This -blind- syn should trigger a challenge ack and not\n tear down the connection *)\n WIRE.xmit ~ip id ~syn:true ~rx_ack:None ~seq:(Sequence.of_int32 10l)\n ~window ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_CHALLENGE)\n ) else\n Lwt.return (Fsm_error \"Expected final ack of three step dance\")\n | `WAIT_FOR_CHALLENGE ->\n if (Tcp_wire.get_ack data) && (Tcp_wire.get_ack_number data = 1l) then (\n Lwt.return Fsm_done\n ) else\n Lwt.return (Fsm_error \"Challenge ack expected\") in\n (`WAIT_FOR_SYN, fsm), sut_connects_and_remains_connected\n\nlet blind_data_injection_scenario =\n let page = Cstruct.create 512 in\n let fsm ip state ~src ~dst data =\n match state with\n | `WAIT_FOR_SYN ->\n let syn = Tcp_wire.get_syn data in\n if syn then (\n let id = reply_id_from ~src ~dst data in\n WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data)\n ~seq:(Sequence.of_int32 1000000l) ~window\n ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_ACK)\n ) else\n Lwt.return (Fsm_error \"Expected initial syn request\")\n | `WAIT_FOR_ACK ->\n if Tcp_wire.get_ack data then (\n let id = reply_id_from ~src ~dst data in\n (* This -blind- data should trigger a challenge ack and not\n tear down the connection *)\n let invalid_ack = ack_from_past data (window +100) in\n WIRE.xmit ~ip id ~rx_ack:invalid_ack ~seq:(Sequence.of_int32 1000001l)\n ~window ~options page\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_CHALLENGE)\n ) else\n Lwt.return (Fsm_error \"Expected final ack of three step dance\")\n | `WAIT_FOR_CHALLENGE ->\n if (Tcp_wire.get_ack data) && (Tcp_wire.get_ack_number data = 1000001l) then\n Lwt.return Fsm_done\n else\n Lwt.return (Fsm_error \"Challenge ack expected\")\n in\n (`WAIT_FOR_SYN, fsm), sut_connects_and_remains_connected\n\nlet data_repeated_ack_scenario =\n (* This is the just data transmission with ack in the past but within the acceptable window *)\n let page = Cstruct.create 512 in\n let fsm ip state ~src ~dst data =\n match state with\n | `WAIT_FOR_SYN ->\n let syn = Tcp_wire.get_syn data in\n if syn then (\n let id = reply_id_from ~src ~dst data in\n WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data)\n ~seq:(Sequence.of_int32 1000000l) ~window\n ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_ACK)\n ) else\n Lwt.return (Fsm_error \"Expected initial syn request\")\n | `WAIT_FOR_ACK ->\n if Tcp_wire.get_ack data then (\n let id = reply_id_from ~src ~dst data in\n (* Ack is old but within the acceptable window. *)\n let valid_ack = ack_from_past data (window -100) in\n WIRE.xmit ~ip id ~rx_ack:valid_ack ~seq:(Sequence.of_int32 1000001l)\n ~window ~options page\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_DATA_ACK)\n ) else\n Lwt.return (Fsm_error \"Expected final ack of three step dance\")\n | `WAIT_FOR_DATA_ACK ->\n if (Tcp_wire.get_ack data) && (Tcp_wire.get_ack_number data = Int32.(add 1000001l (of_int (Cstruct.length page)))) then\n Lwt.return Fsm_done\n else\n Lwt.return (Fsm_error \"Ack for data expected\") in\n\n let sut stack fail_callback =\n let conn = VNETIF_STACK.Stack.TCP.create_connection (VNETIF_STACK.Stack.tcp stack) in\n or_error \"connect\" conn (Ipaddr.V4 server_ip, 80) >>= fun flow ->\n (* We should receive the data *)\n VNETIF_STACK.Stack.TCP.read flow >>= function\n | Ok _ -> Lwt.return_unit\n | other -> fail_result_not_expected fail_callback other in\n (`WAIT_FOR_SYN, fsm), sut\n\n\nlet run_test pcap_file ((initial_state, fsm), sut) () =\n let backend = VNETIF_STACK.create_backend () in\n VNETIF_STACK.record_pcap backend pcap_file (run backend (initial_state, fsm) sut)\n\nlet suite = [\n \"blind rst to syn_sent\", `Quick,\n run_test \"tcp_blind_rst_on_syn.pcap\" blind_rst_on_syn_scenario ;\n\n \"connection refused\", `Quick,\n run_test \"tcp_connection_refused.pcap\" connection_refused_scenario;\n\n \"blind rst on established\", `Quick,\n run_test \"tcp_blind_rst_on_established.pcap\" blind_rst_on_established_scenario;\n\n \"rst on established\", `Quick,\n run_test \"tcp_rst_on_established.pcap\" rst_on_established_scenario;\n\n \"blind syn on established\", `Quick,\n run_test \"tcp_blind_syn_on_established.pcap\" blind_syn_on_established_scenario;\n\n \"blind data injection\", `Quick,\n run_test \"tcp_blind_data_injection.pcap\" blind_data_injection_scenario;\n\n \"data repeated ack\", `Quick,\n run_test \"tcp_data_repeated_ack.pcap\" data_repeated_ack_scenario;\n]\n" }, { "path": "test/test_simulatenous_close.ml", "content": "open Common\n\nopen Low_level\nopen Lwt.Infix\n\nlet close_ack_scenario =\n let fsm ip state ~src ~dst data =\n match state with\n | `WAIT_FOR_SYN ->\n let syn = Tcp_wire.get_syn data in\n if syn then (\n let id = reply_id_from ~src ~dst data in\n WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data)\n ~seq:(Sequence.of_int32 1000000l) ~window\n ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_ACK)\n ) else\n Lwt.return (Fsm_error \"Expected initial syn request\")\n | `WAIT_FOR_ACK ->\n if Tcp_wire.get_ack data then (\n let id = reply_id_from ~src ~dst data in\n WIRE.xmit ~ip id ~rx_ack:(ack data) ~fin:true ~seq:(Sequence.of_int32 1000001l)\n ~window ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_FIN)\n ) else\n Lwt.return (Fsm_error \"Expected final ack of three step dance\")\n | `WAIT_FOR_FIN ->\n if (Tcp_wire.get_fin data) then\n let id = reply_id_from ~src ~dst data in\n WIRE.xmit ~ip id ~rx_ack:(ack data) ~seq:(Sequence.of_int32 1000002l)\n ~window:0 ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return Fsm_done\n else\n Lwt.return (Fsm_error \"Fin expected\") in\n\n let sut stack _fail_callback =\n let conn = VNETIF_STACK.Stack.TCP.create_connection (VNETIF_STACK.Stack.tcp stack) in\n or_error \"connect\" conn (Ipaddr.V4 server_ip, 80) >>= fun flow ->\n (* We should receive the data *)\n VNETIF_STACK.Stack.TCP.close flow >>= fun () ->\n Lwt_unix.sleep 4.0 >>= fun () ->\n Alcotest.(check int) \"connection is cleaned\" 0 (VNETIF_STACK.T.num_open_channels ((VNETIF_STACK.Stack.tcp stack)));\n Lwt.return_unit\n in\n (`WAIT_FOR_SYN, fsm), sut\n\n let close_reset_scenario =\n let fsm ip state ~src ~dst data =\n match state with\n | `WAIT_FOR_SYN ->\n let syn = Tcp_wire.get_syn data in\n if syn then (\n let id = reply_id_from ~src ~dst data in\n WIRE.xmit ~ip id ~syn:true ~rx_ack:(ack data)\n ~seq:(Sequence.of_int32 1000000l) ~window\n ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_ACK)\n ) else\n Lwt.return (Fsm_error \"Expected initial syn request\")\n | `WAIT_FOR_ACK ->\n if Tcp_wire.get_ack data then (\n let id = reply_id_from ~src ~dst data in\n WIRE.xmit ~ip id ~rx_ack:(ack data) ~fin:true ~seq:(Sequence.of_int32 1000001l)\n ~window ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_FIN)\n ) else\n Lwt.return (Fsm_error \"Expected final ack of three step dance\")\n | `WAIT_FOR_FIN ->\n if (Tcp_wire.get_fin data) then\n let id = reply_id_from ~src ~dst data in\n WIRE.xmit ~ip id ~rx_ack:None ~rst:true ~seq:(Sequence.of_int32 1000001l)\n ~window:0 ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_next `WAIT_FOR_CHALLENGE_ACK)\n else\n Lwt.return (Fsm_error \"Expected fin\")\n | `WAIT_FOR_CHALLENGE_ACK ->\n if (Tcp_wire.get_ack data) then\n let id = reply_id_from ~src ~dst data in\n WIRE.xmit ~ip id ~rx_ack:None ~rst:true ~seq:(Sequence.of_int32 1000002l)\n ~window:0 ~options (Cstruct.create 0)\n >|= Result.get_ok >>= fun () ->\n Lwt.return (Fsm_done)\n else\n Lwt.return (Fsm_error \"Expected challenge ack\")\n in\n\n let sut stack _fail_callback =\n let conn = VNETIF_STACK.Stack.TCP.create_connection (VNETIF_STACK.Stack.tcp stack) in\n or_error \"connect\" conn (Ipaddr.V4 server_ip, 80) >>= fun flow ->\n (* We should receive the data *)\n VNETIF_STACK.Stack.TCP.close flow >>= fun () ->\n Lwt_unix.sleep 4.0 >>= fun () ->\n Alcotest.(check int) \"connection is cleaned\" 0 (VNETIF_STACK.T.num_open_channels ((VNETIF_STACK.Stack.tcp stack)));\n Lwt.return_unit\n in\n (`WAIT_FOR_SYN, fsm), sut\n\nlet run_test pcap_file ((initial_state, fsm), sut) () =\n let backend = VNETIF_STACK.create_backend () in\n VNETIF_STACK.record_pcap backend pcap_file (run backend (initial_state, fsm) sut)\n\nlet suite = [\n \"close with ack\", `Slow, run_test \"close_ack.pcap\" close_ack_scenario;\n \"close with reset, challenge ack ok\", `Slow, run_test \"close_reset.pcap\" close_reset_scenario;\n]\n" }, { "path": "test/test_socket.ml", "content": "open Lwt.Infix\n\nlet or_fail_str ~str f args =\n f args >>= function\n | `Ok p -> Lwt.return p\n | `Error _ -> Alcotest.fail str\n\nlet localhost = Ipaddr.V4.of_string_exn \"127.0.0.1\"\nlet localhost_cidr = Ipaddr.V4.Prefix.make 32 localhost\n\nmodule Stackv4v6 = Tcpip_stack_socket.V4V6\n\nlet make_v4v6_stack ipv4_only ipv6_only ipv4 ipv6 =\n Tcpv4v6_socket.connect ~ipv4_only ~ipv6_only ipv4 ipv6 >>= fun tcp ->\n Udpv4v6_socket.connect ~ipv4_only ~ipv6_only ipv4 ipv6 >>= fun udp ->\n Stackv4v6.connect udp tcp >|= fun stack ->\n stack\n\nlet ip4_any = Ipaddr.V4.Prefix.global (* 0.0.0.0/0 *)\n\nlet two_connect_tcp () =\n let announce flow =\n Tcpv4v6_socket.read flow >>= function\n | Error _ -> Printf.printf \"Error reading!\"; Alcotest.fail \"Error reading TCP flow\"\n | Ok `Eof -> Printf.printf \"EOF!\"; Lwt.return_unit\n | Ok (`Data buf) -> Printf.printf \"Buffer received: %s\\n%!\" (Cstruct.to_string buf);\n Lwt.return_unit\n in\n let server_port = 14041 in\n make_v4v6_stack true false localhost_cidr None >>= fun server ->\n make_v4v6_stack true false localhost_cidr None >>= fun client ->\n let teardown () =\n Stackv4v6.disconnect server >>= fun () ->\n Stackv4v6.disconnect client\n in\n\n Stackv4v6.TCP.listen (Stackv4v6.tcp server) ~port:server_port announce;\n Lwt.pick [\n Stackv4v6.listen server;\n Stackv4v6.TCP.create_connection (Stackv4v6.tcp client) (Ipaddr.V4 localhost, server_port) >|= Result.get_ok >>= fun flow ->\n Stackv4v6.TCP.write flow (Cstruct.of_string \"test!\") >>= function\n | Ok () -> Stackv4v6.TCP.close flow >>= fun () -> teardown ()\n | Error _ -> teardown () >>= fun () -> Alcotest.fail \"Error writing to socket for TCP test\"\n ]\n\nlet icmp_echo_request () =\n Icmpv4_socket.connect () >>= fun server ->\n Icmpv4_socket.connect () >>= fun client ->\n let echo_request = Icmpv4_packet.(Marshal.make_cstruct\n ~payload:(Cstruct.create 0)\n { ty = Icmpv4_wire.Echo_request;\n code = 0x00;\n subheader = Id_and_seq (0x1dea, 0x0001)\n }) in\n let received_icmp = ref 0 in\n let log_and_count buf =\n received_icmp := !received_icmp + 1;\n Logs.debug (fun f -> f \"received ICMP packet number %d: %a\" !received_icmp Cstruct.hexdump_pp buf);\n Lwt.return_unit\n in\n Lwt.pick [\n Icmpv4_socket.listen server localhost log_and_count;\n Mirage_sleep.ns (Duration.of_ms 500) >>= fun () ->\n Icmpv4_socket.write client ~dst:localhost echo_request >|= Result.get_ok >>= fun () ->\n Mirage_sleep.ns (Duration.of_sec 10);\n ] >>= fun () ->\n Icmpv4_socket.disconnect server >>= fun () ->\n Icmpv4_socket.disconnect client >|= fun () ->\n Alcotest.(check int) \"number of ICMP packets received by listener\"\n 1 !received_icmp\n\nlet no_leak_fds_in_tcpv4v6 () =\n make_v4v6_stack false false ip4_any None >>= fun stack1 ->\n Stackv4v6.TCP.listen (Stackv4v6.tcp stack1) ~port:1234 (fun _flow -> Lwt.return_unit);\n Stackv4v6.disconnect stack1 >>= fun () ->\n make_v4v6_stack false false ip4_any None >>= fun stack2 ->\n Stackv4v6.TCP.listen (Stackv4v6.tcp stack2) ~port:1234 (fun _flow -> Lwt.return_unit);\n Stackv4v6.disconnect stack2\n\nlet no_leak_fds_in_udpv4v6 () =\n make_v4v6_stack false false ip4_any None >>= fun stack1 ->\n Stackv4v6.UDP.listen (Stackv4v6.udp stack1) ~port:1234 (fun ~src:_ ~dst:_ ~src_port:_ _cs -> Lwt.return_unit);\n Stackv4v6.disconnect stack1 >>= fun () ->\n make_v4v6_stack false false ip4_any None >>= fun stack2 ->\n Stackv4v6.UDP.listen (Stackv4v6.udp stack2) ~port:1234 (fun ~src:_ ~dst:_ ~src_port:_ _cs -> Lwt.return_unit);\n Stackv4v6.disconnect stack2\n\nlet no_leak_fds_in_tcpv4v6_2 () =\n make_v4v6_stack false false localhost_cidr None >>= fun stack1 ->\n Stackv4v6.TCP.listen (Stackv4v6.tcp stack1) ~port:1234 (fun _flow -> Lwt.return_unit);\n Stackv4v6.disconnect stack1 >>= fun () ->\n make_v4v6_stack false false localhost_cidr None >>= fun stack2 ->\n Stackv4v6.TCP.listen (Stackv4v6.tcp stack2) ~port:1234 (fun _flow -> Lwt.return_unit);\n Stackv4v6.disconnect stack2\n\nlet no_leak_fds_in_udpv4v6_2 () =\n make_v4v6_stack false false localhost_cidr None >>= fun stack1 ->\n Stackv4v6.UDP.listen (Stackv4v6.udp stack1) ~port:1234 (fun ~src:_ ~dst:_ ~src_port:_ _cs -> Lwt.return_unit);\n Stackv4v6.disconnect stack1 >>= fun () ->\n make_v4v6_stack false false localhost_cidr None >>= fun stack2 ->\n Stackv4v6.UDP.listen (Stackv4v6.udp stack2) ~port:1234 (fun ~src:_ ~dst:_ ~src_port:_ _cs -> Lwt.return_unit);\n Stackv4v6.disconnect stack2\n\nlet ip6_local = Some Ipaddr.V6.(Prefix.of_addr localhost)\n\nlet no_leak_fds_in_tcpv4v6_3 () =\n make_v4v6_stack false false localhost_cidr ip6_local >>= fun stack1 ->\n Stackv4v6.TCP.listen (Stackv4v6.tcp stack1) ~port:1234 (fun _flow -> Lwt.return_unit);\n Stackv4v6.disconnect stack1 >>= fun () ->\n make_v4v6_stack false false localhost_cidr ip6_local >>= fun stack2 ->\n Stackv4v6.TCP.listen (Stackv4v6.tcp stack2) ~port:1234 (fun _flow -> Lwt.return_unit);\n Stackv4v6.disconnect stack2\n\nlet no_leak_fds_in_udpv4v6_3 () =\n make_v4v6_stack false false localhost_cidr ip6_local >>= fun stack1 ->\n Stackv4v6.UDP.listen (Stackv4v6.udp stack1) ~port:1234 (fun ~src:_ ~dst:_ ~src_port:_ _cs -> Lwt.return_unit);\n Stackv4v6.disconnect stack1 >>= fun () ->\n make_v4v6_stack false false localhost_cidr ip6_local >>= fun stack2 ->\n Stackv4v6.UDP.listen (Stackv4v6.udp stack2) ~port:1234 (fun ~src:_ ~dst:_ ~src_port:_ _cs -> Lwt.return_unit);\n Stackv4v6.disconnect stack2\n\nlet no_leak_fds_in_tcpv4v6_4 () =\n make_v4v6_stack true false localhost_cidr ip6_local >>= fun stack1 ->\n Stackv4v6.TCP.listen (Stackv4v6.tcp stack1) ~port:1234 (fun _flow -> Lwt.return_unit);\n Stackv4v6.disconnect stack1 >>= fun () ->\n make_v4v6_stack true false localhost_cidr ip6_local >>= fun stack2 ->\n Stackv4v6.TCP.listen (Stackv4v6.tcp stack2) ~port:1234 (fun _flow -> Lwt.return_unit);\n Stackv4v6.disconnect stack2\n\nlet no_leak_fds_in_udpv4v6_4 () =\n make_v4v6_stack true false localhost_cidr ip6_local >>= fun stack1 ->\n Stackv4v6.UDP.listen (Stackv4v6.udp stack1) ~port:1234 (fun ~src:_ ~dst:_ ~src_port:_ _cs -> Lwt.return_unit);\n Stackv4v6.disconnect stack1 >>= fun () ->\n make_v4v6_stack true false localhost_cidr ip6_local >>= fun stack2 ->\n Stackv4v6.UDP.listen (Stackv4v6.udp stack2) ~port:1234 (fun ~src:_ ~dst:_ ~src_port:_ _cs -> Lwt.return_unit);\n Stackv4v6.disconnect stack2\n\nlet no_leak_fds_in_tcpv4v6_5 () =\n make_v4v6_stack false true localhost_cidr ip6_local >>= fun stack1 ->\n Stackv4v6.TCP.listen (Stackv4v6.tcp stack1) ~port:1234 (fun _flow -> Lwt.return_unit);\n Stackv4v6.disconnect stack1 >>= fun () ->\n make_v4v6_stack false true localhost_cidr ip6_local >>= fun stack2 ->\n Stackv4v6.TCP.listen (Stackv4v6.tcp stack2) ~port:1234 (fun _flow -> Lwt.return_unit);\n Stackv4v6.disconnect stack2\n\nlet no_leak_fds_in_udpv4v6_5 () =\n make_v4v6_stack false true localhost_cidr ip6_local >>= fun stack1 ->\n Stackv4v6.UDP.listen (Stackv4v6.udp stack1) ~port:1234 (fun ~src:_ ~dst:_ ~src_port:_ _cs -> Lwt.return_unit);\n Stackv4v6.disconnect stack1 >>= fun () ->\n make_v4v6_stack false true localhost_cidr ip6_local >>= fun stack2 ->\n Stackv4v6.UDP.listen (Stackv4v6.udp stack2) ~port:1234 (fun ~src:_ ~dst:_ ~src_port:_ _cs -> Lwt.return_unit);\n Stackv4v6.disconnect stack2\n\nlet suite = [\n \"two sockets connect via TCP\", `Quick, two_connect_tcp;\n \"icmp echo-requests are sent\", `Slow, icmp_echo_request;\n \"file descriptors are not leaked in tcpv4v6 (any)\", `Quick, no_leak_fds_in_tcpv4v6;\n \"file descriptors are not leaked in udpv4v6 (any)\", `Quick, no_leak_fds_in_udpv4v6;\n \"file descriptors are not leaked in tcpv4v6 (v4)\", `Quick, no_leak_fds_in_tcpv4v6_2;\n \"file descriptors are not leaked in udpv4v6 (v4)\", `Quick, no_leak_fds_in_udpv4v6_2;\n \"file descriptors are not leaked in tcpv4v6 (v4v6)\", `Quick, no_leak_fds_in_tcpv4v6_3;\n \"file descriptors are not leaked in udpv4v6 (v4v6)\", `Quick, no_leak_fds_in_udpv4v6_3;\n \"file descriptors are not leaked in tcpv4v6 (v4 only)\", `Quick, no_leak_fds_in_tcpv4v6_4;\n \"file descriptors are not leaked in udpv4v6 (v4 only)\", `Quick, no_leak_fds_in_udpv4v6_4;\n \"file descriptors are not leaked in tcpv4v6 (v6 only)\", `Quick, no_leak_fds_in_tcpv4v6_5;\n \"file descriptors are not leaked in udpv4v6 (v6 only)\", `Quick, no_leak_fds_in_udpv4v6_5;\n]\n" }, { "path": "test/test_tcp_options.ml", "content": "open Common\n\nlet check = Alcotest.(check @@ result (list options) string)\n\nlet errors ?(check_msg = false) exp = function\n | Ok opt -> failf \"Ok %a when Error %s expected\" Tcp.Options.pps opt exp\n | Error p -> if check_msg then\n Alcotest.(check string)\n \"Error didn't give the expected error message\" exp p\n else ()\n\nlet test_unmarshal_bad_mss () =\n let odd_sized_mss = Cstruct.create 3 in\n Cstruct.set_uint8 odd_sized_mss 0 2;\n Cstruct.set_uint8 odd_sized_mss 1 3;\n Cstruct.set_uint8 odd_sized_mss 2 255;\n errors \"MSS size is unreasonable\" (Tcp.Options.unmarshal odd_sized_mss)\n\nlet test_unmarshal_bogus_length () =\n let bogus = Cstruct.create (4*8-1) in\n Cstruct.memset bogus 0;\n Cstruct.blit_from_string \"\\x6e\\x73\\x73\\x68\\x2e\\x63\\x6f\\x6d\" 0 bogus 0 8;\n (* some unknown option (0x6e) with claimed length 0x73, longer than\n the buffer. This invalidates later results, but previous ones are\n still valid, if any *)\n check \"length\" (Ok []) (Tcp.Options.unmarshal bogus)\n\nlet test_unmarshal_zero_length () =\n let bogus = Cstruct.create 10 in\n Cstruct.memset bogus 1; (* noops *)\n Cstruct.set_uint8 bogus 0 64; (* arbitrary unknown option-kind *)\n Cstruct.set_uint8 bogus 1 0;\n (* this invalidates later results, but previous ones are still\n valid, if any *)\n check \"zero\" (Ok []) (Tcp.Options.unmarshal bogus)\n\nlet test_unmarshal_simple_options () =\n (* empty buffer should give empty list *)\n check \"simple\" (Ok []) (Tcp.Options.unmarshal (Cstruct.create 0));\n\n (* buffer with just eof should give empty list *)\n let just_eof = Cstruct.create 1 in\n Cstruct.set_uint8 just_eof 0 0;\n check \"eof\" (Ok []) (Tcp.Options.unmarshal just_eof);\n\n (* buffer with single noop should give a list with 1 noop *)\n let just_noop = Cstruct.create 1 in\n Cstruct.set_uint8 just_noop 0 1;\n check \"noop\" (Ok [ Tcp.Options.Noop ]) (Tcp.Options.unmarshal just_noop);\n\n (* buffer with valid, but unknown, option should be correctly communicated *)\n let unknown = Cstruct.create 10 in\n let data = \"hi mom!!\" in\n let kind = 18 in (* TODO: more canonically unknown option-kind *)\n Cstruct.blit_from_string data 0 unknown 2 (String.length data);\n Cstruct.set_uint8 unknown 0 kind;\n Cstruct.set_uint8 unknown 1 (Cstruct.length unknown);\n check \"more\"\n (Ok [Tcp.Options.Unknown (kind, data)])\n (Tcp.Options.unmarshal unknown)\n\nlet test_unmarshal_stops_at_eof () =\n let buf = Cstruct.create 14 in\n let ts1 = 0xabad1deal in\n let ts2 = 0xc0ffee33l in\n Cstruct.memset buf 0;\n Cstruct.set_uint8 buf 0 4; (* sack_ok *)\n Cstruct.set_uint8 buf 1 2; (* length of two *)\n Cstruct.set_uint8 buf 2 1; (* noop *)\n Cstruct.set_uint8 buf 3 0; (* eof *)\n Cstruct.set_uint8 buf 4 8; (* timestamp *)\n Cstruct.set_uint8 buf 5 10; (* timestamps are 2 4-byte times *)\n Cstruct.BE.set_uint32 buf 6 ts1;\n Cstruct.BE.set_uint32 buf 10 ts2;\n (* correct parsing will ignore options from after eof, so we shouldn't see\n timestamp or noop *)\n match Tcp.Options.unmarshal buf with\n | Error s -> Alcotest.fail s\n | Ok result ->\n Alcotest.(check bool) \"SACK_ok missing\"\n true (List.mem Tcp.Options.SACK_ok result);\n Alcotest.(check bool) \"noop missing\"\n true (List.mem Tcp.Options.Noop result);\n Alcotest.(check bool) \"timestamp present\"\n false (List.mem (Tcp.Options.Timestamp (ts1, ts2)) result)\n\nlet test_unmarshal_ok_options () =\n let buf = Cstruct.create 8 in\n Cstruct.memset buf 0;\n let opts = [ Tcp.Options.MSS 536; Tcp.Options.SACK_ok; Tcp.Options.Noop;\n Tcp.Options.Noop ] in\n let marshalled = Tcp.Options.marshal buf opts in\n Alcotest.(check int) \"marshalled\" marshalled 8;\n (* order is reversed by the unmarshaller, which is fine but we need to\n account for that when making equality assertions *)\n match Tcp.Options.unmarshal buf with\n | Error s -> Alcotest.fail s\n | Ok l -> Alcotest.(check @@ list options) \"l\" l opts\n\nlet test_unmarshal_random_data () =\n let random = Cstruct.create 64 in\n let iterations = 100 in\n Random.self_init ();\n let set_random pos =\n let num = Random.int32 Int32.max_int in\n Cstruct.BE.set_uint32 random pos num;\n in\n let rec check = function\n | n when n <= 0 -> ()\n | n ->\n List.iter set_random [0;4;8;12;16;20;24;28;32;36;40;44;48;52;56;60];\n Cstruct.hexdump random;\n (* acceptable outcomes: some list of options or the expected exception *)\n match Tcp.Options.unmarshal random with\n | Error _ -> (* Errors are OK, just finish *) ()\n | Ok l ->\n Tcp.Options.pps Format.std_formatter l;\n (* a really basic truth: the longest list we can have is 64 noops *)\n Alcotest.(check bool) \"random\" true (List.length l < 65);\n check (n - 1)\n in\n check iterations\n\nlet test_marshal_unknown () =\n let buf = Cstruct.create 10 in\n Cstruct.memset buf 255;\n let unknown = [ Tcp.Options.Unknown (64, \" \") ] in (* overall, length 4 *)\n Alcotest.(check int) \"4 bytes\"\n 4 (Tcp.Options.marshal buf unknown); (* should have written 4 bytes *)\n Cstruct.hexdump buf;\n (* option-kind *)\n Alcotest.(check int) \"option kind\" 64 (Cstruct.get_uint8 buf 0);\n (* option-length *)\n Alcotest.(check int)\"option length\" 4 (Cstruct.get_uint8 buf 1);\n (* data *)\n Alcotest.(check int) \"data 1\" 0x20 (Cstruct.get_uint8 buf 2);\n (* moar data *)\n Alcotest.(check int) \"data 2\" 0x20 (Cstruct.get_uint8 buf 3);\n (* unwritten region *)\n Alcotest.(check int) \"canary\" 255 (Cstruct.get_uint8 buf 4)\n\nlet test_options_marshal_padding () =\n let buf = Cstruct.create 8 in\n Cstruct.memset buf 255;\n let extract = Cstruct.get_uint8 buf in\n let needs_padding = [ Tcp.Options.SACK_ok ] in\n Alcotest.(check int) \"padding\" 4 (Tcp.Options.marshal buf needs_padding);\n Alcotest.(check int) \"extract 0\" 4 (extract 0);\n Alcotest.(check int) \"extract 1\" 2 (extract 1);\n (* should pad out the rest of the buffer with 0 *)\n Alcotest.(check int) \"extract 2\" 0 (extract 2);\n Alcotest.(check int) \"extract 3\" 0 (extract 3);\n (* but not keep padding into random memory *)\n Alcotest.(check int) \"extract 4\" 255 (extract 4)\n\nlet test_marshal_empty () =\n let buf = Cstruct.create 4 in\n Cstruct.memset buf 255;\n Alcotest.(check int) \"0\" 0 (Tcp.Options.marshal buf []);\n Alcotest.(check int) \"255\" 255 (Cstruct.get_uint8 buf 0)\n\nlet test_marshal_into_cstruct () =\n let options = [\n Tcp.Options.MSS 1460;\n Tcp.Options.SACK_ok;\n Tcp.Options.Window_size_shift 2\n ] in\n (* MSS is 4 bytes, SACK_OK is 4 bytes, window_size_shift is 3, plus\n 1 for padding *)\n let options_size = 12 in\n let buf = Cstruct.create (Tcp.Tcp_wire.sizeof_tcp + options_size) in\n Cstruct.memset buf 255;\n let src = Ipaddr.V4.of_string_exn \"127.0.0.1\" in\n let dst = Ipaddr.V4.of_string_exn \"127.0.0.1\" in\n let ipv4_header =\n {Ipv4_packet.src; dst; proto = 6; ttl = 64; id = 0 ; off = 0 ; options = Cstruct.create 0}\n in\n let payload = Cstruct.of_string \"ab\" in\n let pseudoheader =\n Ipv4_packet.Marshal.pseudoheader ~src ~dst ~proto:`TCP\n (Tcp.Tcp_wire.sizeof_tcp + options_size + Cstruct.length payload)\n in\n let packet =\n Tcp.Tcp_packet.{\n urg = false;\n ack = true;\n psh = false;\n rst = false;\n syn = true;\n fin = false;\n window = 0;\n options;\n sequence = Tcp.Sequence.of_int 255;\n ack_number = Tcp.Sequence.of_int 1024;\n src_port = 3000;\n dst_port = 6667;\n }\n in\n Tcp.Tcp_packet.Marshal.into_cstruct ~pseudoheader ~payload packet buf\n |> Alcotest.(check (result int string)) \"correct size written\"\n (Ok (Cstruct.length buf));\n let raw =Cstruct.concat [buf; payload] in\n Ipv4_packet.Unmarshal.verify_transport_checksum ~proto:`TCP ~ipv4_header\n ~transport_packet:raw\n |> Alcotest.(check bool) \"Checksum correct\" true;\n Tcp.Tcp_packet.Unmarshal.of_cstruct raw\n |> Alcotest.(check (result (pair tcp_packet cstruct) string))\n \"reload TCP packet\" (Ok (packet, payload));\n let just_options = Cstruct.create options_size in\n let generated_options = Cstruct.shift buf Tcp.Tcp_wire.sizeof_tcp in\n Alcotest.(check int) \"size of options buf\" options_size @@\n Tcp.Options.marshal just_options options;\n (* expecting the result of Options.Marshal to be here *)\n Alcotest.check cstruct \"marshalled options are as expected\"\n just_options generated_options;\n (* Now try with make_cstruct *)\n let headers =\n Tcp.Tcp_packet.Marshal.make_cstruct ~pseudoheader ~payload packet\n in\n let raw =Cstruct.concat [headers; payload] in\n Ipv4_packet.Unmarshal.verify_transport_checksum ~proto:`TCP ~ipv4_header\n ~transport_packet:raw\n |> Alcotest.(check bool) \"Checksum correct\" true\n\nlet test_marshal_without_padding () =\n let options = [ Tcp.Options.MSS 1460 ] in\n let options_size = 4 in (* MSS is 4 bytes *)\n let buf = Cstruct.create (Tcp.Tcp_wire.sizeof_tcp + options_size) in\n Cstruct.memset buf 255;\n let src = Ipaddr.V4.of_string_exn \"127.0.0.1\" in\n let dst = Ipaddr.V4.of_string_exn \"127.0.0.1\" in\n let ipv4_header =\n {Ipv4_packet.src; dst; proto = 6; ttl = 64; id = 0 ; off = 0 ; options = Cstruct.create 0}\n in\n let payload = Cstruct.of_string \"\\x02\\x04\\x05\\xb4\" in\n let pseudoheader =\n Ipv4_packet.Marshal.pseudoheader ~src ~dst ~proto:`TCP\n (Tcp.Tcp_wire.sizeof_tcp + options_size + Cstruct.length payload)\n in\n let packet =\n Tcp.Tcp_packet.{\n urg = false;\n ack = true;\n psh = false;\n rst = false;\n syn = true;\n fin = false;\n window = 0;\n options;\n sequence = Tcp.Sequence.of_int 255;\n ack_number = Tcp.Sequence.of_int 1024;\n src_port = 3000;\n dst_port = 6667;\n }\n in\n Tcp.Tcp_packet.Marshal.into_cstruct ~pseudoheader ~payload packet buf\n |> Alcotest.(check (result int string)) \"correct size written\"\n (Ok (Cstruct.length buf));\n let raw =Cstruct.concat [buf; payload] in\n Ipv4_packet.Unmarshal.verify_transport_checksum ~proto:`TCP ~ipv4_header\n ~transport_packet:raw\n |> Alcotest.(check bool) \"Checksum correct\" true;\n Tcp.Tcp_packet.Unmarshal.of_cstruct raw\n |> Alcotest.(check (result (pair tcp_packet cstruct) string))\n \"reload TCP packet\" (Ok (packet, payload))\n\nlet suite = [\n \"unmarshal broken mss\", `Quick, test_unmarshal_bad_mss;\n \"unmarshal option with bogus length\", `Quick, test_unmarshal_bogus_length;\n \"unmarshal option with zero length\", `Quick, test_unmarshal_zero_length;\n \"unmarshal simple cases\", `Quick, test_unmarshal_simple_options;\n \"unmarshal stops at eof\", `Quick, test_unmarshal_stops_at_eof;\n \"unmarshal non-broken tcp options\", `Quick, test_unmarshal_ok_options;\n \"unmarshalling random data returns\", `Quick, test_unmarshal_random_data;\n \"test marshalling into a cstruct\", `Quick, test_marshal_into_cstruct;\n \"test marshalling without padding\", `Quick, test_marshal_without_padding;\n \"test marshalling an unknown value\", `Quick, test_marshal_unknown;\n \"test options marshalling when padding is needed\", `Quick,\n test_options_marshal_padding;\n \"test marshalling the empty list\", `Quick, test_marshal_empty;\n]\n\nlet suite =\n List.map (fun (n, s, f) -> n, s, (fun () -> Lwt.return (f ()))) suite\n" }, { "path": "test/test_udp.ml", "content": "open Common\n\nmodule B = Basic_backend.Make\nmodule V = Vnetif.Make(B)\nmodule E = Ethernet.Make(V)\nmodule Static_arp = Static_arp.Make(E)\nmodule Ip = Static_ipv4.Make(E)(Static_arp)\nmodule Udp = Udp.Make(Ip)\n\ntype stack = {\n backend : B.t;\n netif : V.t;\n ethif : E.t;\n arp : Static_arp.t;\n ip : Ip.t;\n udp : Udp.t;\n}\n\nlet get_stack ?(backend = B.create ~use_async_readers:true\n ~yield:(fun() -> Lwt.pause ()) ()) ip =\n let open Lwt.Infix in\n let cidr = Ipaddr.V4.Prefix.make 24 ip in\n V.connect backend >>= fun netif ->\n E.connect netif >>= fun ethif ->\n Static_arp.connect ethif >>= fun arp ->\n Ip.connect ~cidr ethif arp >>= fun ip ->\n Udp.connect ip >>= fun udp ->\n Lwt.return { backend; netif; ethif; arp; ip; udp }\n\nlet fails msg f args =\n match f args with\n | Ok _ -> Alcotest.fail msg\n | Error _ -> ()\n\nlet marshal_unmarshal () =\n let parse = Udp_packet.Unmarshal.of_cstruct in\n fails \"unmarshal a 0-length packet\" parse (Cstruct.create 0);\n fails \"unmarshal a too-short packet\" parse (Cstruct.create 2);\n let with_data = Cstruct.create 8 in\n Cstruct.memset with_data 0;\n Udp_wire.set_src_port with_data 2000;\n Udp_wire.set_dst_port with_data 21;\n Udp_wire.set_length with_data 20;\n let payload = Cstruct.of_string \"abcdefgh1234\" in\n let with_data = Cstruct.concat [with_data; payload] in\n match Udp_packet.Unmarshal.of_cstruct with_data with\n | Error s -> Alcotest.fail s\n | Ok (_header, data) ->\n Alcotest.(check cstruct) \"unmarshalling gives expected data\" payload data;\n Lwt.return_unit\n\nlet write () =\n let open Lwt.Infix in\n let dst = Ipaddr.V4.of_string_exn \"192.168.4.20\" in\n get_stack dst >>= fun stack ->\n Static_arp.add_entry stack.arp dst (Macaddr.of_string_exn \"00:16:3e:ab:cd:ef\");\n Udp.write ~src_port:1212 ~dst_port:21 ~dst stack.udp (Cstruct.of_string \"MGET *\") >|= Result.get_ok\n\nlet unmarshal_regression () =\n let i = Cstruct.create 1016 in\n Cstruct.memset i 30;\n Cstruct.set_char i 4 '\\x04';\n Cstruct.set_char i 5 '\\x00';\n Alcotest.(check (result reject pass)) \"correctly return error for bad packet\"\n (Error \"parse failed\") (Udp_packet.Unmarshal.of_cstruct i);\n Lwt.return_unit\n\n\nlet marshal_marshal () =\n let error_str = Alcotest.result Alcotest.reject Alcotest.string in\n let udp = {Udp_packet.src_port = 1; dst_port = 2} in\n let payload = Cstruct.create 100 in\n let buffer = Cstruct.create Udp_wire.sizeof_udp in\n let src = Ipaddr.V4.of_string_exn \"127.0.0.1\" in\n let dst = Ipaddr.V4.of_string_exn \"127.0.0.1\" in\n let pseudoheader = Ipv4_packet.Marshal.pseudoheader ~src ~dst ~proto:`UDP (Cstruct.length buffer + Cstruct.length payload) in\n Udp_packet.Marshal.into_cstruct ~pseudoheader ~payload udp (Cstruct.shift buffer 1)\n |> Alcotest.check error_str \"Buffer too short\" (Error \"Not enough space for a UDP header\");\n Udp_packet.Marshal.into_cstruct ~pseudoheader ~payload udp buffer\n |> Alcotest.(check (result unit string)) \"Buffer big enough for header\" (Ok ());\n Udp_packet.Unmarshal.of_cstruct (Cstruct.concat [buffer; payload])\n |> Alcotest.(check (result (pair udp_packet cstruct) string)) \"Save and reload\" (Ok (udp, payload));\n Lwt.return_unit\n\nlet suite = [\n \"unmarshal regression\", `Quick, unmarshal_regression;\n \"marshal/marshal\", `Quick, marshal_marshal;\n \"marshal/unmarshal\", `Quick, marshal_unmarshal;\n \"write packets\", `Quick, write;\n]\n" }, { "path": "test/vnetif_backends.ml", "content": "(*\n * Copyright (c) 2015-16 Magnus Skjegstad \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nlet (>>=) = Lwt.(>>=)\n\nmodule type Backend = sig\n include Vnetif.BACKEND\n val create : unit -> t\nend\n\n(** This backend enforces an Ethernet frame size. *)\nmodule Frame_size_enforced = struct\n module X = Basic_backend.Make\n type t = {\n xt : X.t;\n mutable frame_size : int;\n }\n\n let register t =\n X.register t.xt\n\n let unregister t id =\n X.unregister t.xt id\n\n let mac t id =\n X.mac t.xt id\n\n let set_listen_fn t id buf =\n X.set_listen_fn t.xt id buf\n\n let unregister_and_flush t id =\n X.unregister_and_flush t.xt id\n\n let write t id ~size fill =\n if size > t.frame_size then\n Lwt.return (Error `Invalid_length)\n else\n X.write t.xt id ~size fill\n\n let set_frame_size t m = t.frame_size <- m\n let set_max_ip_mtu t m = t.frame_size <- m + Ethernet.Packet.sizeof_ethernet\n\n let create ~frame_size () =\n let xt = X.create ~use_async_readers:true ~yield:(fun() -> Lwt.pause () ) () in\n { xt ; frame_size }\n\n let create () =\n create ~frame_size:(1500 + Ethernet.Packet.sizeof_ethernet) ()\n\nend\n\n(** This backend adds a random number of trailing bytes to each frame *)\nmodule Trailing_bytes : Backend = struct\n module X = Basic_backend.Make\n include X\n\n let max_bytes_to_add = 10\n\n (* Just adds trailing bytes, doesn't store anything in them *)\n let add_random_bytes src =\n let bytes_to_add = Random.int max_bytes_to_add in\n let len = Cstruct.length src in\n let dst = Cstruct.create (len + bytes_to_add) in\n Cstruct.blit src 0 dst 0 len;\n dst\n\n let set_listen_fn t id fn =\n (* Add random bytes before returning result to real listener *)\n X.set_listen_fn t id (fun buf ->\n fn (add_random_bytes buf))\n\n let create () =\n X.create ~use_async_readers:true ~yield:(fun() -> Lwt.pause () ) ()\n\nend\n\n(** This backend drops packets *)\nmodule Uniform_packet_loss : Backend = struct\n module X = Basic_backend.Make\n include X\n\n let drop_p = 0.01\n\n let write t id ~size fill =\n if Random.float 1.0 < drop_p then\n Lwt.return (Ok ()) (* drop packet *)\n else\n X.write t id ~size fill (* pass to real write *)\n\n let create () =\n X.create ~use_async_readers:true ~yield:(fun() -> Lwt.pause () ) ()\n\nend\n\n(** This backend uniformly drops packets with no payload *)\nmodule Uniform_no_payload_packet_loss : Backend = struct\n module X = Basic_backend.Make\n include X\n\n (* We assume that packets with payload are usually filled. We could make the\n * payload check more accurate by parsing the packet properly. *)\n let no_payload_len = 100\n (* Drop probability, if no payload *)\n let drop_p = 0.10\n\n let write t id ~size fill =\n if size <= no_payload_len && Random.float 1.0 < drop_p then\n Lwt.return (Ok ()) (* drop packet *)\n else\n X.write t id ~size fill (* pass to real write *)\n\n let create () =\n X.create ~use_async_readers:true ~yield:(fun() -> Lwt.pause () ) ()\nend\n\n(** This backend drops packets for 1 second after 1 megabyte has been\n * transferred *)\nmodule Drop_1_second_after_1_megabyte : Backend = struct\n module X = Basic_backend.Make\n type t = {\n xt : X.t;\n mutable sent_bytes : int;\n mutable is_dropping : bool;\n mutable done_dropping : bool;\n }\n\n let byte_limit : int = 1_000_000\n let time_to_sleep : float = 1.0\n\n let register t =\n X.register t.xt\n\n let unregister t id =\n X.unregister t.xt id\n\n let mac t id =\n X.mac t.xt id\n\n let set_listen_fn t id buf =\n X.set_listen_fn t.xt id buf\n\n let unregister_and_flush t id =\n X.unregister_and_flush t.xt id\n\n let should_drop t =\n if (t.sent_bytes > byte_limit) &&\n (t.is_dropping = false) &&\n (t.done_dropping = false) then\n begin\n Logs.info (fun f -> f \"Backend dropping packets for %f sec\" time_to_sleep);\n t.is_dropping <- true;\n Lwt.async(fun () ->\n Lwt_unix.sleep time_to_sleep >>= fun () ->\n t.done_dropping <- true;\n t.is_dropping <- false;\n Logs.info (fun f -> f \"Stopped dropping\");\n Lwt.return_unit\n );\n true\n end else\n begin\n if t.is_dropping = true then\n true\n else\n false\n end\n\n let write t id ~size fill =\n t.sent_bytes <- t.sent_bytes + size;\n if should_drop t then\n Lwt.return (Ok ())\n else\n X.write t.xt id ~size fill (* pass to real write *)\n\n let create () =\n let xt = X.create ~use_async_readers:true ~yield:(fun() -> Lwt.pause ()) () in\n { xt ; done_dropping = false; is_dropping = false; sent_bytes = 0 }\n\nend\n\n(** This backend has a global on/off switch which drops all the packets *)\nmodule On_off_switch = struct\n module X = Basic_backend.Make\n include X\n\n let send_packets = ref true\n\n let write t id ~size fill =\n if not !send_packets then\n begin\n Logs.info (fun f -> f \"write dropping 1 packet\");\n Lwt.return (Ok ()) (* drop packet *)\n end else\n X.write t id ~size fill (* pass to real write *)\n\n let create () =\n X.create ~use_async_readers:true ~yield:(fun() -> Lwt.pause () ) ()\n\nend\n\n(** This backend delivers all packets unmodified *)\nmodule Basic : Backend = struct\n module X = Basic_backend.Make\n include X\n\n let create () =\n X.create ~use_async_readers:true ~yield:(fun() -> Lwt.pause () ) ()\nend\n" }, { "path": "test/vnetif_common.ml", "content": "(*\n * Copyright (c) 2015 Magnus Skjegstad \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *)\n\nopen Common\nopen Lwt.Infix\n\nmodule type VNETIF_STACK =\nsig\n type backend\n module Stack : Tcpip.Stack.V4V6\n\n (** Create a new backend *)\n val create_backend : unit -> backend\n\n (** Create a new stack connected to an existing backend *)\n val create_stack : ?mtu:int -> cidr:Ipaddr.V4.Prefix.t ->\n ?gateway:Ipaddr.V4.t -> ?cidr6:Ipaddr.V6.Prefix.t ->\n ?gateway6:Ipaddr.V6.t -> backend -> Stack.t Lwt.t\n\n val create_backend_listener : backend -> (Cstruct.t -> unit Lwt.t) -> int\n\n (** Disable a listener function *)\n val disable_backend_listener : backend -> int -> unit Lwt.t\n\n (** Records pcap data from the backend while running the specified\n function. Disables the pcap recorder when the function exits. *)\n val record_pcap : backend -> string -> (unit -> unit Lwt.t) -> unit Lwt.t\nend\n\nmodule VNETIF_STACK (B: Vnetif_backends.Backend): sig\n include VNETIF_STACK with type backend = B.t\n\n module T : sig\n val num_open_channels : Stack.TCP.t -> int\n end\nend\n= struct\n type backend = B.t\n module V = Vnetif.Make(B)\n module E = Ethernet.Make(V)\n\n module A = Arp.Make(E)\n module Ip4 = Static_ipv4.Make(E)(A)\n module Icmp4 = Icmpv4.Make(Ip4)\n module Ip6 = Ipv6.Make(V)(E)\n module Ip46 = Tcpip_stack_direct.IPV4V6(Ip4)(Ip6)\n module U = Udp.Make(Ip46)\n module T = Tcp.Flow.Make(Ip46)\n\n module Stack =\n Tcpip_stack_direct.MakeV4V6(V)(E)(A)(Ip46)(Icmp4)(U)(T)\n\n let create_backend () =\n B.create ()\n\n let create_stack ?mtu ~cidr ?gateway ?cidr6 ?gateway6 backend =\n let size_limit = match mtu with None -> None | Some x -> Some x in\n V.connect ?size_limit backend >>= fun netif ->\n E.connect netif >>= fun ethif ->\n A.connect ethif >>= fun arpv4 ->\n Ip4.connect ~cidr ?gateway ethif arpv4 >>= fun ipv4 ->\n Icmp4.connect ipv4 >>= fun icmpv4 ->\n Ip6.connect ?cidr:cidr6 ?gateway:gateway6 netif ethif >>= fun ipv6 ->\n Ip46.connect ~ipv4_only:false ~ipv6_only:false ipv4 ipv6 >>= fun ip ->\n U.connect ip >>= fun udp ->\n T.connect ip >>= fun tcp ->\n Stack.connect netif ethif arpv4 ip icmpv4 udp tcp\n\n let create_backend_listener backend listenf =\n match (B.register backend) with\n | Error _ -> failf \"Error occurred while registering to backend\"\n | Ok id -> (B.set_listen_fn backend id listenf); id\n\n let disable_backend_listener backend id =\n B.unregister_and_flush backend id\n\n let create_pcap_recorder backend channel =\n let header_buf = Cstruct.create Pcap.sizeof_pcap_header in\n Pcap.LE.set_pcap_header_magic_number header_buf Pcap.magic_number;\n Pcap.LE.set_pcap_header_network header_buf Pcap.Network.(to_int32 Ethernet);\n Pcap.LE.set_pcap_header_sigfigs header_buf 0l;\n Pcap.LE.set_pcap_header_snaplen header_buf 0xffffl;\n Pcap.LE.set_pcap_header_thiszone header_buf 0l;\n Pcap.LE.set_pcap_header_version_major header_buf Pcap.major_version;\n Pcap.LE.set_pcap_header_version_minor header_buf Pcap.minor_version;\n Lwt_io.write channel (Cstruct.to_string header_buf) >>= fun () ->\n let pcap_record channel buffer =\n let pcap_buf = Cstruct.create Pcap.sizeof_pcap_packet in\n let time = Unix.gettimeofday () in\n Pcap.LE.set_pcap_packet_incl_len pcap_buf (Int32.of_int (Cstruct.length buffer));\n Pcap.LE.set_pcap_packet_orig_len pcap_buf (Int32.of_int (Cstruct.length buffer));\n Pcap.LE.set_pcap_packet_ts_sec pcap_buf (Int32.of_float time);\n let frac = (time -. (float_of_int (truncate time))) *. 1000000.0 in\n Pcap.LE.set_pcap_packet_ts_usec pcap_buf (Int32.of_float frac);\n (try\n Lwt_io.write channel ((Cstruct.to_string pcap_buf) ^ (Cstruct.to_string buffer))\n with\n Lwt_io.Channel_closed msg -> Printf.printf \"Warning: Pcap output channel already closed: %s.\\n\" msg; Lwt.return_unit\n )\n >>= fun () ->\n Lwt.return_unit\n in\n let recorder_id = create_backend_listener backend (pcap_record channel) in\n Lwt.return recorder_id\n\n let record_pcap backend pcap_file fn =\n Lwt.catch\n (fun _ ->\n Lwt_io.with_file ~mode:Lwt_io.output pcap_file (fun oc ->\n create_pcap_recorder backend oc >>= fun recorder_id ->\n fn () >>= fun () ->\n disable_backend_listener backend recorder_id >>= fun () ->\n Lwt.return_unit\n )\n )\n (function\n | Unix.Unix_error _ ->\n Printf.printf \"Could not create pcap file %s - something along the way doesn't exist.\\n\" pcap_file;\n fn ()\n | e -> Lwt.fail e\n )\nend\n" } ]