swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

6
unikernel/duniverse/mirage-tcpip/.github/dependabot.yml vendored Normal file
View file

@ -0,0 +1,6 @@
version: 2
updates:
- package-ecosystem: github-actions
directory: /
schedule:
interval: weekly

69
unikernel/duniverse/mirage-tcpip/.github/workflows/main.yml vendored Normal file
View file

@ -0,0 +1,69 @@
name: Builds, tests & co
on:
pull_request:
push:
schedule:
# Prime the caches every Monday
- cron: 0 1 * * MON
permissions: read-all
jobs:
build:
strategy:
fail-fast: false
matrix:
os:
- macos-latest
- ubuntu-latest
ocaml-compiler:
- 5
- 4
runs-on: ${{ matrix.os }}
steps:
- name: Checkout tree
uses: actions/checkout@v4
- name: Set-up OCaml
uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: ${{ matrix.ocaml-compiler }}
- run: opam install . --deps-only --with-test
- run: opam exec -- dune build
- run: opam exec -- dune runtest
unikernel-example:
strategy:
fail-fast: false
matrix:
mode:
- qubes
- unix
- virtio
defaults:
run:
working-directory: examples/unikernel
runs-on: ubuntu-latest
steps:
- name: Checkout tree
uses: actions/checkout@v4
- name: Set-up OCaml
uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: 4
opam-pin: false
- run: opam install mirage
- run: opam exec -- mirage configure -t ${{ matrix.mode }}
- run: opam exec -- make depend
- run: opam exec -- make

3
unikernel/duniverse/mirage-tcpip/.gitignore vendored Normal file
View file

@ -0,0 +1,3 @@
_build
.merlin
*.install

696
unikernel/duniverse/mirage-tcpip/CHANGES.md Normal file
View file

@ -0,0 +1,696 @@
### v9.0.1 (2025-04-15)
* Unix: avoid spurious warnings when the fd is scheduled to be closed (#527
@hannesm, review by @djs55 @reynir)
* Unix: if recvfrom (UDP sockets) returns 0 (signalling EOF), do not try to read
again (avoids busy loops) (#528 @hannesm, review by @reynir)
### v9.0.0 (2025-02-06)
* Adapt to mirage-crypto-rng 1.2.0 API (#526 @hannesm)
* Use dune variants instead of functors for TIME, MCLOCK, PCLOCK
-- now using mirage-sleep and mirage-mtime (#526 @hannesm)
### v8.2.0 (2024-08-22)
* Use `mirage-crypto.1.0` & `randomconv.0.2` (@hannesm, #521)
* Update unikernels to `mirage.4.6.0` (@hannesm, @reynir, @smorimoto, #522)
* Update our CI system (@samoht, @smorimoto, #519, #520)
### v8.1.0 (2024-05-29)
* adapt to mirage-vnetif 0.6.2 changes (#517 @hannesm)
* Add `type prefix = Ipaddr.Prefix.t` and `IP.configured_ips : t -> prefix`
to the IP layers (#516 @hannesm)
* Mark `get_ips` as deprecated, use `configured_ips` instead (#516 @hannesm)
### v8.0.2 (2024-05-08)
* remove mirage-random-test dependency (#514 @hannesm)
* remove calls to mirage-profile in tests, now support mirage-vnetif 0.6.1
(#514 @hannesm)
### v8.0.1 (2024-03-26)
* TCP: add `src : flow -> ipaddr * int`, implemented by `getsockname` on unix
(#511 @hannesm)
* TCP unix stack: increase TCP buffer size (was 4096, is now 65536)
(#510 @edwintorok)
* TCP: adapt to mirage-flow 4.0:
add ``val shutdown : flow -> [ `read | `write | `read_write ] -> unit Lwt.t``
(#512 @hannesm, review by @djs55)
### v8.0.0 (2023-03-17)
* TCP: add ID for PCB for connection tracking (#495 @TheLortex)
* Unix stack, UDP: copy buffer before passing it to client (#502 @reynir)
* API renamings (due to ppx_cstruct removal): accessors such as
Icmpv4_wire.get_icmpv4_ty are now Icmpv4_wire.get_ty ("_icmpv4" is removed)
(#505)
* API change: remove deprecated V4-only and V6-only stack
The module types Stack.V4 and Stack.V6 no longer exist
The bindings Stack.V4V6.listen_udp and listen_tcp have been removed
(#494 @hannesm)
* Use Cstruct.to_string instead of deprecated Cstruct.copy (#506 @hannesm)
* Remove ppx_cstruct dependency (#505 @hannesm)
* Remove mirage-profile dependency (#504 @hannesm)
* Remove Mirage3 cross-compilation runes (#507 @hannesm)
* opam: add lower bounds for cmdliner and alcotest (#506 @hannesm)
### v7.1.2 (2022-07-27)
* TCP: fix memory leaks on connection close in three scenarios (#489 @TheLortex)
- simultanous close: set up the timewait timer in the `Closing(1) - Recv_ack(2) -> Time_wait`
state transition
- client sends a RST instead of a FIN: enable sending a challenge ACK even when the reception
thread is stopped
- client doesn't ACK server's FIN: enable the retransmit timer in the `Closing(_)` state
### v7.1.1 (2022-05-24)
* Ndpv6: demote more logs to debug level (#480 @reynir)
* Ndpv6: set RS opt header (#482 @reynir)
* Icmpv6: add redirect parsing (#481 @reynir)
* Improve log messages of connect and disconnect of various layers and stacks:
separate IP addresses with ", " (#485 @hannesm)
* TCP log sources: prefix "tcp" to distinguish them (#484 @reynir)
### v7.1.0 (2022-03-23)
* Work with MSVC compiler (@jonahbeckford, #476)
* Skip `Lwt_bytes` UDP tests on Windows (@MisterDA, #469)
* Run `PKG_CONFIG_PATH` through cypath (@MisterDA, #469)
* Add Windows CI via GitHub Action (@MisterDA, #469)
* Remove `which` command and replace it by `command -v` (@hannesm, #472)
* Fix some typos (@MisterDA, #471)
* Update binaries to `cmdliner.1.1.0` (@dinosaure, #475)
* Be able to extract via _functor_/`functoria` the TCP/IP stack (@dinosaure, #474)
* Remove missing deprecated usage of `Cstruct.len` (@dinosaure, #477)
### v7.0.1 (2021-12-17)
* Fix cancellation of Unix socket when we don't use `Stack.connect` (@dinosaure, @hannesm, #466)
### v7.0.0 (2021-12-10)
* Fix memory leak in processing RST packets (#460 @balrajsingh, reported in
#456 by @dinosaure)
* Move module types (IP, UDP, TCP, STACK, ICMP) into tcpip core library
(#463 @hannesm)
* API breakage: `Tcpip_checksum` is now part of tcpip.checksum (used to be
part of tcpip #463 @hannesm)
* API breakage: tcpip.unix has been removed (#463 @hannesm)
* Use Lwt.pause instead of deprecated `Lwt_{unix,main}.yield` (#461 @dinosaure)
### v6.4.0 (2021-11-11)
* Adapt to mirage-protocols 6.0.0 API (#457 @hannesm)
* TCP and UDP now have a listen and unlisten function (fixes #452)
* type ipinput (in TCP and UDP) and listener (in TCP) have been removed
### v6.3.0 (2021-10-25)
* Use Cstruct.length instead of deprecated Cstruct.len (#454 @hannesm)
* Avoid deprecated Fmt functions (#455 @hannesm)
* Remove rresult dependency (#455 @hannesm)
* Require OCaml 4.08
* Record TCP statistics via metrics library (#455 @hannesm)
### v6.2.0 (2021-07-19)
* This allows to listen on the same port as sending via UDP in the dual socket
stack, and avoids file descriptor leaks in the socket stack.
* Socket stack: avoid file descriptor leaks (remember opened file descriptors in
data structure, close them in disconnect)
(#449 @reynir @hannesm, fixes #446 #450)
* Socket stack: convert an incoming packet on a dual socket to v4 source IP if
received via IPv4 (#451 @reynir @hannesm)
* Allow freestanding compilation without opam (#447 @sternenseemann)
* Adapt to alcotest 1.4.0 breaking change (#448 @CraigFE)
### v6.1.0 (2021-03-17)
* checksum stubs: Drop `caml_` from their name (@hannesm, #445)
* Add cancellation on `tcpip.stack-socket` (@dinosaure, @talex5, @hannesm, #443)
* Ensure that listen really binds the given socket before
creating a task on `tcpip.stack-socket` (@dinosaure, @hannesm, #439)
* Add `ppx_cstruct` as a dependency (@hannesm, @dinosaure, #439)
* Upgrade to ocamlformat.0.17.0 (@dinosaure, #442)
* Drop the support of OCaml 4.08.0 (@dinosaure, #442)
* Use the usual layout to compile freestanding C stubs and link them to
a Solo5 unikernel (@dinosaure, @hannesm, #441)
**breaking changes**
C stubs are prepended by `mirage_`. Symbols such as checksum's
symbols are `caml_mirage_tcpip_*` instead of `caml_tcpip_*`
`tcpip.unix` is a fake sub-package and user does not it anymore, he can
safely remove it from its project.
* Conflict with `< ocaml-freestanding.0.4.1` (@hannesm, #441)
### v6.0.0 (2020-11-30)
* Dual IPv4 and IPv6 socket and direct stack support, now requires
mirage-stack 2.2.0 and mirage-protocols 5.0.0 (#433 @hannesm)
* The above change also unified arguments passed to connect functions which
are API-breaking changes
* IPv6 waits for timeout after sending neighbour advertisement (for duplicate
address detection)
* Remove Xen cross-compilation runes, with mirage-xen 6.0.0 they're provided
by mirage-xen (#434 @hannesm)
* Move to dune 2.7.0 (and bisect instrumentation if desired) (#436 @hannesm)
### v5.0.1 (2020-09-22)
* Assorted IPv6 improvements (#428 #431 #432 @MagnusS @hannesm)
- set length in packets to be sent
- preserve updated ctx from Ndv6.handle
- fix ICMP checksum computation
- implement Mirage_stack.V6 signature
- add connect, mtu, iperf tests
- fix DAD protocol implementation (and test it)
- avoid out of bounds accesses of IPv6 packets (check length before accessing)
* Fix 32 bit issues (@MagnusS)
* Implement stack-direct and tcp disconnect: tear down existing connections (#429 @hannesm)
* Treat broadcast address of network as broadcast as well (#430 @hannesm, reported in #427)
### v5.0.0 (2020-06-19)
* Static_ipv4.connect API change: takes a cidr:Ipaddr.V4.Prefix.t instead of
ip:Ipaddr.V4.t and network:Ipaddr.V4.Prefix.t (#426 @hannesm)
* Adapt to ipaddr 5.0.0 API changes (#426 @hannesm)
### v4.1.0 (2020-02-08)
* Revert "Ipv4.Fragments use a Lru.M.t instead of Lru.F.t" (#423 by @hannesm)
A Lru.M.t allocates a Hashtbl.t of size = capacity (= 256 * 1024 in our case),
this leads to excessive ~2MB memory consumption for each Fragment cache,
reported by @xaki23 in mirage/qubes-mirage-firewall#93
* use SOCK_RAW for an ICMP socket in the unix sockets API (previously used
SOCK_DGRAM which did not work)
reported by @justinc1 in #358, fixed in #424 by @hannesm
* tcp is now compatible with lwt >= 5.0.0 (where Lwt.async requires a function
of (unit -> unit Lwt.t) (#370 #425 @cfcs @hannesm, issue #392 @emillon)
* Add a dependency on dune-configurator to support dune 2.0.0 (#421 @avsm)
### v4.0.0 (2019-11-01)
* Adapt to mirage-protocols 4.0.0, mirage-net 3.0.0, mirage-time 2.0.0,
mirage-clock 3.0.0, mirage-stack 2.0.0 interface changes (#420 @hannesm)
* Revise Static_ipv4.connect signature (for more safety):
val connect : ip:(Ipaddr.V4.Prefix.t * Ipaddr.V4.t) -> ?gateway:Ipaddr.V4.t ->
?fragment_cache_size:int -> E.t -> A.t -> t Lwt.t
it used to be:
val connect : ?ip:Ipaddr.V4.t -> ?network:Ipaddr.V4.Prefix.t ->
?gateway:Ipaddr.V4.t option -> C.t -> E.t -> A.t -> t Lwt.t
The clock `C.t` is gone (due to mirage-clock 3.0.0), `~ip` and `~network` are
now required and passed as pair `~ip`. The optional argument `?gateway` is
of type Ipaddr.V4.t. The new optional labeled argument `~fragment_cache_size`
specifies the byte size of the IPv4 fragment cache (#420 @hannesm)
### v3.7.9 (2019-10-15)
* Add ?ttl:int parameter to Udp and Icmp write (#416 @phaer)
* Ipv4.Fragments use a Lru.M.t instead of Lru.F.t (#418 @hannesm)
* Adapt to mirage-protocols 3.1.0 changes (#419 @hannesm)
- removed IP.set_ip
- added `Would_fragment to Ip.error
### v3.7.8 (2019-08-12)
* provide Fragments.fragment for the write side of fragmentation, use in Static_ipv4 (#415, @hannesm)
### v3.7.7 (2019-07-16)
* support ipaddr/macaddr.4.0.0 interfaces (@avsm)
* remove extraneous debug messages from Ipv4.Fragments (@hannesm, #410)
### v3.7.6 (2019-07-08)
* opam: ensure Xen bindings are built with right mirage-xen-ocaml CFLAGS (@avsm)
* opam: correctly register mirage-xen-ocaml as a depopt (@avsm)
* use mirage-protocols-3.0 interface for ipaddr printing (#408 @yomimono @linse)
* remove dependency on configurator and use dune's builtin one instead (@avsm)
### v3.7.5 (2019-05-03)
* drop IPv4 packets which destination address is not us or broadcast (#407 by @hannesm)
### v3.7.4 (2019-04-11)
* ipv4 reassembly requires lru 0.3.0 now (#406 by @hannesm)
* ICMP test maintenance (#405 by @yomimono @linse)
* remove usage of Cstruct.set_len (use Cstruct.sub with offset 0 instead) (#403 by @hannesm)
### v3.7.3 (2019-04-06)
* fix ICMPv4 checksum calculation (#401 by @yomimono)
### v3.7.2 (2019-03-29)
* add Ipv4_packet.Unmarshal.header_of_cstruct (#397 by @linse)
* require cstruct version 3.2.0 (#398 by @hannesm)
### v3.7.1 (2019-02-25)
* Adjust to mirage-protocols 2.0.0 changes (#394 by @hannesm)
* Ethif is now Ethernet (#394 by @hannesm)
* IPv4 write now fragments if payload exceeds MTU (and the optional labeled
fragment argument is not false) (#394 by @hannesm)
### v3.7.0 (2019-02-02)
* Use `Lwt_dllist` instead of `Lwt_sequence`, due to the latter being deprecated
upstream in Lwt (ocsigen/lwt#361) (#388 by @avsm).
* Remove arpv4 and ethif sublibraries, now provided by ethernet and arp-mirage
opam packages (#380 by @hannesm).
* Upgrade from jbuilder to dune (#391 @avsm)
* Switch from topkg to dune-release (#391 @avsm)
### v3.6.0 (2019-01-04)
* The IPv4 implementation now supports reassembly of IPv4 fragments (#375 by @hannesm)
- using a LRU cache using up to 256KB memory
- out of order fragments are supported
- maximum number of fragments is 16
- timeout between first and last fragment is 10s
- overlapping fragments are dropped
* IPv6: use correct timeout value after first NS message (#334 @djs55)
* Use `Ipaddr.pp` instead of `Ipaddr.pp_hum` due to upstream
interface changes (#385 @hannesm).
### v3.5.1 (2018-11-16)
* socket stack (tcp/udp): catch exception in recv_from and accept (#376 @hannesm)
* use mirage-random-test for testing (Stdlibrandom got removed from mirage-random>1.2.0, #377 @hannesm)
### v3.5.0 (2018-09-16)
* Ipv4: require Mirage_random.C, used for generating IPv4 identifier instead of using OCaml's stdlib Random directly (#371 @hannesm)
* 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)
* adjust to mirage-protocols 1.4.0 and mirage-stack 1.3.0 changes (#371 @hannesm)
Arp no longer contains the type alias ethif
Ethif no longer contains the type alias netif
Static_ipv4 no longer contains the type alias ethif and prefix
Ipv6 no longer contains the type alias ethif and prefix
Mirage_protocols_lwt.IPV4 no longer contains the type alias ethif
Mirage_protocols_lwt.UDPV4 and TCPV4 no longer contain the type alias ip
* remove unused types: 'a config, netif, and id from socket and direct stack (#371 @hannesm)
* remove usage of Result, depending on OCaml >= 4.03.0 (#372 @hannesm)
### v3.4.2 (2018-06-15)
Note the use of the new TCP keep-alive feature can cause excessive amounts
of memory to be used in some circumstances, see
https://github.com/mirage/mirage-tcpip/issues/367
* Ensure a zero UDP checksum is sent as 0xffff, not 0x0000 (#359 @stedolan)
* Avoid leaking a file descriptor in the socket stack if the connection fails (#363 @hannesm)
* Avoid raising an exception with `Lwt.fail` when `write` fails in the socket stack (#363 @hannesm)
* Ignore `EBADF` errors in `close` in the socket stack (#366 @hannesm)
* Emit a warning when TCP keep-alives are used (#368 @djs55)
### v3.4.1 (2018-03-09)
* expose tcp_socket_options in the socket stack, fixing downstream builds (#356 @yomimono)
* add missing dependencies and constraints (#354 @yomimono, #353 @rgrinberg)
* remove leftover ocamlbuild files (#353 @rgrinberg)
### v3.4.0 (2018-02-15)
* Add support for TCP keepalives (#338 @djs55)
* Fix TCP deadlock (#343 @mfp)
* Update the CI to test OCaml 4.04, 4.05, 4.06 (#344 @yomimono)
### v3.3.1 (2017-11-07)
* Add an example for user-space `ping`, and some socket ICMPv4 fixes (#336 @djs55)
* Make tcpip safe-string-safe (and buildable by default on OCaml 4.06.0) (#341 @djs55)
### v3.3.0 (2017-08-08)
* Test with current mirage-www master (#323 @yomimono)
* Improve the Tcp.Wire API (#325 @samoht)
* Add dependency from stack-unix to io-page-unix (@avsm)
* Replace dependency on cstruct.lwt with cstruct-lwt (#322 @yomimono)
* Update to lwt 3.0 (#326 @samoht)
* Replace oUnit with alcotest (#329 @samoht)
* Fix stub linking on Xen (#332 @djs55)
* Add support for ICMP sockets on Windows (#333 @djs55)
### v3.2.0 (2017-06-26)
* port to jbuilder. Build time is now roughly 4-5x faster than the old oasis-based build system.
* packs have been replaced by module aliases.
### v3.1.4 (2017-06-12)
* avoid linking to cstruct.ppx in the compiled library and only use it at build time (#316 @djs55)
* use improved packet size support in `mirage-vnetif>=0.4.0` to test the MTU fixes in #313.
### v3.1.3 (2017-05-23)
* involve the IP layer's MTU in the TCP MSS calculation (hopefully correctly) (#313, by @yomimono)
### v3.1.2 (2017-05-14)
* impose a maximum TCP MSS of 1460 to avoid sending over-large datagrams on 1500 MTU links
(#309, by @hannesm)
### v3.1.1 (2017-05-14)
* fix parsing 20-byte cstructs as ipv4 packets (#307, by @yomimono)
* udp: payload length parse fix (#307, by @yomimono)
* support lwt >= 2.7.0 (#308, by @djs55)
### v3.1.0 (2017-03-14)
* 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)
* 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)
* functorize ipv6 over a random implementation (#298, by @olleolleolle and @hannesm)
* add tests for sending and receiving UDP packets over IPv6 (#300, by @mattgray)
* avoid float in TCP RTO calculations. (#295, by @olleolleolle and @mattgray)
* numerous bugfixes in header marshallers and unmarshallers (#301, by @talex5 and @yomimono)
* replace polymorphic equality in `_packet.equals` functions (#302, by @yomimono)
### v3.0.0 (2017-02-23)
* adapt to MirageOS 3 API changes (*many* PRs, from @hannesm, @samoht, and @yomimono):
- replace error polyvars in many functions with result types
- define and use error types
- `connect` in various modules now returns the device directly or raises an exception
- refer to mirage-protocols and mirage-stacks, rather than mirage-types
* if no UDP source port is given to UDP.write, choose a random one (#272, by @hannesm)
* remove `Ipv4.Routing.No_route_to_destination_address` exception; treat routing failures as normal packet loss in TCP (#269, by @yomimono)
* Ipv6.connect takes a list of IPs (#268, by @yomimono)
* remove exception "Refused" in TCP (#267, by @yomimono)
* remove DHCP module. Users may be interested in the replacement charrua-core (#260, by @yomimono)
* move Ipv4 to Static\_ipv4, which can be used by other IPv4 modules with their own configuration logic (#260, by @yomimono)
* 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)
* remove unused `id` types no longer required by mirage-types (#255, by @yomimono)
* overhaul how `random` is used and handled (#254 and others, by @hannesm)
* fix redundant `memset` that zeroed out options in Tcp\_packet.Marshal.into\_cstruct (#250, by @balrajsingh)
* add vnetif backend for triggering fast retransmit in iperf tests (#248, by @magnuss)
* fixes for incorrect timer values (#247, by @balrajsingh)
* add vnetif backend that drops packets with no payload (#246, by @magnuss)
* fix a race when closing test pcap files (#246, by @magnuss)
### v2.8.1 (2016-09-12)
* Set the TCP congestion window correctly when going into fast-recovery mode. (#244, by @balrajsingh)
* When TCP packet loss is discovered by timeout, allow transition into fast-recovery mode. (#244, by @balrajsingh)
### v2.8.0 (2016-04-04)
* 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)
* Explicitly require the use of an OCaml compiler >= 4.02.3 . (#195 by @yomimono)
* Explicitly depend on `result`. (#195 by @yomimono)
### v2.7.0 (2016-03-20)
* Raise Invalid\_argument if given an invalid port number in listen_{tcp,udp}v4
(#173 by @matildah and #175 by @hannesm)
* Improve TCP options marshalling/unmarshalling (#174 by @yomimono)
* Add state tests and fixes for closure conditions (#177 #176 by @yomimono)
* Remove bogus warning (#178 by @talex5)
* Clean up IPv6 stack (#179 by @nojb)
* RST checking from RFC5961 (#182 by @ppolv)
* Transform EPIPE exceptions into `Eof (#183 by @djs55)
* Improve error strings in IPv4 (#184 by @yomimono)
* Replace use of cstruct.syntax with cstruct.ppx (#188 by @djs55)
* Make the Unix subpackages optional, so the core builds on Win32
(#191 by @djs55)
### v2.6.1 (2015-09-15)
* Add optional arguments for settings in ip v6 and v4 connects (#170, by @Drup)
* Expose `Ipv4.Routing.No_route_to_destination_address` (#166, by @yomimono)
### v2.6.0 (2015-07-29)
* ARP now handles ARP frames, not Ethernet frames with ARP payload
(#164, by @hannesm)
* Check length of received ethernet frame to avoid cstruct exceptions
(#117, by @hannesm)
* Pull arpv4 module out of ipv4. Also add unit-tests for the newly created
ARP library (#155, by @yomimono)
### v2.5.1 (2015-07-07)
* Fix regression introduced in 2.5.0 where packet loss could lead to the
connection to become very slow (#157, MagnusS, @talex5, @yomimono and
@balrajsingh)
* Improve the tests: more logging, more tracing and compile to native code when
available, etc (@MagnusS and @talex5)
* Do not raise `Invalid_argument("Lwt.wakeup_result")` every time a connection
is closed. Also now pass the raised exceptions to `Lwt.async_exception_hook`
instead of ignoring them transparently, so the user can decide to shutdown
its application if something wrong happens (#153, #156, @yomomino and @talex5)
* The `channel` library now lives in a separate repository and is released
separately (#159, @samoht)
### v2.5.0 (2015-06-10)
* The test runs now produce `.pcap` files (#141, by @MagnusS)
* Strip trailing bytes from network packets (#145, by @talex5)
* Add tests for uniform packet loss (#147, by @MagnusS)
* fixed bug where in case of out of order packets the ack and window were set
incorrectly (#140, #146)
* Properly handle RST packets (#107, #148)
* Add a `Log` module to control at runtime the debug statements which are
displayed (#142)
* Writing in a PCB which does not have the right state now returns an error
instead of blocking (#150)
### v2.4.3 (2015-05-05)
* Fix infinite loop in `Channel.read_line` when the line does not contain a CRLF
sequence (#131)
### v2.4.2 (2015-04-29)
* Fix a memory leak in `Channel` (#119, by @yomimono)
* Add basic unit-test for channels (#119, by @yomimono)
* Add alcotest testing templates
* Modernize Travis CI scripts
### v2.4.1 (2015-04-21)
* Merge between 2.4.0 and 2.3.1
### v2.4.0 (2015-03-24)
* ARP improvements (#118)
### v2.3.1 (2015-03-31)
* Do not raise an assertion if an IP frame has extra trailing bytes (#221).
### v2.3.0 (2015-03-09)
* Fix `STACKV4` for the `DEVICE` signature which has `connect` removed
(in Mirage types 2.3+).
### v2.2.3 (2015-03-09)
* Add ICMPv6 error reporting functions (#101)
* Add universal IP address converters (#108)
* Add `error_message` functions for human-readable errors (#98)
* Improve debug logging for ICMP Destination Unreachable packets.
* Filter incoming frames by MAC address to stop sending unnecessary RSTs. (#114)
* Unhook unused modules `Sliding_window` and `Profiler` from the build. (#112)
* Add an explicit `connect` method to the signatures. (#100)
### v2.2.2 (2015-01-11)
* Readded tracing and ARP fixes which got accidentally reverted in the IPv6
merge. (#96)
### v2.2.1 (2014-12-20)
* Use `Bytes` instead of `String` to begin the `-safe-string` migration in OCaml
4.02.0 (#93).
* Remove dependency on `uint` to avoid the need for a C stub (#92).
### v2.2.0 (2014-12-18)
Add IPv6 support. This changeset minimises interface changes to the existing
`STACKV4` interfaces to facilitate a progressive merge. The only visible
interface changes are:
* `IPV4.set_ipv4_*` functions have been renamed `IPV4.set_ip_*` because they
are shared between IPV4 and IPV6.
* `IPV4.get_ipv4` and `get_ipv4_netmask` now return a `list` of `Ipaddr.V4.t`
(again because this is the common semantics with IPV6.)
* Several types that had `v4` in their names (like `IPV4.ipv4addr`) have lost
that particle.
### v2.1.1 (2014-12-12)
* Improve console printing for the DHCP client to output line
breaks properly on Xen consoles.
### v2.1.0 (2014-12-07)
* Build Xen stubs separately, with `CFLAGS` from `mirage-xen` 2.1.0+.
This allows us to use the red zone under x86_64 Unix again.
* Adding tracing labels and counters, which introduces a new dependency on the
`mirage-profile` package.
### v2.0.3 (2014-12-05)
* Fixed race waiting for ARP response (#86).
* Move the the code that configures IPv4 address, netmask and gateways
after receiving a successful lease out of the `Dhcp_clientv4` module
and into `Stackv4` (#87)
### v2.0.2 (2014-12-01)
* Add IPv4 multicast to MAC address mapping in IPv4 output processing
(#81 from Luke Dunstan).
* Improve formatting of DHCP console logging, including printing out options
(#83).
* Build with -mno-red-zone on x86_64 to avoid stack corruption on Xen (#80).
### v2.0.1 (2014-11-04)
* Fixed race condition in the signalling between the rx/tx threads under load.
* Experimentally switch to immediate ACKs in TCPv4 by default instead of delayed ones.
### v2.0.0 (2014-11-02)
* Moved 1s complement checksum C code here from mirage-platform.
* Depend on `Console_unix` and `Console_xen` instead of `Console`.
* [socket] Do not return an `Eof` when writing 0-length buffer (#76).
* [socket] Accept callbacks now run in async threads instead of being serialised
(#75).
### v1.1.6 (2014-07-20)
* Quieten down the stack logging rate by not announcing IPv6 packet discards.
* Raise exception `Bad_option` for unparsable or invalid TCPv4 options (#57).
* Fix linking error with module `Tcp_checksum` by lifting it into top library
(#60).
* Add `opam` file to permit easier local pinning, and fix Travis to use this.
### v1.1.5 (2014-06-18)
* Ensure that DHCP completes before the application is started, so that
unikernels that establish outgoing connections can do so without a race.
(fix from Mindy Preston in #53, followup in #55)
* Add `echo`, `chargen` and `discard` services into the `examples/`
directory. (from Mindy Preston in #52).
### v1.1.4 (2014-06-03)
* [tcp] Fully process the last `ACK` in a 3-way handshake for server connections.
This ensures that a `FIN` is correctly transmitted upon application-initiated
connection close. (fix from Mindy Preston in #51).
### v1.1.3 (2014-03-01)
* Expose IPV4 through the STACKV4 interface.
### v1.1.2 (2014-03-27)
* Fix DHCP variable length option parsing for MTU responses, which
in turns improves robustness on Amazon EC2 (fix from @yomimono
via mirage/mirage-tcpip#48)
### v1.1.1 (2014-02-21)
* Catch and ignore top-level socket exceptions (#219).
* Set `SO_REUSEADDR` on listening sockets for Unix (#218).
* Adapt the Stack interfaces to the v1.1.1 mirage-types interface
(see mirage/mirage#226 for details).
### v1.1.0 (2014-02-03)
* Rewrite of the library as a set of functors that parameterize the
stack across the `V1_LWT` module types from Mirage 1.1.x. This removes
the need to compile separate Xen and Unix versions of the stack.
### v0.9.5 (2013-12-08)
* Build for either Xen or Unix, depending on the value of the `OS` envvar.
* Shift to the `mirage-types` 0.5.0+ interfaces, which breaks the
socket backend (temporarily).
* Port the direct stack to the new interfaces.
* Add Travis CI scripts.
### v0.9.4 (2013-08-09)
* Use the `Ipaddr` external library and remove the Homebrew
equivalents in `Nettypes`.
### v0.9.3 (2013-07-18)
* Changes in module Manager: Removed some functions from the `.mli
(plug/unplug) and added some modifications in the way the Manager
interacts with the underlying module Netif. The Netif.create function
does not take a callback anymore.
### v0.9.2 (2013-07-09)
* Improve TCP state machine for connection teardown.
* Limit fragment number to 8, and coalesce buffers if it goes higher.
* Adapt to mirage-platform-0.9.2 API changes.
### v0.9.1 (2013-06-12)
* Depend on mirage-platform-0.9.1 direct tuntap interfaces.
* Version bump to catch up with mirage-platform.
### v0.5.2 (2013-02-08)
* Encourage scatter-gather I/O all the time, rather than playing tricks
with packet header buffers. This simplifies the output path considerably
and cuts minor heap allocations down.
* Install the packed `cmx` along with the `cmxa` to ensure that the
compiler can do cross-module optimization (this is not a fatal error,
but will impact performance if the `cmx` file is not present).
### v0.5.1 (2012-12-20)
* Update socket stack to use Cstruct 0.6.0 API
### v0.5.0 (2012-12-20)
* Update Cstruct API to 0.6.0
* [tcp] write now blocks if the write buffer and write window are full
### v0.4.1 (2012-12-14)
* Add iperf self-test that creates two VIFs and transmits across
them. This is a useful local test which stresses the bridge
code using just one VM.
* Add support for attaching existing devices when initialising the
network manager, via an optional `attached` parameter.
* Constrain TCP connect to be a `unit Lwt.t` instead of a polymorphic
return value.
* Expose IPv4 netmask function.
* Reduce ARP verbosity to the console.
* Fix TCP fast recovery to wait until all in-flight packets are
acked, rather then exiting early.
### v0.4.0 (2012-12-11)
* Require OCaml-4.00.0 or higher, and add relevant build fixes
to deal with module packing.
### v0.3.1 (2012-12-10)
* Fix the DHCP client marshalling for IPv4 addresses.
* Expose the interface MAC address in the Manager signature.
* Tweak TCP ISN calculation to be more friendly on a 32-bit host.
* Add Manager.create ?devs to control the number of Netif devices
constructed by default.
* Add Ethif.set/disable_promiscuous to permit directly tapping
a network interface.
### v0.3.0 (2012-09-04)
* Initial public release.

34
unikernel/duniverse/mirage-tcpip/LICENSE.md Normal file
View file

@ -0,0 +1,34 @@
Copyright (c) Anil Madhavapeddy <anil@recoil.org>
Copyright (c) Balraj Singh <balrajsingh@ieee.org>
Copyright (c) Citrix Inc
Copyright (c) David Scott <dave@recoil.org>
Copyright (c) Docker Inc
Copyright (c) Drup <drupyog@zoho.com>
Copyright (c) Gabor Pali <pali.gabor@gmail.com>
Copyright (c) Hannes Mehnert <hannes@mehnert.org>
Copyright (c) Haris Rotsos <cr409@cam.ac.uk>
Copyright (c) Kia <sadieperkins@riseup.net>
Copyright (c) Luke Dunstan <LukeDunstan81@gmail.com>
Copyright (c) Magnus Skjegstad <magnus@skjegstad.com>
Copyright (c) Mindy Preston <meetup@yomimono.org>
Copyright (c) Nicolas Ojeda Bar <n.oje.bar@gmail.com>
Copyright (c) Pablo Polvorin <ppolvorin@process-one.net>
Copyright (c) Richard Mortier <mort@cantab.net>
Copyright (c) Thomas Gazagnaire <thomas@gazagnaire.org>
Copyright (c) Thomas Leonard <talex5@gmail.com>
Copyright (c) Tim Cuthbertson <tim@gfxmonk.net>
Copyright (c) Vincent Bernardoff <vb@luminar.eu.org>
Copyright (c) lnmx <len@lnmx.org>
Copyright (c) pqwy <david@numm.org>
Permission to use, copy, modify, and distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

17
unikernel/duniverse/mirage-tcpip/Makefile Normal file
View file

@ -0,0 +1,17 @@
.PHONY: build clean test
build:
dune build
test:
dune runtest
install:
dune install
uninstall:
dune uninstall
clean:
dune clean

48
unikernel/duniverse/mirage-tcpip/README.md Normal file
View file

@ -0,0 +1,48 @@
# mirage-tcpip - an OCaml TCP/IP networking stack
`mirage-tcpip` provides a networking stack for the [Mirage operating
system](https://mirage.io). It provides implementations for the following module types
(which correspond with the similarly-named protocols):
* IP (via the IPv4 and IPv6 modules)
* ICMP
* UDP
* TCP
## Implementations
There are two implementations of the IP, ICMP, UDP, and TCP module types -
the `socket` stack, and the `direct` stack.
### The `socket` stack
The `socket` stack uses socket calls to a traditional operating system to
provide the functionality described in the module types.
See the [`src/stack-unix/`](./src/stack-unix/) directory for the modules used as implementations of the
`socket` stack.
The `socket` stack is used for testing or other applications which do not
expect to run as unikernels.
### The `direct` stack
The `direct` stack expects to write to a device implementing the `NETIF` module
type defined for MirageOS.
See the [`src/`](./src/) directory for the modules used as implementations of the
`direct` stack, which is the expected stack for most MirageOS applications.
The `direct` stack is the only usable set of implementations for
applications which will run as unikernels on a hypervisor target.
## Community
* WWW: <https://mirage.io>
* E-mail: <mirageos-devel@lists.xenproject.org>
* Issues: <https://github.com/mirage/mirage-tcpip/issues>
* API docs: <http://docs.mirage.io/tcpip/index.html>
## License
`mirage-tcpip` is distributed under the ISC license.

4
unikernel/duniverse/mirage-tcpip/dune-project Normal file
View file

@ -0,0 +1,4 @@
(lang dune 2.7)
(name tcpip)
(version v9.0.1)
(formatting disabled)

3
unikernel/duniverse/mirage-tcpip/examples/ping/dune Normal file
View file

@ -0,0 +1,3 @@
(executables
(names ping)
(libraries cmdliner logs logs.fmt tcpip.icmpv4-socket tcpip))

174
unikernel/duniverse/mirage-tcpip/examples/ping/ping.ml Normal file
View file

@ -0,0 +1,174 @@
let src =
let src = Logs.Src.create "ping" ~doc:"Mirage ping" in
Logs.Src.set_level src (Some Logs.Info);
src
module Log = (val Logs.src_log src : Logs.LOG)
(* Construct a payload buffer of a given size *)
let make_payload ~size () =
let buf = Cstruct.create size in
let pattern = "plz reply i'm so lonely" in
for i = 0 to Cstruct.length buf - 1 do
Cstruct.set_char buf i pattern.[i mod (String.length pattern)]
done;
buf
let seq_no_to_send_time = Hashtbl.create 7
let nr_transmitted = ref 0
let nr_received = ref 0
let min_ms = ref max_float
let max_ms = ref 0.
(* to compute the standard deviation, we store the sum and the sum of squares *)
let sum_ms = ref 0.
let sum_ms_2 = ref 0.
(* Send ICMP ECHO_REQUEST packets forever *)
let send_echo_requests ~stack ~payload ~dst () =
let rec send seq_no =
let open Lwt.Infix in
let id_no = 0x1234 in
let req = Icmpv4_packet.({code = 0x00; ty = Icmpv4_wire.Echo_request;
subheader = Id_and_seq (id_no, seq_no)}) in
let header = Icmpv4_packet.Marshal.make_cstruct req ~payload in
let echo_request = Cstruct.concat [ header; payload ] in
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));
Icmpv4_socket.write stack ~dst echo_request
>>= function
| Ok () ->
Hashtbl.replace seq_no_to_send_time seq_no (Unix.gettimeofday ());
incr nr_transmitted;
Lwt_unix.sleep 1.
>>= fun () ->
send (seq_no + 1)
| Error e ->
Log.err (fun f -> f "Error sending ICMP to %s: %a" (Ipaddr.V4.to_string dst) Icmpv4_socket.pp_error e);
Lwt.return_unit in
send 0
(* Return a thread and a receiver callback. The thread is woken up when we have
received [count] packets *)
let make_receiver ~count ~payload () =
let finished_t, finished_u = Lwt.task () in
let callback buf =
Log.debug (fun f -> f "Received IP %a" Cstruct.hexdump_pp buf);
match Ipv4_packet.Unmarshal.of_cstruct buf with
| Error msg ->
Log.err (fun f -> f "Error unmarshalling IP datagram: %s" msg);
Lwt.return_unit
| Ok (ip, ip_payload) ->
match Icmpv4_packet.Unmarshal.of_cstruct ip_payload with
| Error msg ->
Log.err (fun f -> f "Error unmarshalling ICMP message: %s" msg);
Lwt.return_unit
| Ok (reply, received_payload) ->
let open Icmpv4_packet in
begin match reply.subheader with
| Next_hop_mtu _ | Pointer _ | Address _ | Unused ->
Log.err (fun f -> f "received an ICMP message which wasn't an echo-request or reply");
Lwt.return_unit
| Id_and_seq (_id, seq) ->
if reply.code <> 0
then Log.err (fun f -> f "received an ICMP ECHO_REQUEST with reply.code=%d" reply.code);
if not(Cstruct.equal payload received_payload)
then Log.err (fun f -> f "received an ICMP ECHO_REQUEST with an unexpected payload");
if not(Hashtbl.mem seq_no_to_send_time seq)
then Log.err (fun f -> f "received an ICMP ECHO_REQUEST with an unexpected sequence number")
else begin
let secs = Unix.gettimeofday () -. (Hashtbl.find seq_no_to_send_time seq) in
Hashtbl.remove seq_no_to_send_time seq;
let ms = secs *. 1000.0 in
Printf.printf "%d bytes from %s: icmp_seq=%d ttl=%d time=%f ms\n%!"
(Cstruct.length payload) (Ipaddr.V4.to_string ip.Ipv4_packet.src) seq ip.Ipv4_packet.ttl ms;
incr nr_received;
min_ms := min !min_ms ms;
max_ms := max !max_ms ms;
sum_ms := !sum_ms +. ms;
sum_ms_2 := !sum_ms_2 +. (ms *. ms);
if Some !nr_received = count then begin
Log.debug (fun f -> f "Finished after %d packets received" !nr_received);
Lwt.wakeup_later finished_u ();
end
end;
Lwt.return_unit
end in
finished_t, callback
let ping (count:int option) (size:int) (timeout:int option) dst =
let dst = Ipaddr.V4.of_string_exn dst in
Lwt_main.run begin
let open Lwt.Infix in
let payload = make_payload ~size () in
Icmpv4_socket.connect ()
>>= fun stack ->
let finished, on_icmp_receive = make_receiver ~count ~payload () in
let me = Ipaddr.V4.any in
let listener = Icmpv4_socket.listen stack me on_icmp_receive in
let timeout = match timeout with
| None ->
let forever, _ = Lwt.task () in
forever
| Some t ->
Lwt_unix.sleep (float_of_int t)
>>= fun () ->
Log.debug (fun f -> f "Timed-out");
Lwt.return_unit in
let sender = send_echo_requests ~stack ~payload ~dst () in
let interrupted, interrupted_u = Lwt.task () in
ignore(Lwt_unix.on_signal Sys.sigint (fun _ -> Lwt.wakeup_later interrupted_u ()));
Lwt.pick [
finished;
timeout;
interrupted;
listener;
sender;
]
>>= fun () ->
Printf.printf "--- %s ping statistics ---\n" (Ipaddr.V4.to_string dst);
let n = float_of_int (!nr_received) in
let percent_loss = 100. *. (float_of_int (!nr_transmitted) -. n) /. (float_of_int (!nr_transmitted)) in
Printf.printf "%d packets transmitted, %d packets received, %0.0f%% packet loss\n"
!nr_transmitted !nr_received percent_loss;
let avg_ms = !sum_ms /. n in
let variance_ms = 1. /. (n -. 1.) *. (!sum_ms_2) -. 1. /. (n *. (n -. 1.)) *. (!sum_ms) *. (!sum_ms) in
let stddev_ms = sqrt variance_ms in
Printf.printf "round-trip min/avg/max/stddev = %.03f/%.03f/%.03f/%.03f ms\n"
!min_ms avg_ms !max_ms stddev_ms;
Lwt.return (`Ok ())
end
open Cmdliner
let exit_after_success =
let doc = "Exit successfully after receiving one reply packet." in
Arg.(value & flag & info [ "o" ] ~doc)
let count =
let doc = "Stop after sending (and receiving) count ECHO_RESPONSE packets. If not specified, ping will continue until interrupted." in
Arg.(value & opt (some int) None & info [ "c" ] ~doc)
let size =
let doc = "Specify the number of data bytes to be sent." in
Arg.(value & opt int 56 & info [ "s" ] ~doc)
let timeout =
let doc = "Specify a timeout, before ping exits regardless of how many packets have been received." in
Arg.(value & opt (some int) None & info [ "t" ] ~doc)
let destination =
let doc ="Hostname or IP address of destination host" in
Arg.(value & pos 0 string "" & info [] ~doc)
let cmd =
let doc = "Send ICMP ECHO_REQUEST packets and listen for ECHO_RESPONSES" in
let man = [
`S "DESCRIPTION";
`P "Send a sequence of ICMP ECHO_REQUEST packets to a network host and count the responses. When the program exits, display some statistics.";
] in
Cmd.v (Cmd.info "ping" ~doc ~man) (Term.(ret(const ping $ count $ size $ timeout $ destination)))
let _ =
Logs.set_reporter (Logs_fmt.reporter ());
exit (Cmd.eval cmd)

11
unikernel/duniverse/mirage-tcpip/examples/unikernel/config.ml Normal file
View file

@ -0,0 +1,11 @@
(* mirage >= 4.6.0 & < 4.10.0 *)
open Mirage
let main =
let packages = [ package ~min:"2.9.0" "ipaddr" ] in
main ~packages "Services.Main" (stackv4v6 @-> job)
let stack = generic_stackv4v6 default_network
let () = register "services" [ main $ stack ]

55
unikernel/duniverse/mirage-tcpip/examples/unikernel/services.ml Normal file
View file

@ -0,0 +1,55 @@
open Lwt.Infix
module Main (S: Tcpip.Stack.V4V6) = struct
let report_and_close flow pp e message =
let ip, port = S.TCP.dst flow in
Logs.warn
(fun m -> m "closing connection from %a:%d due to error %a while %s"
Ipaddr.pp ip port pp e message);
S.TCP.close flow
let rec chargen flow how_many start_at =
let charpool =
"!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~ "
in
let make_chars how_many start_at =
let output = (String.sub (charpool ^ charpool) start_at how_many) ^ "\n" in
Cstruct.of_string output
in
S.TCP.write flow (make_chars how_many start_at) >>= function
| Ok () ->
chargen flow how_many ((start_at + 1) mod (String.length charpool))
| Error e -> report_and_close flow S.TCP.pp_write_error e "writing in Chargen"
let rec discard flow =
S.TCP.read flow >>= fun result -> (
match result with
| Error e -> report_and_close flow S.TCP.pp_error e "reading in Discard"
| Ok `Eof -> report_and_close flow Fmt.string "end of file" "reading in Discard"
| Ok (`Data _) -> discard flow
)
let rec echo flow =
S.TCP.read flow >>= function
| Error e -> report_and_close flow S.TCP.pp_error e "reading in Echo"
| Ok `Eof -> report_and_close flow Fmt.string "end of file" "reading in Echo"
| Ok (`Data buf) ->
S.TCP.write flow buf >>= function
| Ok () -> echo flow
| Error e -> report_and_close flow S.TCP.pp_write_error e "writing in Echo"
let start s =
(* RFC 862 - read payloads and repeat them back *)
S.TCP.listen (S.tcp s) ~port:7 echo;
(* RFC 863 - discard all incoming data and never write a payload *)
S.TCP.listen (S.tcp s) ~port:9 discard;
(* RFC 864 - write data without regard for input *)
S.TCP.listen (S.tcp s) ~port:19 (fun flow -> chargen flow 75 0);
S.listen s
end

6
unikernel/duniverse/mirage-tcpip/src/core/dune Normal file
View file

@ -0,0 +1,6 @@
(library
(name tcpip)
(public_name tcpip)
(instrumentation
(backend bisect_ppx))
(libraries cstruct lwt fmt ipaddr mirage-flow duration))

38
unikernel/duniverse/mirage-tcpip/src/core/ip.ml Normal file
View file

@ -0,0 +1,38 @@
type error = [
| `No_route of string (** can't send a message to that destination *)
| `Would_fragment
]
let pp_error ppf = function
| `No_route s -> Fmt.pf ppf "no route to destination: %s" s
| `Would_fragment -> Fmt.string ppf "would fragment"
type proto = [ `TCP | `UDP | `ICMP ]
let pp_proto ppf = function
| `TCP -> Fmt.string ppf "TCP"
| `UDP -> Fmt.string ppf "UDP"
| `ICMP -> Fmt.string ppf "ICMP"
module type S = sig
type nonrec error = private [> error]
val pp_error: error Fmt.t
type ipaddr
val pp_ipaddr : ipaddr Fmt.t
type prefix
val pp_prefix : prefix Fmt.t
type t
val disconnect : t -> unit Lwt.t
type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
val input:
t ->
tcp:callback -> udp:callback -> default:(proto:int -> callback) ->
Cstruct.t -> unit Lwt.t
val write: t -> ?fragment:bool -> ?ttl:int ->
?src:ipaddr -> ipaddr -> proto -> ?size:int -> (Cstruct.t -> int) ->
Cstruct.t list -> (unit, error) result Lwt.t
val pseudoheader : t -> ?src:ipaddr -> ipaddr -> proto -> int -> Cstruct.t
val src: t -> dst:ipaddr -> ipaddr
val get_ip: t -> ipaddr list
[@@ocaml.deprecated "this function will be removed soon, use [configured_ips] instead."]
val configured_ips: t -> prefix list
val mtu: t -> dst:ipaddr -> int
end

98
unikernel/duniverse/mirage-tcpip/src/core/ip.mli Normal file
View file

@ -0,0 +1,98 @@
(** {2 IP layer} *)
(** IP errors and protocols. *)
type error = [
| `No_route of string (** can't send a message to that destination *)
| `Would_fragment (** would need to fragment, but fragmentation is disabled *)
]
val pp_error : error Fmt.t
type proto = [ `TCP | `UDP | `ICMP ]
val pp_proto: proto Fmt.t
(** An Internet Protocol (IP) layer reassembles IP fragments into packets,
removes the IP header, and on the sending side fragments overlong payload
and inserts IP headers. *)
module type S = sig
type nonrec error = private [> error]
(** The type for IP errors. *)
val pp_error: error Fmt.t
(** [pp_error] is the pretty-printer for errors. *)
type ipaddr
(** The type for IP addresses. *)
val pp_ipaddr : ipaddr Fmt.t
(** [pp_ipaddr] is the pretty-printer for IP addresses. *)
type prefix
(** The type for the IP address and netmask. *)
val pp_prefix : prefix Fmt.t
(** [pp_prefix] is the pretty-printer for the prefix. *)
type t
(** The type representing the internal state of the IP layer. *)
val disconnect: t -> unit Lwt.t
(** Disconnect from the IP layer. While this might take some time to
complete, it can never result in an error. *)
type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
(** An input continuation used by the parsing functions to pass on
an input packet down the stack.
[callback ~src ~dst buf] will be called with [src] and [dst]
containing the source and destination IP address respectively,
and [buf] will be a buffer pointing at the start of the IP
payload. *)
val input:
t ->
tcp:callback -> udp:callback -> default:(proto:int -> callback) ->
Cstruct.t -> unit Lwt.t
(** [input ~tcp ~udp ~default ip buf] demultiplexes an incoming
[buffer] that contains an IP frame. It examines the protocol
header and passes the result onto either the [tcp] or [udp]
function, or the [default] function for unknown IP protocols. *)
val write: t -> ?fragment:bool -> ?ttl:int ->
?src:ipaddr -> ipaddr -> proto -> ?size:int -> (Cstruct.t -> int) ->
Cstruct.t list -> (unit, error) result Lwt.t
(** [write t ~fragment ~ttl ~src dst proto ~size headerf payload] allocates a
buffer, writes the IP header, and calls the headerf function. This may
write to the provided buffer of [size] (default 0). If [size + ip header]
exceeds the maximum transfer unit, an error is returned. The [payload] is
appended. The optional [fragment] argument defaults to [true], in which
case multiple IP-fragmented frames are sent if the payload is too big for a
single frame. When it is [false], the don't fragment bit is set and if the
payload and header would exceed the maximum transfer unit, an error is
returned. *)
val pseudoheader : t -> ?src:ipaddr -> ipaddr -> proto -> int -> Cstruct.t
(** [pseudoheader t ~src dst proto len] gives a pseudoheader suitable for use in
TCP or UDP checksum calculation based on [t]. *)
val src: t -> dst:ipaddr -> ipaddr
(** [src ip ~dst] is the source address to be used to send a
packet to [dst]. In the case of IPv4, this will always return
the same IP, which is the only one set. *)
val get_ip: t -> ipaddr list
[@@ocaml.deprecated "this function will be removed soon, use [configured_ips] instead."]
(** Get the IP addresses associated with this interface. For IPv4, only
one IP address can be set at a time, so the list will always be of
length 1 (and may be the default value, [[10.0.0.2]]). *)
val configured_ips: t -> prefix list
(** Get the prefix associated with this interface. For IPv4, only
one prefix can be set at a time, so the list will always be of
length 1, e.g. [[10.0.0.2/24]]. *)
val mtu: t -> dst:ipaddr -> int
(** [mtu ~dst ip] is the Maximum Transmission Unit of the [ip] i.e. the
maximum size of the payload, not including the IP header. *)
end

32
unikernel/duniverse/mirage-tcpip/src/core/stack.ml Normal file
View file

@ -0,0 +1,32 @@
module type V4V6 = sig
type t
(** The type representing the internal state of the dual IPv4 and IPv6 stack. *)
val disconnect: t -> unit Lwt.t
(** Disconnect from the dual IPv4 and IPv6 stack. While this might take some
time to complete, it can never result in an error. *)
module UDP: Udp.S with type ipaddr = Ipaddr.t
module TCP: Tcp.S with type ipaddr = Ipaddr.t
module IP: Ip.S with type ipaddr = Ipaddr.t and type prefix = Ipaddr.Prefix.t
val udp: t -> UDP.t
(** [udp t] obtains a descriptor for use with the [UDP] module,
usually to transmit traffic. *)
val tcp: t -> TCP.t
(** [tcp t] obtains a descriptor for use with the [TCP] module,
usually to initiate outgoing connections. *)
val ip: t -> IP.t
(** [ip t] obtains a descriptor for use with the [IP] module,
which can handle raw IPv4 and IPv6 frames, or manipulate IP address
configuration on the stack interface. *)
val listen: t -> unit Lwt.t
(** [listen t] requests that the stack listen for traffic on the
network interface associated with the stack, and demultiplex
traffic to the appropriate callbacks. *)
end

40
unikernel/duniverse/mirage-tcpip/src/core/tcp.ml Normal file
View file

@ -0,0 +1,40 @@
type error = [ `Timeout | `Refused]
type write_error = [ error | Mirage_flow.write_error]
let pp_error ppf = function
| `Timeout -> Fmt.string ppf "connection attempt timed out"
| `Refused -> Fmt.string ppf "connection attempt was refused"
let pp_write_error ppf = function
| #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e
| #error as e -> pp_error ppf e
module Keepalive = struct
type t = {
after: Duration.t;
interval: Duration.t;
probes: int;
}
end
module type S = sig
type nonrec error = private [> error]
type nonrec write_error = private [> write_error]
type ipaddr
type flow
type t
val disconnect : t -> unit Lwt.t
include Mirage_flow.S with
type flow := flow
and type error := error
and type write_error := write_error
val dst: flow -> ipaddr * int
val src: flow -> ipaddr * int
val write_nodelay: flow -> Cstruct.t -> (unit, write_error) result Lwt.t
val writev_nodelay: flow -> Cstruct.t list -> (unit, write_error) result Lwt.t
val create_connection: ?keepalive:Keepalive.t -> t -> ipaddr * int -> (flow, error) result Lwt.t
val listen : t -> port:int -> ?keepalive:Keepalive.t -> (flow -> unit Lwt.t) -> unit
val unlisten : t -> port:int -> unit
val input: t -> src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
end

99
unikernel/duniverse/mirage-tcpip/src/core/tcp.mli Normal file
View file

@ -0,0 +1,99 @@
type error = [ `Timeout | `Refused]
type write_error = [ error | Mirage_flow.write_error ]
val pp_error : error Fmt.t
val pp_write_error : write_error Fmt.t
(** Configuration for TCP keep-alives.
Keep-alive messages are probes sent on an idle connection. If no traffic
is received after a certain number of probes are sent, then the connection
is assumed to have been lost. *)
module Keepalive: sig
type t = {
after: Duration.t; (** initial delay before sending probes on an idle
connection *)
interval: Duration.t; (** interval between successive probes *)
probes: int; (** total number of probes to send before assuming
that, if the connection is still idle it has
been lost *)
}
(** Configuration for TCP keep-alives *)
end
(** Transmission Control Protocol layer: reliable ordered streaming
communication. *)
module type S = sig
type nonrec error = private [> error]
(** The type for TCP errors. *)
type nonrec write_error = private [> write_error]
(** The type for TCP write errors. *)
type ipaddr
(** The type for IP address representations. *)
type flow
(** A flow represents the state of a single TCP stream that is connected
to an endpoint. *)
type t
(** The type representing the internal state of the TCP layer. *)
val disconnect: t -> unit Lwt.t
(** Disconnect from the TCP layer. While this might take some time to
complete, it can never result in an error. *)
include Mirage_flow.S with
type flow := flow
and type error := error
and type write_error := write_error
val dst: flow -> ipaddr * int
(** Get the destination IP address and destination port that a
flow is currently connected to. *)
val src : flow -> ipaddr * int
(** Get the source IP address and source port that a flow is currently
connected to. *)
val write_nodelay: flow -> Cstruct.t -> (unit, write_error) result Lwt.t
(** [write_nodelay flow buffer] writes the contents of [buffer]
to the flow. The thread blocks until all data has been successfully
transmitted to the remote endpoint.
Buffering within the layer is minimized in this mode.
Note that this API will change in a future revision to be a
per-flow attribute instead of a separately exposed function. *)
val writev_nodelay: flow -> Cstruct.t list -> (unit, write_error) result Lwt.t
(** [writev_nodelay flow buffers] writes the contents of [buffers]
to the flow. The thread blocks until all data has been successfully
transmitted to the remote endpoint.
Buffering within the layer is minimized in this mode.
Note that this API will change in a future revision to be a
per-flow attribute instead of a separately exposed function. *)
val create_connection: ?keepalive:Keepalive.t -> t -> ipaddr * int -> (flow, error) result Lwt.t
(** [create_connection ~keepalive t (addr,port)] opens a TCP connection
to the specified endpoint.
If the optional argument [?keepalive] is provided then TCP keep-alive
messages will be sent to the server when the connection is idle. If
no responses are received then eventually the connection will be disconnected:
[read] will return [Ok `Eof] and write will return [Error `Closed] *)
val listen : t -> port:int -> ?keepalive:Keepalive.t -> (flow -> unit Lwt.t) -> unit
(** [listen t ~port ~keepalive callback] listens on [port]. The [callback] is
executed for each flow that was established. If [keepalive] is provided,
this configuration will be applied before calling [callback].
@raise Invalid_argument if [port < 0] or [port > 65535]
*)
val unlisten : t -> port:int -> unit
(** [unlisten t ~port] stops any listener on [port]. *)
val input: t -> src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
(** [input t] returns an input function continuation to be
passed to the underlying {!IP} layer. *)
end

13
unikernel/duniverse/mirage-tcpip/src/core/udp.ml Normal file
View file

@ -0,0 +1,13 @@
module type S = sig
type error
val pp_error: error Fmt.t
type ipaddr
type t
val disconnect : t -> unit Lwt.t
type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t
val listen : t -> port:int -> callback -> unit
val unlisten : t -> port:int -> unit
val input: t -> src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
val write: ?src:ipaddr -> ?src_port:int -> ?ttl:int -> dst:ipaddr -> dst_port:int -> t -> Cstruct.t ->
(unit, error) result Lwt.t
end

46
unikernel/duniverse/mirage-tcpip/src/core/udp.mli Normal file
View file

@ -0,0 +1,46 @@
(** User datagram protocol layer: connectionless message-oriented
communication. *)
module type S = sig
type error (* entirely abstract since we expose none in a Udp module *)
(** The type for UDP errors. *)
val pp_error: error Fmt.t
(** [pp] is the pretty-printer for errors. *)
type ipaddr
(** The type for an IP address representations. *)
type t
(** The type representing the internal state of the UDP layer. *)
val disconnect: t -> unit Lwt.t
(** Disconnect from the UDP layer. While this might take some time to
complete, it can never result in an error. *)
type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t
(** The type for callback functions that adds the UDP metadata for
[src] and [dst] IP addresses, the [src_port] of the
connection and the [buffer] payload of the datagram. *)
val listen : t -> port:int -> callback -> unit
(** [listen t ~port callback] executes [callback] for each packet received
on [port].
@raise Invalid_argument if [port < 0] or [port > 65535] *)
val unlisten : t -> port:int -> unit
(** [unlisten t ~port] stops any listeners on [port]. *)
val input: t -> src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
(** [input t] demultiplexes incoming datagrams based on
their destination port. *)
val write: ?src:ipaddr -> ?src_port:int -> ?ttl:int -> dst:ipaddr ->
dst_port:int -> t -> Cstruct.t -> (unit, error) result Lwt.t
(** [write ~src ~src_port ~ttl ~dst ~dst_port udp data] is a task
that writes [data] from an optional [src] and [src_port] to a [dst]
and [dst_port] IP address pair. An optional time-to-live ([ttl]) is passed
through to the IP layer. *)
end

7
unikernel/duniverse/mirage-tcpip/src/icmp/dune Normal file
View file

@ -0,0 +1,7 @@
(library
(name tcpip_icmpv4)
(public_name tcpip.icmpv4)
(instrumentation
(backend bisect_ppx))
(libraries logs tcpip ipaddr tcpip.checksum)
(wrapped false))

82
unikernel/duniverse/mirage-tcpip/src/icmp/icmpv4.ml Normal file
View file

@ -0,0 +1,82 @@
module type S = sig
type t
val disconnect : t -> unit Lwt.t
type ipaddr = Ipaddr.V4.t
type error
val pp_error: error Fmt.t
val input : t -> src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
val write : t -> ?src:ipaddr -> dst:ipaddr -> ?ttl:int -> Cstruct.t -> (unit, error) result Lwt.t
end
open Lwt.Infix
let src = Logs.Src.create "icmpv4" ~doc:"Mirage ICMPv4"
module Log = (val Logs.src_log src : Logs.LOG)
module Make (IP : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) = struct
type ipaddr = Ipaddr.V4.t
type t = {
ip : IP.t;
echo_reply : bool;
}
type error = [ `Ip of IP.error ]
let pp_error ppf (`Ip e) = IP.pp_error ppf e
let connect ip =
let t = { ip; echo_reply = true } in
Lwt.return t
let disconnect _ = Lwt.return_unit
let writev t ?src ~dst ?ttl bufs =
IP.write t.ip ?src dst ?ttl `ICMP (fun _ -> 0) bufs >|= function
| Ok () -> Ok ()
| Error e ->
Log.warn (fun f -> f "Error sending IP packet: %a" IP.pp_error e);
Error (`Ip e)
let write t ?src ~dst ?ttl buf = writev t ?src ~dst ?ttl [buf]
let input t ~src ~dst:_ buf =
let open Icmpv4_packet in
match Unmarshal.of_cstruct buf with
| Error s ->
Log.info (fun f ->
f "ICMP: error parsing message from %a: %s" Ipaddr.V4.pp src s);
Lwt.return_unit
| Ok (message, payload) ->
match message.ty, message.subheader with
| Echo_reply, _ ->
Log.info (fun f ->
f "ICMP: discarding echo reply from %a" Ipaddr.V4.pp src);
Lwt.return_unit
| Destination_unreachable, _ ->
Log.info (fun f ->
f "ICMP: destination unreachable from %a" Ipaddr.V4.pp src);
Lwt.return_unit
| Echo_request, Id_and_seq (id, seq) ->
Log.debug (fun f ->
f "ICMP echo-request received: %a (payload %a)"
Icmpv4_packet.pp message Cstruct.hexdump_pp payload);
if t.echo_reply then begin
let icmp = {
code = 0x00;
ty = Echo_reply;
subheader = Id_and_seq (id, seq);
} in
writev t ~dst:src [ Marshal.make_cstruct icmp ~payload; payload ]
>|= function
| Ok () -> ()
| Error (`Ip e) ->
Log.warn (fun f -> f "Unable to send ICMP echo-reply: %a" IP.pp_error e); ()
end else Lwt.return_unit
| ty, _ ->
Log.info (fun f ->
f "ICMP unknown ty %s from %a"
(Icmpv4_wire.ty_to_string ty) Ipaddr.V4.pp src);
Lwt.return_unit
end

36
unikernel/duniverse/mirage-tcpip/src/icmp/icmpv4.mli Normal file
View file

@ -0,0 +1,36 @@
(** {2 ICMP layer} *)
(** Internet Control Message Protocol: error messages and operational
information. *)
module type S = sig
type t
(** The type representing the internal state of the ICMP layer. *)
val disconnect: t -> unit Lwt.t
(** Disconnect from the ICMP layer. While this might take some time to
complete, it can never result in an error. *)
type ipaddr = Ipaddr.V4.t
(** The type for IP addresses. *)
type error (* entirely abstract since we expose none in an Icmp module *)
(** The type for ICMP errors. *)
val pp_error: error Fmt.t
(** [pp_error] is the pretty-printer for errors. *)
val input : t -> src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
(** [input t src dst buffer] reacts to the ICMP message in
[buffer]. *)
val write : t -> ?src:ipaddr -> dst:ipaddr -> ?ttl:int -> Cstruct.t -> (unit, error) result Lwt.t
(** [write t ~src ~dst ~ttl buffer] sends the ICMP message in [buffer] to [dst]
over IP. Passes the time-to-live ([ttl]) to the IP stack if given. *)
end
module Make (I : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) : sig
include S
val connect : I.t -> t Lwt.t
end

115
unikernel/duniverse/mirage-tcpip/src/icmp/icmpv4_packet.ml Normal file
View file

@ -0,0 +1,115 @@
open Icmpv4_wire
(* second 4 bytes of the message have varying interpretations *)
type subheader =
| Id_and_seq of Cstruct.uint16 * Cstruct.uint16
| Next_hop_mtu of Cstruct.uint16
| Pointer of Cstruct.uint8
| Address of Ipaddr.V4.t
| Unused
type t = {
code : Cstruct.uint8;
ty : ty;
subheader : subheader;
}
let pp fmt t =
let say = Format.fprintf in
let pp_subheader fmt = function
| Id_and_seq (id, seq) -> say fmt "subheader: id: %d, sequence %d" id seq
| Next_hop_mtu mtu -> say fmt "subheader: MTU %d" mtu
| Pointer pt -> say fmt "subheader: pointer to byte %d" pt
| Address addr -> say fmt "subheader: ip %a" Ipaddr.V4.pp addr
| Unused -> ()
in
say fmt "ICMP type %s, code %d, subheader [%a]" (ty_to_string t.ty)
t.code pp_subheader t.subheader
let subheader_eq = function
| Unused, Unused -> true
| Id_and_seq (a, b), Id_and_seq (p, q) -> a = p && b = q
| Next_hop_mtu a, Next_hop_mtu b-> a = b
| Pointer a, Pointer b -> a = b
| Address a, Address b -> Ipaddr.V4.compare a b = 0
| _ -> false
let equal {code; ty; subheader} q =
code = q.code &&
ty = q.ty &&
subheader_eq (subheader, q.subheader)
let ( let* ) = Result.bind
module Unmarshal = struct
type error = string
let subheader_of_cstruct ty buf =
let open Cstruct.BE in
match ty with
| Echo_request | Echo_reply
| Timestamp_request | Timestamp_reply
| Information_request | Information_reply ->
Id_and_seq (get_uint16 buf 0, get_uint16 buf 2)
| Destination_unreachable -> Next_hop_mtu (get_uint16 buf 2)
| Time_exceeded
| Source_quench -> Unused
| Redirect -> Address (Ipaddr.V4.of_int32 (get_uint32 buf 0))
| Parameter_problem -> Pointer (Cstruct.get_uint8 buf 0)
let of_cstruct buf =
let check_len () =
if Cstruct.length buf < sizeof_icmpv4 then
Error "packet too short for ICMPv4 header"
else Ok () in
let check_ty () =
match int_to_ty (get_ty buf) with
| None -> Error "unrecognized ICMPv4 type"
| Some ty -> Ok ty
in
(* TODO: check checksum as well, and return an error if it's invalid *)
let* () = check_len () in
let* ty = check_ty () in
let code = get_code buf in
let subheader = subheader_of_cstruct ty (Cstruct.shift buf 4) in
let payload = Cstruct.shift buf sizeof_icmpv4 in
Ok ({ code; ty; subheader}, payload)
end
module Marshal = struct
type error = string
let subheader_into_cstruct ~buf sh =
let open Cstruct.BE in
match sh with
| Id_and_seq (id, seq) -> set_uint16 buf 0 id; set_uint16 buf 2 seq
| Next_hop_mtu mtu -> set_uint16 buf 0 0; set_uint16 buf 2 mtu
| Pointer byte -> set_uint32 buf 0 Int32.zero; Cstruct.set_uint8 buf 0 byte;
| Address addr -> set_uint32 buf 0 (Ipaddr.V4.to_int32 addr)
| Unused -> set_uint32 buf 0 Int32.zero
let unsafe_fill {ty; code; subheader} buf ~payload =
set_ty buf (ty_to_int ty);
set_code buf code;
set_checksum buf 0x0000;
subheader_into_cstruct ~buf:(Cstruct.shift buf 4) subheader;
let packets = [(Cstruct.sub buf 0 sizeof_icmpv4); payload] in
set_checksum buf (Tcpip_checksum.ones_complement_list packets)
let check_len buf =
if Cstruct.length buf < sizeof_icmpv4 then
Error "Not enough space for ICMP header"
else Ok ()
let into_cstruct t buf ~payload =
let* () = check_len buf in
unsafe_fill t buf ~payload;
Ok ()
let make_cstruct t ~payload =
let buf = Cstruct.create sizeof_icmpv4 in
unsafe_fill t buf ~payload;
buf
end

38
unikernel/duniverse/mirage-tcpip/src/icmp/icmpv4_packet.mli Normal file
View file

@ -0,0 +1,38 @@
type subheader =
| Id_and_seq of Cstruct.uint16 * Cstruct.uint16
| Next_hop_mtu of Cstruct.uint16
| Pointer of Cstruct.uint8
| Address of Ipaddr.V4.t
| Unused
type t = {
code : Cstruct.uint8;
ty : Icmpv4_wire.ty;
subheader : subheader;
}
val pp : Format.formatter -> t -> unit
val equal : t -> t -> bool
module Unmarshal : sig
type error = string
val subheader_of_cstruct : Icmpv4_wire.ty -> Cstruct.t -> subheader
val of_cstruct : Cstruct.t -> (t * Cstruct.t, error) result
end
module Marshal : sig
type error = string
(** [into_cstruct t buf ~payload] generates an ICMPv4 header from [t] and
writes it into [buf] at offset 0. [payload] is used to calculate the ICMPv4 header
checksum, but is not included in the generated buffer. [into_cstruct] may
fail if the buffer is of insufficient size. *)
val into_cstruct : t -> Cstruct.t -> payload:Cstruct.t -> (unit, error) result
(** [make_cstruct t ~payload] allocates, fills, and returns a Cstruct.t with the header
information from [t]. The payload is used to calculate the ICMPv4 header
checksum, but is not included in the generated buffer. [make_cstruct] allocates
8 bytes for the ICMPv4 header. *)
val make_cstruct : t -> payload:Cstruct.t -> Cstruct.t
end

103
unikernel/duniverse/mirage-tcpip/src/icmp/icmpv4_wire.ml Normal file
View file

@ -0,0 +1,103 @@
type ty =
| Echo_reply
| Destination_unreachable
| Source_quench
| Redirect
| Echo_request
| Time_exceeded
| Parameter_problem
| Timestamp_request
| Timestamp_reply
| Information_request
| Information_reply
let ty_to_string = function
| Echo_reply -> "echo reply"
| Destination_unreachable -> "destination unreachable"
| Source_quench -> "source quench"
| Redirect -> "redirect"
| Echo_request -> "echo request"
| Time_exceeded -> "time exceeded"
| Parameter_problem -> "parameter problem"
| Timestamp_request -> "timestamp request"
| Timestamp_reply -> "timestamp reply"
| Information_request -> "information request"
| Information_reply -> "information reply"
let int_to_ty = function
| 0 -> Some Echo_reply
| 3 -> Some Destination_unreachable
| 4 -> Some Source_quench
| 5 -> Some Redirect
| 8 -> Some Echo_request
| 11 -> Some Time_exceeded
| 12 -> Some Parameter_problem
| 13 -> Some Timestamp_request
| 14 -> Some Timestamp_reply
| 15 -> Some Information_request
| 16 -> Some Information_reply
| _ -> None
let ty_to_int = function
| Echo_reply -> 0
| Destination_unreachable -> 3
| Source_quench -> 4
| Redirect -> 5
| Echo_request -> 8
| Time_exceeded -> 11
| Parameter_problem -> 12
| Timestamp_request -> 13
| Timestamp_reply -> 14
| Information_request -> 15
| Information_reply -> 16
type unreachable_reason =
| Network_unreachable
| Host_unreachable
| Protocol_unreachable
| Port_unreachable
| Would_fragment
| Source_route_failed
| Destination_network_unknown
| Destination_host_unknown
| Source_host_isolated
| Destination_net_prohibited
| Destination_host_prohibited
| TOS_network_unreachable
| TOS_host_unreachable
| Communication_prohibited
| Host_precedence_violation
| Precedence_insufficient
let unreachable_reason_to_int = function
| Network_unreachable -> 0
| Host_unreachable -> 1
| Protocol_unreachable -> 2
| Port_unreachable -> 3
| Would_fragment -> 4
| Source_route_failed -> 5
| Destination_network_unknown -> 6
| Destination_host_unknown -> 7
| Source_host_isolated -> 8
| Destination_net_prohibited -> 9
| Destination_host_prohibited -> 10
| TOS_network_unreachable -> 11
| TOS_host_unreachable -> 12
| Communication_prohibited -> 13
| Host_precedence_violation -> 14
| Precedence_insufficient -> 15
let sizeof_icmpv4 = 8
let ty_off = 0
let code_off = 1
let csum_off = 2
let get_ty buf = Cstruct.get_uint8 buf ty_off
let set_ty buf value = Cstruct.set_uint8 buf ty_off value
let get_code buf = Cstruct.get_uint8 buf code_off
let set_code buf value = Cstruct.set_uint8 buf code_off value
let get_checksum buf = Cstruct.BE.get_uint16 buf csum_off
let set_checksum buf value = Cstruct.BE.set_uint16 buf csum_off value

47
unikernel/duniverse/mirage-tcpip/src/icmp/icmpv4_wire.mli Normal file
View file

@ -0,0 +1,47 @@
type ty =
| Echo_reply
| Destination_unreachable
| Source_quench
| Redirect
| Echo_request
| Time_exceeded
| Parameter_problem
| Timestamp_request
| Timestamp_reply
| Information_request
| Information_reply
val ty_to_string : ty -> string
val int_to_ty : int -> ty option
val ty_to_int : ty -> int
type unreachable_reason =
| Network_unreachable
| Host_unreachable
| Protocol_unreachable
| Port_unreachable
| Would_fragment
| Source_route_failed
| Destination_network_unknown
| Destination_host_unknown
| Source_host_isolated
| Destination_net_prohibited
| Destination_host_prohibited
| TOS_network_unreachable
| TOS_host_unreachable
| Communication_prohibited
| Host_precedence_violation
| Precedence_insufficient
val unreachable_reason_to_int : unreachable_reason -> int
val sizeof_icmpv4 : int
val get_ty : Cstruct.t -> int
val set_ty : Cstruct.t -> int -> unit
val get_code : Cstruct.t -> int
val set_code : Cstruct.t -> int -> unit
val get_checksum : Cstruct.t -> int
val set_checksum : Cstruct.t -> int -> unit

8
unikernel/duniverse/mirage-tcpip/src/ipv4/dune Normal file
View file

@ -0,0 +1,8 @@
(library
(name tcpip_ipv4)
(public_name tcpip.ipv4)
(instrumentation
(backend bisect_ppx))
(libraries logs ipaddr cstruct tcpip tcpip.udp tcpip.checksum
mirage-crypto-rng mirage-mtime randomconv lru arp.mirage ethernet)
(wrapped false))

224
unikernel/duniverse/mirage-tcpip/src/ipv4/fragments.ml Normal file
View file

@ -0,0 +1,224 @@
(*
* Copyright (c) 2018 Hannes Mehnert <hannes@mehnert.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
let src = Logs.Src.create "ipv4-fragments" ~doc:"IPv4 fragmentation"
module Log = (val Logs.src_log src : Logs.LOG)
(* TODO:
current state:
lifetime is 10s max between first and last fragment
size is 1MB hardcoded
max 16 fragments for each "flow" (source ip, destrination ip, protocol, ipv4 identifier)
inserted into sorted list, checks overlaps and holes on reassembly (triggered once a fragment without "more fragments" has been received)
this has some issues:
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)
insertion into linked list is O(n) (with n is maximal 16)
ping -s 65535 isn't answered with MTU=1500 (doesn't fit into 16 fragments)
what we could do instead
maximum storage per source ip
use a bitmask or tree data structure for the segments (offset is on 8byte boundaries)
may lead to verification of overlaps at insertion time --> can drop immediately
*)
(* IP Fragmentation using a LRU cache:
The key of our cache is source ip * destination ip * protocol * identifier.
The value is a quintuple consisting of first segment received. IP options
(which are usually sent only in the first IP segment), "last segment
received" (i.e. an IPv4 segment without the more fragment bit set), a counter
of the length of items, and a list of pairs, which contain an offset and
payload. The list is sorted by offset in descending order. *)
module V = struct
type t = int64 * Cstruct.t * bool * int * (int * Cstruct.t) list
let weight (_, _, _, _, v) = Cstruct.lenv (List.map snd v)
end
module K = struct
type t = Ipaddr.V4.t * Ipaddr.V4.t * int * int
let compare (src, dst, proto, id) (src', dst', proto', id') =
let (&&&) a b = match a with 0 -> b | x -> x in
let int_cmp : int -> int -> int = compare in
Ipaddr.V4.compare src src' &&&
Ipaddr.V4.compare dst dst' &&&
int_cmp proto proto' &&&
int_cmp id id'
end
module Cache = Lru.F.Make(K)(V)
(* insert_sorted inserts a fragment in a list, sort is by frag_start, descending *)
let rec insert_sorted ((frag_start, _) as frag) = function
| [] -> [ frag ]
| ((frag'_start, _) as frag')::tl ->
if frag'_start <= frag_start
then frag::frag'::tl
else frag'::insert_sorted frag tl
(* attempt_reassemble takes a list of fragments, and returns either
- Ok payload when the payload was completed
- Error Hole if some fragment is still missing
- Error Bad if the list of fragments was bad: it contains overlapping
segments. This is an indication for malicious activity, and we drop the
IP fragment
There are various attacks (and DoS) on IP reassembly, most prominent use
overlapping segments (and selection thereof), we just drop overlapping segments
(similar as Linux does since https://git.kernel.org/pub/scm/linux/kernel/git/davem/net-next.git/commit/?id=c30f1fc041b74ecdb072dd44f858750414b8b19f).
*)
type r = Bad | Hole
let attempt_reassemble fragments =
Log.debug (fun m -> m "reassemble %a"
Fmt.(list ~sep:(any "; ") (pair ~sep:(any ", len ") int int))
(List.map (fun (off, data) -> off, Cstruct.length data) fragments)) ;
(* input: list of (offset, fragment) with decreasing offset *)
(* output: maybe a cstruct.t if there are no gaps *)
let len =
(* List.hd is safe here, since we are never called with an empty list *)
let off, data = List.hd fragments in
off + Cstruct.length data
in
let rec check until = function
| [] -> if until = 0 then Ok () else Error Hole
| (start, d)::tl ->
let until' = start + (Cstruct.length d) in
if until = until'
then check start tl
else if until' > until
then Error Bad
else Error Hole
in
Result.bind
(check len fragments)
(fun () ->
let buf = Cstruct.create_unsafe len in
List.iter (fun (off, data) ->
Cstruct.blit data 0 buf off (Cstruct.length data))
fragments ;
Ok buf)
let max_number_of_fragments = 16
let max_duration = Duration.of_sec 10
let process cache ts (packet : Ipv4_packet.t) payload =
let add_trim key value cache =
let cache' = Cache.add key value cache in
Cache.trim cache'
in
if packet.off land 0x3FFF = 0 then (* ignore reserved and don't fragment *)
(* fastpath *)
cache, Some (packet, payload)
else
let offset, more =
(packet.off land 0x1FFF) lsl 3, (* of 8 byte blocks *)
packet.off land 0x2000 = 0x2000
and key = (packet.src, packet.dst, packet.proto, packet.id)
in
let v = (ts, packet.options, not more, 1, [(offset, payload)]) in
match Cache.find key cache with
| None ->
Log.debug (fun m -> m "%a none found, inserting into cache" Ipv4_packet.pp packet) ;
add_trim key v cache, None
| Some (ts', options, finished, cnt, frags) ->
if Int64.sub ts ts' >= max_duration then begin
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) ;
add_trim key v cache, None
end else
let cache' = Cache.promote key cache in
let all_frags = insert_sorted (offset, payload) frags
and try_reassemble = finished || not more
and options' = if offset = 0 then packet.options else options
in
Log.debug (fun m -> m "%d found, finished %b more %b try_reassemble %b"
cnt finished more try_reassemble) ;
let maybe_add_to_cache c =
if cnt < max_number_of_fragments then
add_trim key (ts', options', try_reassemble, succ cnt, all_frags) c
else
(Log.warn (fun m -> m "%a dropping from cache, maximum number of fragments exceeded"
Ipv4_packet.pp packet) ;
Cache.remove key c)
in
if try_reassemble then
match attempt_reassemble all_frags with
| Ok p ->
Log.debug (fun m -> m "%a reassembled to payload %d" Ipv4_packet.pp packet (Cstruct.length p)) ;
let packet' = { packet with options = options' ; off = 0 } in
Cache.remove key cache', Some (packet', p)
| Error Bad ->
Log.warn (fun m -> m "%a dropping from cache, bad fragments (%a)"
Ipv4_packet.pp packet
Fmt.(list ~sep:(any "; ") (pair ~sep:(any ", ") int int))
(List.map (fun (s, d) -> (s, Cstruct.length d)) all_frags)) ;
Log.debug (fun m -> m "full fragments: %a"
Fmt.(list ~sep:(any "@.") Cstruct.hexdump_pp)
(List.map snd all_frags)) ;
Cache.remove key cache', None
| Error Hole -> maybe_add_to_cache cache', None
else
maybe_add_to_cache cache', None
(* TODO hdr.options is a Cstruct.t atm, but instead we need to parse all the
options, and distinguish based on the first bit -- only these with the bit
set should be copied into all fragments (see RFC 791, 3.1, page 15) *)
let fragment ~mtu hdr payload =
let rec frag1 acc hdr hdr_buf offset data_size payload =
let more = Cstruct.length payload > data_size in
let hdr' =
(* off is 16 bit of IPv4 header, 0x2000 sets the more fragments bit *)
let off = (offset / 8) lor (if more then 0x2000 else 0) in
{ hdr with Ipv4_packet.off }
in
let this_payload, rest =
if more then Cstruct.split payload data_size else payload, Cstruct.empty
in
let payload_len = Cstruct.length this_payload in
Ipv4_wire.set_checksum hdr_buf 0;
(match Ipv4_packet.Marshal.into_cstruct ~payload_len hdr' hdr_buf with
(* hdr_buf is allocated with hdr_size (computed below) bytes, thus
into_cstruct will never return an error! *)
| Error msg -> invalid_arg msg
| Ok () -> ());
let acc' = Cstruct.append hdr_buf this_payload :: acc in
if more then
let offset = offset + data_size in
(frag1[@tailcall]) acc' hdr hdr_buf offset data_size rest
else
acc'
in
let hdr_size =
(* padded to 4 byte boundary *)
let opt_size = (Cstruct.length hdr.Ipv4_packet.options + 3) / 4 * 4 in
opt_size + Ipv4_wire.sizeof_ipv4
in
let data_size =
let full = mtu - hdr_size in
(full / 8) * 8
in
if data_size <= 0 then
[]
else
List.rev (frag1 [] hdr (Cstruct.create hdr_size) data_size data_size payload)

92
unikernel/duniverse/mirage-tcpip/src/ipv4/fragments.mli Normal file
View file

@ -0,0 +1,92 @@
(*
* Copyright (c) 2018 Hannes Mehnert <hannes@mehnert.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(** IPv4 Fragmentation and reassembly
An IPv4 packet may exceed the maximum transferable unit (MTU) of a link, and
thus may be fragmented into multiple packets. Since the MTU depends on the
underlying link, fragmentation and reassembly may happen in gateways as well
as endpoints. Starting at byte 6, 16 bit in the IPv4 header are used for
fragmentation. The first bit is reserved, the second signals if set to never
fragment this packet - instead if it needs to be fragmented, an ICMP error
must be returned (used for path MTU discovery). The third bit indicates
whether this is the last fragment or more are following. The remaining 13
bits are the offset of this fragment in the reassembled packet, divided by
8. All fragments of one reassembled packet use the same 16 bit IPv4
identifier (byte offset 4). The IPv4 header is repeated in each fragment,
apart from those options which highest bit is cleared. Fragments may be
received in any order.
This module implements a reassembly cache, using a least recently used (LRU)
cache underneath. For security reasons, only non-overlapping fragments are
accepted. To avoid denial of service attacks, the maximum number of segments
is limited to 16 - with a common MTU of 1500, this means that packets
exceeding 24000 bytes will be dropped. The arrival time of the first and last
fragment may not exceed 10 seconds. There is no per-source IP limit of
fragment data to keep, only the total amount of fragmented data can be
limited by the choice of the size of the LRU.
Any received packet may be the last needed for a successful reassembly (due
to receiving them out-of-order). When the last fragment (which has the more
fragments bit cleared) for a quadruple source IP, destination IP, IP
identifier, and protocol ID, is received, reassembly is attempted - also on
subsequent packets with the same quadruple. *)
module V : sig
type t = int64 * Cstruct.t * bool * int * (int * Cstruct.t) list
(** The type of values in the fragment cache: a timestamp of the first
received one, IP options (of the first fragment), whether or not the last
fragment was received (the one with more fragments cleared), amount of
received fragments, and a list of pairs of offset and fragment. *)
val weight : t -> int
(** [weight t] is the data length of the received fragments. *)
end
module K : sig
type t = Ipaddr.V4.t * Ipaddr.V4.t * int * int
(** The type of keys in the fragment cache: source IP address, destination
IP address, protocol type, and IP identifier. *)
val compare : t -> t -> int
end
module Cache : sig
include Lru.F.S with type k = K.t and type v = V.t
end
val max_duration : int64
(** [max_duration] is the maximum delta between first and last received
fragment, in nanoseconds. At the moment it is 10 seconds. *)
val process : Cache.t -> int64 -> Ipv4_packet.t -> Cstruct.t -> Cache.t *
(Ipv4_packet.t * Cstruct.t) option (** [process t timestamp hdr payload] is
[t'], a new cache, and maybe a fully reassembled IPv4 packet. If reassembly
fails, e.g. too many fragments, delta between receive timestamp of first and
last packet exceeds {!max_duration}, overlapping packets, these packets
will be dropped from the cache. The IPv4 header options are always taken from
the first fragment (where offset is 0). If the provided IPv4 header has an
fragmentation offset of 0, and the more fragments bit is not set, the given
header and payload is directly returned. Handles out-of-order fragments
gracefully. *)
val fragment : mtu:int -> Ipv4_packet.t -> Cstruct.t -> Cstruct.t list
(** [fragment ~mtu hdr payload] is called with the IPv4 header of the first
fragment and the remaining payload (which did not fit into the first
fragment). The [data_length = ((mtu - header_length hdr) / 8) * 8] is used
for each fragment (and it is assumed that the first fragment contains
exactly that much data). The number of packets returned is
[len payload / data_len]. If [data_len <= 0], the empty list is returned. *)

180
unikernel/duniverse/mirage-tcpip/src/ipv4/ipv4_packet.ml Normal file
View file

@ -0,0 +1,180 @@
type t = {
src : Ipaddr.V4.t;
dst : Ipaddr.V4.t;
id : Cstruct.uint16;
off : Cstruct.uint16;
ttl : Cstruct.uint8;
proto : Cstruct.uint8;
options : Cstruct.t;
}
type protocol = [
| `ICMP
| `TCP
| `UDP ]
let pp fmt t =
Format.fprintf fmt "IPv4 packet %a -> %a: id %04x, off %d proto %d, ttl %d, options %a"
Ipaddr.V4.pp t.src Ipaddr.V4.pp t.dst t.id t.off t.proto t.ttl Cstruct.hexdump_pp t.options
let equal {src; dst; id; off; ttl; proto; options} q =
src = q.src &&
dst = q.dst &&
id = q.id &&
off = q.off &&
ttl = q.ttl &&
proto = q.proto &&
Cstruct.equal options q.options
module Marshal = struct
open Ipv4_wire
type error = string
let protocol_to_int = function
| `ICMP -> 1
| `TCP -> 6
| `UDP -> 17
let pseudoheader ~src ~dst ~proto len =
(* should we do sth about id or off (assert false?) *)
let proto = protocol_to_int proto in
let ph = Cstruct.create 12 in
let numify = Ipaddr.V4.to_int32 in
Cstruct.BE.set_uint32 ph 0 (numify src);
Cstruct.BE.set_uint32 ph 4 (numify dst);
Cstruct.set_uint8 ph 8 0;
Cstruct.set_uint8 ph 9 proto;
Cstruct.BE.set_uint16 ph 10 len;
ph
let unsafe_fill ~payload_len t buf =
let nearest_4 n = match n mod 4 with
| 0 -> n
| k -> (4 - k) + n
in
let options_len = nearest_4 @@ Cstruct.length t.options in
set_hlen_version buf ((4 lsl 4) + 5 + (options_len / 4));
set_id buf t.id;
set_off buf t.off;
set_ttl buf t.ttl;
set_proto buf t.proto;
set_src buf t.src;
set_dst buf t.dst;
Cstruct.blit t.options 0 buf sizeof_ipv4 (Cstruct.length t.options);
set_len buf (sizeof_ipv4 + options_len + payload_len);
let checksum = Tcpip_checksum.ones_complement @@ Cstruct.sub buf 0 (20 + options_len) in
set_checksum buf checksum
let into_cstruct ~payload_len t buf =
if Cstruct.length buf < (sizeof_ipv4 + Cstruct.length t.options) then
Error "Not enough space for IPv4 header"
else
Ok (unsafe_fill ~payload_len t buf)
let make_cstruct ~payload_len t =
let nearest_4 n = match n mod 4 with
| 0 -> n
| k -> (4 - k) + n
in
let options_len = nearest_4 @@ Cstruct.length t.options in
let buf = Cstruct.create (sizeof_ipv4 + options_len) in
Cstruct.memset buf 0x00; (* should be removable in the future *)
unsafe_fill ~payload_len t buf;
buf
end
module Unmarshal = struct
type error = string
let int_to_protocol = function
| 1 -> Some `ICMP
| 6 -> Some `TCP
| 17 -> Some `UDP
| _ -> None
let ( let* ) = Result.bind
let header_of_cstruct buf =
let open Ipv4_wire in
let check_version buf =
let version n = (n land 0xf0) in
match get_hlen_version buf |> version with
| 0x40 -> Ok ()
| n -> Error (Printf.sprintf "IPv4 presented with a packet that claims a different IP version: %x" n)
in
let size_check buf =
if (Cstruct.length buf < sizeof_ipv4) then Error "buffer sent to IPv4 parser had size < 20"
else Ok ()
in
let get_header_length buf =
let length_of_hlen_version n = (n land 0x0f) * 4 in
let hlen = get_hlen_version buf |> length_of_hlen_version in
let len = get_len buf in
if len < sizeof_ipv4 then
Error (Printf.sprintf
"total length %d is smaller than minimum header length" len)
else if len < hlen then
Error (Printf.sprintf
"total length %d is smaller than stated header length %d"
len hlen)
else if hlen < sizeof_ipv4 then
Error (Printf.sprintf "IPv4 header claimed to have size < 20: %d" hlen)
else if Cstruct.length buf < hlen then
Error (Printf.sprintf "IPv4 packet w/length %d claimed to have header of size %d" (Cstruct.length buf) hlen)
else Ok hlen
in
let parse buf options_end =
let src = get_src buf
and dst = get_dst buf
and id = get_id buf
and off = get_off buf
and ttl = get_ttl buf
and proto = get_proto buf
in
let options =
if options_end > sizeof_ipv4 then (Cstruct.sub buf sizeof_ipv4 (options_end - sizeof_ipv4))
else (Cstruct.create 0)
in
Ok ({src; dst; id; off; ttl; proto; options;}, options_end)
in
let* () = size_check buf in
let* () = check_version buf in
let* hl = get_header_length buf in
parse buf hl
let of_cstruct buf =
let parse buf options_end =
let payload_len = Ipv4_wire.get_len buf - options_end in
let payload_available = Cstruct.length buf - options_end in
if payload_available < payload_len then (
Error (Printf.sprintf "Payload buffer (%d bytes) too small to contain payload (of size %d from header)" payload_available payload_len)
) else (
let payload = Cstruct.sub buf options_end payload_len in
Ok payload
)
in
let* header, options_end = header_of_cstruct buf in
let* payload = parse buf options_end in
Ok (header, payload)
let verify_transport_checksum ~proto ~ipv4_header ~transport_packet =
(* note: it's not necessary to ensure padding to integral number of 16-bit fields here; ones_complement_list does this for us *)
let check ~proto ipv4_header len =
try
let ph = Marshal.pseudoheader ~src:ipv4_header.src ~dst:ipv4_header.dst ~proto len in
let calculated_checksum = Tcpip_checksum.ones_complement_list [ph ; transport_packet] in
0 = compare 0x0000 calculated_checksum
with
| Invalid_argument _ -> false
in
match proto with
| `TCP -> (* checksum isn't optional in tcp, but pkt must be long enough *)
check ipv4_header ~proto (Cstruct.length transport_packet)
| `UDP ->
match Udp_wire.get_checksum transport_packet with
| n when (=) 0 @@ compare n 0x0000 -> true (* no checksum supplied, so the check trivially passes *)
| _ ->
check ipv4_header ~proto (Cstruct.length transport_packet)
end

54
unikernel/duniverse/mirage-tcpip/src/ipv4/ipv4_packet.mli Normal file
View file

@ -0,0 +1,54 @@
type t = {
src : Ipaddr.V4.t;
dst : Ipaddr.V4.t;
id : Cstruct.uint16;
off : Cstruct.uint16;
ttl : Cstruct.uint8;
proto : Cstruct.uint8;
options : Cstruct.t;
}
val pp : Format.formatter -> t -> unit
val equal : t -> t -> bool
type protocol = [
| `ICMP
| `TCP
| `UDP ]
module Unmarshal : sig
type error = string
val int_to_protocol : int -> protocol option
val of_cstruct : Cstruct.t -> (t * Cstruct.t, error) result
val header_of_cstruct : Cstruct.t -> ((t * int), error) result
(** [header_of_cstruct buf] attempts to return [t, offset] where [offset]
is the first byte of the payload in [buf]. *)
val verify_transport_checksum : proto:([`TCP | `UDP]) -> ipv4_header:t ->
transport_packet:Cstruct.t -> bool
end
module Marshal : sig
type error = string
val protocol_to_int : protocol -> Cstruct.uint16
val pseudoheader : src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> proto:protocol
-> int -> Cstruct.t
(** [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. *)
(** [into_cstruct ~payload_len t buf] attempts to write a header representing [t] (including
[t.options]) into [buf] at offset 0.
If there is insufficient space to represent [t], an error will be returned. *)
val into_cstruct : payload_len:int -> t -> Cstruct.t -> (unit, error) result
(** [make_cstruct ~payload_len t] allocates, fills, and returns a buffer
representing the IPV4 header corresponding to [t].
If [t.options] is non-empty, [t.options] will be
concatenated onto the result. A variable amount of memory (at least 20 bytes
for a zero-length options field) will be allocated.
Note: no space is allocated for the payload. *)
val make_cstruct : payload_len:int -> t -> Cstruct.t
end

39
unikernel/duniverse/mirage-tcpip/src/ipv4/ipv4_wire.ml Normal file
View file

@ -0,0 +1,39 @@
let sizeof_ipv4 = 20
let hlen_version_off = 0
let _tos_off = 1
let len_off = 2
let id_off = 4
let off_off = 6
let ttl_off = 8
let proto_off = 9
let csum_off = 10
let src_off = 12
let dst_off = 16
let get_hlen_version buf = Cstruct.get_uint8 buf hlen_version_off
let set_hlen_version buf v = Cstruct.set_uint8 buf hlen_version_off v
let get_len buf = Cstruct.BE.get_uint16 buf len_off
let set_len buf v = Cstruct.BE.set_uint16 buf len_off v
let get_id buf = Cstruct.BE.get_uint16 buf id_off
let set_id buf v = Cstruct.BE.set_uint16 buf id_off v
let get_off buf = Cstruct.BE.get_uint16 buf off_off
let set_off buf v = Cstruct.BE.set_uint16 buf off_off v
let get_ttl buf = Cstruct.get_uint8 buf ttl_off
let set_ttl buf v = Cstruct.set_uint8 buf ttl_off v
let get_proto buf = Cstruct.get_uint8 buf proto_off
let set_proto buf v = Cstruct.set_uint8 buf proto_off v
let get_checksum buf = Cstruct.BE.get_uint16 buf csum_off
let set_checksum buf value = Cstruct.BE.set_uint16 buf csum_off value
let get_src buf = Ipaddr.V4.of_int32 (Cstruct.BE.get_uint32 buf src_off)
let set_src buf v = Cstruct.BE.set_uint32 buf src_off (Ipaddr.V4.to_int32 v)
let get_dst buf = Ipaddr.V4.of_int32 (Cstruct.BE.get_uint32 buf dst_off)
let set_dst buf v = Cstruct.BE.set_uint32 buf dst_off (Ipaddr.V4.to_int32 v)

28
unikernel/duniverse/mirage-tcpip/src/ipv4/ipv4_wire.mli Normal file
View file

@ -0,0 +1,28 @@
val sizeof_ipv4 : int
val get_hlen_version : Cstruct.t -> int
val set_hlen_version : Cstruct.t -> int -> unit
val get_len : Cstruct.t -> int
val set_len : Cstruct.t -> int -> unit
val get_id : Cstruct.t -> int
val set_id : Cstruct.t -> int -> unit
val get_off : Cstruct.t -> int
val set_off : Cstruct.t -> int -> unit
val get_ttl : Cstruct.t -> int
val set_ttl : Cstruct.t -> int -> unit
val get_proto : Cstruct.t -> int
val set_proto : Cstruct.t -> int -> unit
val get_checksum : Cstruct.t -> int
val set_checksum : Cstruct.t -> int -> unit
val get_src : Cstruct.t -> Ipaddr.V4.t
val set_src : Cstruct.t -> Ipaddr.V4.t -> unit
val get_dst : Cstruct.t -> Ipaddr.V4.t
val set_dst : Cstruct.t -> Ipaddr.V4.t -> unit

57
unikernel/duniverse/mirage-tcpip/src/ipv4/routing.ml Normal file
View file

@ -0,0 +1,57 @@
(* RFC 1112: 01-00-5E-00-00-00 ORed with lower 23 bits of the ip address *)
let mac_of_multicast ip =
let ipb = Ipaddr.V4.to_octets ip in
let macb = Bytes.create 6 in
Bytes.set macb 0 (Char.chr 0x01);
Bytes.set macb 1 (Char.chr 0x00);
Bytes.set macb 2 (Char.chr 0x5E);
Bytes.set macb 3 (Char.chr ((Char.code ipb.[1]) land 0x7F));
Bytes.set macb 4 (String.get ipb 2);
Bytes.set macb 5 (String.get ipb 3);
Macaddr.of_octets_exn (Bytes.to_string macb)
type routing_error = [ `Local | `Gateway ]
module Make(Log : Logs.LOG) (A : Arp.S) = struct
open Lwt.Infix
let destination_mac network gateway arp = function
|ip when Ipaddr.V4.(compare ip broadcast) = 0
|| Ipaddr.V4.(compare ip any) = 0
|| Ipaddr.V4.(compare (Prefix.broadcast network) ip) = 0 -> (* Broadcast *)
Lwt.return @@ Ok Macaddr.broadcast
|ip when Ipaddr.V4.is_multicast ip ->
Lwt.return @@ Ok (mac_of_multicast ip)
|ip when Ipaddr.V4.Prefix.mem ip network -> (* Local *)
A.query arp ip >|= begin function
| Ok mac -> Ok mac
| Error `Timeout ->
Log.info (fun f ->
f "IP.output: could not determine link-layer address for local \
network (%a) ip %a" Ipaddr.V4.Prefix.pp network
Ipaddr.V4.pp ip);
Error `Local
| Error e ->
Log.info (fun f -> f "IP.output: %a" A.pp_error e);
Error `Local
end
|ip -> (* Gateway *)
match gateway with
| None ->
Log.info (fun f ->
f "IP.output: no route to %a (no default gateway is configured)"
Ipaddr.V4.pp ip);
Lwt.return (Error `Gateway)
| Some gateway ->
A.query arp gateway >|= function
| Ok mac -> Ok mac
| Error `Timeout ->
Log.info (fun f ->
f "IP.output: could not send to %a: failed to contact gateway %a"
Ipaddr.V4.pp ip Ipaddr.V4.pp gateway);
Error `Gateway
| Error e ->
Log.info (fun f -> f "IP.output: %a" A.pp_error e);
Error `Gateway
end

187
unikernel/duniverse/mirage-tcpip/src/ipv4/static_ipv4.ml Normal file
View file

@ -0,0 +1,187 @@
(*
* Copyright (c) 2010-2011 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Lwt.Infix
let src = Logs.Src.create "ipv4" ~doc:"Mirage IPv4"
module Log = (val Logs.src_log src : Logs.LOG)
module Make (Ethernet: Ethernet.S) (Arpv4 : Arp.S) = struct
module Routing = Routing.Make(Log)(Arpv4)
(** IO operation errors *)
type error = [ Tcpip.Ip.error | `Would_fragment | `Ethif of Ethernet.error ]
let pp_error ppf = function
| #Tcpip.Ip.error as e -> Tcpip.Ip.pp_error ppf e
| `Ethif e -> Ethernet.pp_error ppf e
type ipaddr = Ipaddr.V4.t
type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
let pp_ipaddr = Ipaddr.V4.pp
type prefix = Ipaddr.V4.Prefix.t
let pp_prefix = Ipaddr.V4.Prefix.pp
type t = {
ethif : Ethernet.t;
arp : Arpv4.t;
cidr: Ipaddr.V4.Prefix.t;
gateway: Ipaddr.V4.t option;
mutable cache: Fragments.Cache.t;
}
let write t ?(fragment = true) ?(ttl = 38) ?src dst proto ?(size = 0) headerf bufs =
Routing.destination_mac t.cidr t.gateway t.arp dst >>= function
| Error `Local ->
Log.warn (fun f -> f "Could not find %a on the local network" Ipaddr.V4.pp dst);
Lwt.return @@ Error (`No_route "no response for IP on local network")
| Error `Gateway when t.gateway = None ->
Log.warn (fun f -> f "Write to %a would require an external route, which was not provided" Ipaddr.V4.pp dst);
Lwt.return @@ Ok ()
| Error `Gateway ->
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);
(* when a gateway is specified the user likely expects their traffic to be passed to it *)
Lwt.return @@ Error (`No_route "no route to default gateway to outside world")
| Ok mac ->
(* need first to deal with fragmentation decision - find out mtu *)
let mtu = Ethernet.mtu t.ethif in
(* no options here, always 20 bytes! *)
let hdr_len = Ipv4_wire.sizeof_ipv4 in
let needed_bytes = Cstruct.lenv bufs + hdr_len + size in
let multiple = needed_bytes > mtu in
(* construct the header (will be reused across fragments) *)
if not fragment && multiple then
Lwt.return (Error `Would_fragment)
else
let off =
match fragment, multiple with
| true, true -> 0x2000
| false, false -> 0x4000
| true, false -> 0x0000
| false, true -> assert false (* handled by conditional above *)
in
let hdr =
let src = match src with None -> Ipaddr.V4.Prefix.address t.cidr | Some x -> x in
let id = if multiple then Randomconv.int16 Mirage_crypto_rng.generate else 0 in
Ipv4_packet.{
options = Cstruct.empty ;
src ; dst ; ttl ; off ; id ;
proto = Ipv4_packet.Marshal.protocol_to_int proto }
in
let writeout size fill =
Ethernet.write t.ethif mac `IPv4 ~size fill >|= function
| Error e ->
Log.warn (fun f -> f "Error sending Ethernet frame: %a"
Ethernet.pp_error e);
Error (`Ethif e)
| Ok () -> Ok ()
in
Log.debug (fun m -> m "ip write: mtu is %d, hdr_len is %d, size %d \
payload len %d, needed_bytes %d"
mtu hdr_len size (Cstruct.lenv bufs) needed_bytes) ;
let leftover = ref Cstruct.empty in
(* first fragment *)
let fill buf =
let payload_buf = Cstruct.shift buf hdr_len in
let header_len = headerf payload_buf in
if header_len > size then begin
Log.err (fun m -> m "headers returned length exceeding size") ;
invalid_arg "headerf exceeds size"
end ;
(* need to copy the given payload *)
let len, rest =
Cstruct.fillv ~src:bufs ~dst:(Cstruct.shift payload_buf header_len)
in
leftover := Cstruct.concat rest;
let payload_len = header_len + len in
match Ipv4_packet.Marshal.into_cstruct ~payload_len hdr buf with
| Ok () -> payload_len + hdr_len
| Error msg ->
Log.err (fun m -> m "failure while assembling ip frame: %s" msg) ;
invalid_arg msg
in
writeout (min mtu needed_bytes) fill >>= function
| Error e -> Lwt.return (Error e)
| Ok () ->
if not multiple then
Lwt.return (Ok ())
else
let remaining = Fragments.fragment ~mtu hdr !leftover in
Lwt_list.fold_left_s (fun acc p ->
match acc with
| Error e -> Lwt.return (Error e)
| Ok () ->
let l = Cstruct.length p in
writeout l (fun buf -> Cstruct.blit p 0 buf 0 l ; l))
(Ok ()) remaining
let input t ~tcp ~udp ~default buf =
match Ipv4_packet.Unmarshal.of_cstruct buf with
| Error s ->
Log.info (fun m -> m "error %s while parsing IPv4 frame %a" s Cstruct.hexdump_pp buf);
Lwt.return_unit
| Ok (packet, payload) ->
let of_interest ip =
Ipaddr.V4.(compare ip (Prefix.address t.cidr) = 0
|| compare ip broadcast = 0
|| compare ip (Prefix.broadcast t.cidr) = 0)
in
if not (of_interest packet.dst) then begin
Log.debug (fun m -> m "dropping IP fragment not for us or broadcast %a"
Ipv4_packet.pp packet);
Lwt.return_unit
end else if Cstruct.length payload = 0 then begin
Log.debug (fun m -> m "dropping zero length IPv4 frame %a" Ipv4_packet.pp packet) ;
Lwt.return_unit
end else
let ts = Mirage_mtime.elapsed_ns () in
let cache, res = Fragments.process t.cache ts packet payload in
t.cache <- cache ;
match res with
| None -> Lwt.return_unit
| Some (packet, payload) ->
let src, dst = packet.src, packet.dst in
match Ipv4_packet.Unmarshal.int_to_protocol packet.proto with
| Some `TCP -> tcp ~src ~dst payload
| Some `UDP -> udp ~src ~dst payload
| Some `ICMP | None -> default ~proto:packet.proto ~src ~dst payload
let connect
?(no_init = false) ~cidr ?gateway ?(fragment_cache_size = 1024 * 256) ethif arp =
(if no_init then
Lwt.return_unit
else
Arpv4.set_ips arp [Ipaddr.V4.Prefix.address cidr]) >|= fun () ->
let cache = Fragments.Cache.empty fragment_cache_size in
{ ethif; arp; cidr; gateway; cache }
let disconnect _ = Lwt.return_unit
let get_ip t = [Ipaddr.V4.Prefix.address t.cidr]
let configured_ips t = [t.cidr]
let pseudoheader t ?src dst proto len =
let src = match src with None -> Ipaddr.V4.Prefix.address t.cidr | Some x -> x in
Ipv4_packet.Marshal.pseudoheader ~src ~dst ~proto len
let src t ~dst:_ = Ipaddr.V4.Prefix.address t.cidr
let mtu t ~dst:_ = Ethernet.mtu t.ethif - Ipv4_wire.sizeof_ipv4
end

26
unikernel/duniverse/mirage-tcpip/src/ipv4/static_ipv4.mli Normal file
View file

@ -0,0 +1,26 @@
(*
* Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
module Make (E: Ethernet.S) (A: Arp.S) : sig
include Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t and type prefix = Ipaddr.V4.Prefix.t
val connect : ?no_init:bool -> cidr:Ipaddr.V4.Prefix.t -> ?gateway:Ipaddr.V4.t ->
?fragment_cache_size:int -> E.t -> A.t -> t Lwt.t
(** [connect ~no_init ~cidr ~gateway ~fragment_cache_size eth arp] connects the ipv4
device using [cidr] and [gateway] for network communication. The size of
the IPv4 fragment cache (for reassembly) can be provided in byte-size of
fragments (defaults to 256kB). *)
end

9
unikernel/duniverse/mirage-tcpip/src/ipv6/dune Normal file
View file

@ -0,0 +1,9 @@
(library
(name tcpip_ipv6)
(public_name tcpip.ipv6)
(instrumentation
(backend bisect_ppx))
(libraries logs mirage-sleep mirage-net macaddr-cstruct tcpip.checksum
mirage-mtime duration ipaddr cstruct tcpip randomconv
mirage-crypto-rng ethernet ipaddr-cstruct)
(wrapped false))

177
unikernel/duniverse/mirage-tcpip/src/ipv6/ipv6.ml Normal file
View file

@ -0,0 +1,177 @@
(*
* Copyright (c) 2014 Nicolas Ojeda Bar <n.oje.bar@gmail.com>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
let src = Logs.Src.create "ipv6" ~doc:"Mirage IPv6"
module Log = (val Logs.src_log src : Logs.LOG)
module I = Ipaddr
open Lwt.Infix
module Make (N : Mirage_net.S)
(E : Ethernet.S) = struct
type ipaddr = Ipaddr.V6.t
type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
let pp_ipaddr = Ipaddr.V6.pp
type prefix = Ipaddr.V6.Prefix.t
let pp_prefix = Ipaddr.V6.Prefix.pp
type t =
{ ethif : E.t;
mutable ctx : Ndpv6.context }
type error = [ Tcpip.Ip.error | `Ethif of E.error ]
let pp_error ppf = function
| #Tcpip.Ip.error as e -> Tcpip.Ip.pp_error ppf e
| `Ethif e -> E.pp_error ppf e
let output t (dst, size, fill) =
E.write t.ethif dst `IPv6 ~size fill
let output_ign t a = output t a >|= fun _ -> ()
let start_ticking t u =
let rec loop u =
let now = Mirage_mtime.elapsed_ns () in
let ctx, outs = Ndpv6.tick ~now t.ctx in
t.ctx <- ctx;
let u = match u, Ndpv6.get_ip t.ctx with
| None, _ | _, [] -> u
| Some u, _ -> Lwt.wakeup_later u (); None
in
Lwt_list.iter_s (output_ign t) outs (* MCP: replace with propagation *) >>= fun () ->
Mirage_sleep.ns (Duration.of_sec 1) >>= fun () ->
loop u
in
loop (Some u)
let mtu t ~dst:_ = E.mtu t.ethif - Ipv6_wire.sizeof_ipv6
let write t ?fragment:_ ?ttl:_ ?src dst proto ?(size = 0) headerf bufs =
let now = Mirage_mtime.elapsed_ns () in
(* TODO fragmentation! *)
let payload = Cstruct.concat bufs in
let size' = size + Cstruct.length payload in
let fillf _ip6hdr buf =
let h_len = headerf buf in
if h_len > size then begin
Log.err (fun m -> m "provided headerf exceeds size") ;
invalid_arg "headerf exceeds size"
end ;
Cstruct.blit payload 0 buf h_len (Cstruct.length payload);
h_len + Cstruct.length payload
in
let ctx, outs = Ndpv6.send ~now t.ctx ?src dst proto size' fillf in
t.ctx <- ctx;
let fail_any progress data =
let squeal = function
| Ok () as ok -> Lwt.return ok
| Error e ->
Log.warn (fun f -> f "ethif write errored: %a" E.pp_error e);
Lwt.return @@ Error (`Ethif e)
in
match progress with
| Ok () -> output t data >>= squeal
| Error e -> Lwt.return @@ Error e
in
(* MCP - it's not totally clear to me that this the right behavior
for writev. *)
Lwt_list.fold_left_s fail_any (Ok ()) outs
let input t ~tcp ~udp ~default buf =
let now = Mirage_mtime.elapsed_ns () in
let ctx, outs, actions = Ndpv6.handle ~now t.ctx buf in
t.ctx <- ctx;
Lwt_list.iter_s (function
| `Tcp (src, dst, buf) -> tcp ~src ~dst buf
| `Udp (src, dst, buf) -> udp ~src ~dst buf
| `Default (proto, src, dst, buf) -> default ~proto ~src ~dst buf
) actions >>= fun () ->
(* MCP: replace below w/proper error propagation *)
Lwt_list.iter_s (output_ign t) outs
let disconnect _ = (* TODO *)
Lwt.return_unit
let src t ~dst = Ndpv6.select_source t.ctx dst
let get_ip t =
Ndpv6.get_ip t.ctx
let configured_ips t =
Ndpv6.configured_ips t.ctx
let pseudoheader t ?src:source dst proto len =
let ph = Cstruct.create (16 + 16 + 8) in
let src = match source with None -> src t ~dst | Some x -> x in
Ipv6_wire.set_ip ph 0 src;
Ipv6_wire.set_ip ph 16 dst;
Cstruct.BE.set_uint32 ph 32 (Int32.of_int len);
Cstruct.set_uint8 ph 36 0;
Cstruct.set_uint8 ph 37 0;
Cstruct.set_uint8 ph 38 0;
Cstruct.set_uint8 ph 39 (Ipv6_wire.protocol_to_int proto);
ph
let connect ?(no_init = false) ?(handle_ra = true) ?cidr ?gateway netif ethif =
Log.info (fun f -> f "IP6: Starting");
let now = Mirage_mtime.elapsed_ns () in
let ctx, outs = Ndpv6.local ~handle_ra ~now (E.mac ethif) in
let ctx, outs = match cidr with
| None -> ctx, outs
| Some p ->
let ctx, outs' = Ndpv6.add_ip ~now ctx p in
let ctx = Ndpv6.add_prefix ~now ctx (Ipaddr.V6.Prefix.prefix p) in
ctx, outs @ outs'
in
let ctx = match gateway with
| None -> ctx
| Some ip -> Ndpv6.add_routers ~now ctx [ip]
in
let t = {ctx; ethif} in
if no_init then
Lwt.return t
else
let task, u = Lwt.task () in
Lwt.async (fun () -> start_ticking t u);
(* call listen until we're good in respect to DAD *)
let ethif_listener =
let noop ~src:_ ~dst:_ _ = Lwt.return_unit in
E.input ethif
~arpv4:(fun _ -> Lwt.return_unit)
~ipv4:(fun _ -> Lwt.return_unit)
~ipv6:(input t ~tcp:noop ~udp:noop ~default:(fun ~proto:_ -> noop))
in
let timeout = Mirage_sleep.ns (Duration.of_sec 3) in
Lwt.pick [
(* MCP: replace this error swallowing with proper propagation *)
(Lwt_list.iter_s (output_ign t) outs >>= fun () ->
task) ;
(N.listen netif ~header_size:Ethernet.Packet.sizeof_ethernet ethif_listener >|= fun _ -> ()) ;
timeout
] >>= fun () ->
let expected_ips = match cidr with None -> 1 | Some _ -> 2 in
match get_ip t with
| ips when List.length ips = expected_ips ->
Log.info (fun f -> f "IP6: Started with %a"
Fmt.(list ~sep:(any ",@ ") Ipaddr.V6.pp) ips);
Lwt.return t
| _ -> Lwt.fail_with "IP6 not started, couldn't assign IP addresses"
end

26
unikernel/duniverse/mirage-tcpip/src/ipv6/ipv6.mli Normal file
View file

@ -0,0 +1,26 @@
(*
* Copyright (c) 2014 Nicolas Ojeda Bar <n.oje.bar@gmail.com>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
module Make (N : Mirage_net.S)
(E : Ethernet.S) : sig
include Tcpip.Ip.S with type ipaddr = Ipaddr.V6.t and type prefix = Ipaddr.V6.Prefix.t
val connect :
?no_init:bool ->
?handle_ra:bool ->
?cidr:Ipaddr.V6.Prefix.t ->
?gateway:Ipaddr.V6.t ->
N.t -> E.t -> t Lwt.t
end

207
unikernel/duniverse/mirage-tcpip/src/ipv6/ipv6_wire.ml Normal file
View file

@ -0,0 +1,207 @@
let sizeof_ipv6 = 40
let int_to_protocol = function
| 58 -> Some `ICMP
| 6 -> Some `TCP
| 17 -> Some `UDP
| _ -> None
let protocol_to_int = function
| `ICMP -> 58
| `TCP -> 6
| `UDP -> 17
let set_ip buf off v =
Ipaddr_cstruct.V6.write_cstruct_exn v (Cstruct.shift buf off)
let get_ip buf off =
Ipaddr_cstruct.V6.of_cstruct_exn (Cstruct.shift buf off)
let version_flow_off = 0
let len_off = 4
let nhdr_off = 6
let hlim_off = 7
let src_off = 8
let dst_off = 24
let get_version_flow buf = Cstruct.BE.get_uint32 buf version_flow_off
let set_version_flow buf v = Cstruct.BE.set_uint32 buf version_flow_off v
let get_nhdr buf = Cstruct.get_uint8 buf nhdr_off
let set_nhdr buf v = Cstruct.set_uint8 buf nhdr_off v
let get_len buf = Cstruct.BE.get_uint16 buf len_off
let set_len buf v = Cstruct.BE.set_uint16 buf len_off v
let get_hlim buf = Cstruct.get_uint8 buf hlim_off
let set_hlim buf v = Cstruct.set_uint8 buf hlim_off v
let get_src buf = get_ip buf src_off
let set_src buf v = set_ip buf src_off v
let get_dst buf = get_ip buf dst_off
let set_dst buf v = set_ip buf dst_off v
let ty_off = 0
let get_ty buf = Cstruct.get_uint8 buf ty_off
let set_ty buf v = Cstruct.set_uint8 buf ty_off v
let code_off = 1
let get_code buf = Cstruct.get_uint8 buf code_off
let set_code buf v = Cstruct.set_uint8 buf code_off v
module Ns = struct
let sizeof_ns = 24
let csum_off = 2
let reserved_off = 4
let target_off = 8
let get_checksum buf = Cstruct.BE.get_uint16 buf csum_off
let set_checksum buf v = Cstruct.BE.set_uint16 buf csum_off v
let get_reserved buf = Cstruct.BE.get_uint32 buf reserved_off
let set_reserved buf v = Cstruct.BE.set_uint32 buf reserved_off v
let get_target buf = get_ip buf target_off
let set_target buf v = set_ip buf target_off v
end
module Llopt = struct
let sizeof_llopt = 8
let len_off = 1
let addr_off = 2
let get_len buf = Cstruct.get_uint8 buf len_off
let set_len buf v = Cstruct.set_uint8 buf len_off v
let get_addr buf = Macaddr_cstruct.of_cstruct_exn (Cstruct.shift buf addr_off)
let set_addr buf v =
Macaddr_cstruct.write_cstruct_exn v (Cstruct.shift buf addr_off)
end
module Icmpv6 = struct
let sizeof_icmpv6 = 8
let _reserved_off = 4
let set_checksum = Ns.set_checksum
end
module Na = struct
let sizeof_na = 24
let get_reserved = Ns.get_reserved
let set_reserved = Ns.set_reserved
let get_target = Ns.get_target
let set_target = Ns.set_target
let get_first_reserved_byte buf =
Cstruct.get_uint8 buf Ns.reserved_off
let get_router buf = (get_first_reserved_byte buf land 0x80) <> 0
let get_solicited buf = (get_first_reserved_byte buf land 0x40) <> 0
let get_override buf = (get_first_reserved_byte buf land 0x20) <> 0
end
module Rs = struct
let sizeof_rs = 8
let set_checksum = Ns.set_checksum
let set_reserved = Ns.set_reserved
end
module Pingv6 = struct
let sizeof_pingv6 = 8
let id_off = 4
let seq_off = 6
let get_checksum = Ns.get_checksum
let set_checksum = Ns.set_checksum
let get_id buf = Cstruct.BE.get_uint16 buf id_off
let set_id buf v = Cstruct.BE.set_uint16 buf id_off v
let get_seq buf = Cstruct.BE.set_uint16 buf seq_off
let set_seq buf v = Cstruct.BE.set_uint16 buf seq_off v
end
module Opt = struct
let sizeof_opt = 2
let get_len = Llopt.get_len
let set_len = Llopt.set_len
end
module Opt_prefix = struct
let sizeof_opt_prefix = 32
let get_len = Llopt.get_len
let set_len = Llopt.set_len
let prefix_len_off = 2
let get_prefix_len buf = Cstruct.get_uint8 buf prefix_len_off
let set_prefix_len buf v = Cstruct.set_uint8 buf prefix_len_off v
let reserved1_off = 3
let get_reserved1 buf = Cstruct.get_uint8 buf reserved1_off
let set_reserved1 buf v = Cstruct.set_uint8 buf reserved1_off v
let valid_lifetime_off = 4
let get_valid_lifetime buf = Cstruct.BE.get_uint32 buf valid_lifetime_off
let set_valid_lifetime buf v = Cstruct.BE.set_uint32 buf valid_lifetime_off v
let preferred_lifetime_off = 8
let get_preferred_lifetime buf = Cstruct.BE.get_uint32 buf preferred_lifetime_off
let set_preferred_lifetime buf v = Cstruct.BE.set_uint32 buf preferred_lifetime_off v
let reserved2_off = 12
let prefix_off = 16
let get_prefix buf = get_ip buf prefix_off
let set_prefix buf v = set_ip buf prefix_off v
let on_link buf = get_reserved1 buf land 0x80 <> 0
let autonomous buf = get_reserved1 buf land 0x40 <> 0
end
module Ra = struct
let sizeof_ra = 16
let get_checksum = Ns.get_checksum
let set_checksum = Ns.set_checksum
let cur_hop_limit_off = 4
let get_cur_hop_limit buf = Cstruct.get_uint8 buf cur_hop_limit_off
let reserved_off = 5
let router_lifetime_off = 6
let get_router_lifetime buf = Cstruct.BE.get_uint16 buf router_lifetime_off
let reachable_time_off = 8
let get_reachable_time buf = Cstruct.BE.get_uint32 buf reachable_time_off
let retrans_timer_off = 12
let get_retrans_timer buf = Cstruct.BE.get_uint32 buf retrans_timer_off
end
module Redirect = struct
let sizeof_redirect = 40
let get_checksum = Ns.get_checksum
let set_checksum = Ns.set_checksum
let get_reserved = Ns.get_reserved
let set_reserved = Ns.set_reserved
let get_target = Ns.get_target
let set_target = Ns.set_target
let destination_off = 24
let get_destination buf = get_ip buf destination_off
let set_destination buf v = set_ip buf destination_off v
end
(* let sizeof_ipv6_pseudo_header = 16 + 16 + 4 + 4 *)

1324
unikernel/duniverse/mirage-tcpip/src/ipv6/ndpv6.ml Normal file
View file

File diff suppressed because it is too large Load diff

82
unikernel/duniverse/mirage-tcpip/src/ipv6/ndpv6.mli Normal file
View file

@ -0,0 +1,82 @@
(*
* Copyright (c) 2015 Nicolas Ojeda Bar <n.oje.bar@gmail.com>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
type ipaddr = Ipaddr.V6.t
type prefix = Ipaddr.V6.Prefix.t
type time = int64
val checksum : Cstruct.t -> Cstruct.t list -> int
type event =
[ `Tcp of ipaddr * ipaddr * Cstruct.t
| `Udp of ipaddr * ipaddr * Cstruct.t
| `Default of int * ipaddr * ipaddr * Cstruct.t ]
type context
val local : handle_ra:bool -> now:time -> Macaddr.t ->
context * (Macaddr.t * int * (Cstruct.t -> int)) list
(** [local ~handle_ra ~now mac] is a pair [ctx, outs] where [ctx] is a local IPv6 context
associated to the hardware address [mac]. [outs] is a list of ethif packets
to be sent. *)
val add_ip : now:time -> context -> prefix ->
context * (Macaddr.t * int * (Cstruct.t -> int)) list
(** [add_ip ~now ctx ip] is [ctx', outs] where [ctx'] is [ctx] updated with a
new local ip and [outs] is a list of ethif packets to be sent. *)
val get_ip : context -> ipaddr list
(** [get_ip ctx] returns the list of local ips. *)
val configured_ips : context -> prefix list
(** [configured_ips ctx] returns the list of local prefixes. *)
val select_source : context -> ipaddr -> ipaddr
(** [select_source ctx ip] returns the ip that should be put in the source field
of a packet destined to [ip]. *)
val handle : now:time -> context -> Cstruct.t ->
context * (Macaddr.t * int * (Cstruct.t -> int)) list * event list
(** [handle ~now ctx buf] handles an incoming ipv6 packet. It returns
[ctx', bufs, evs] where [ctx'] is the updated context, [bufs] is a list of
packets to be sent and [evs] is a list of packets to be passed to the higher
layers (udp, tcp, etc) for further processing. *)
val send : now:time -> context -> ?src:ipaddr -> ipaddr -> Tcpip.Ip.proto ->
int -> (Cstruct.t -> Cstruct.t -> int) -> context * (Macaddr.t * int * (Cstruct.t -> int)) list
(** [send ~now ctx ?src dst proto size fillf] starts route resolution and assembles an
ipv6 packet of [size] for sending with header and body passed to [fillf].
It returns a pair [ctx', dst_size_fills] where [ctx'] is the updated
context and [dst, size, fillf] is a list of packets to be sent, specified
by destination, their size, and fill function. *)
val tick : now:time -> context -> context * (Macaddr.t * int * (Cstruct.t -> int)) list
(** [tick ~now ctx] should be called periodically (every 1s is good). It
returns [ctx', bufs] where [ctx'] is the updated context and [bufs] is a list of
packets to be sent. *)
val add_prefix : now:time -> context -> prefix -> context
(** [add_prefix ~now ctx pfx] adds a local prefix to [ctx]. *)
val get_prefix : context -> prefix list
(** [get_prefix ctx] returns the list of local prefixes known to [ctx]. *)
val add_routers : now:time -> context -> ipaddr list -> context
(** [add_routers ~now ctx ips] adds a list of gateways to [ctx] to be used for
routing. *)
val get_routers : context -> ipaddr list
(** [get_routers ctx] returns the list of gateways known to [ctx]. *)

7
unikernel/duniverse/mirage-tcpip/src/stack-direct/dune Normal file
View file

@ -0,0 +1,7 @@
(library
(name tcpip_stack_direct)
(public_name tcpip.stack-direct)
(instrumentation
(backend bisect_ppx))
(libraries logs ipaddr lwt fmt mirage-sleep mirage-crypto-rng mirage-net
ethernet arp.mirage tcpip.icmpv4 tcpip.udp tcpip.tcp))

240
unikernel/duniverse/mirage-tcpip/src/stack-direct/tcpip_stack_direct.ml Normal file
View file

@ -0,0 +1,240 @@
(*
* Copyright (c) 2011-2014 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Lwt.Infix
let src = Logs.Src.create "tcpip-stack-direct" ~doc:"Pure OCaml TCP/IP stack"
module Log = (val Logs.src_log src : Logs.LOG)
module IPV4V6
(Ipv4 : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t and type prefix = Ipaddr.V4.Prefix.t)
(Ipv6 : Tcpip.Ip.S with type ipaddr = Ipaddr.V6.t and type prefix = Ipaddr.V6.Prefix.t) = struct
type ipaddr = Ipaddr.t
type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
let pp_ipaddr = Ipaddr.pp
type prefix = Ipaddr.Prefix.t
let pp_prefix = Ipaddr.Prefix.pp
type error = [ Tcpip.Ip.error | `Ipv4 of Ipv4.error | `Ipv6 of Ipv6.error | `Msg of string ]
let pp_error ppf = function
| #Tcpip.Ip.error as e -> Tcpip.Ip.pp_error ppf e
| `Ipv4 e -> Ipv4.pp_error ppf e
| `Ipv6 e -> Ipv6.pp_error ppf e
| `Msg m -> Fmt.string ppf m
type t = { ipv4 : Ipv4.t ; ipv4_only : bool ; ipv6 : Ipv6.t ; ipv6_only : bool }
let connect ~ipv4_only ~ipv6_only ipv4 ipv6 =
if ipv4_only && ipv6_only then
Lwt.fail_with "cannot configure stack with both IPv4 only and IPv6 only"
else
Lwt.return { ipv4 ; ipv4_only ; ipv6 ; ipv6_only }
let disconnect _ = Lwt.return_unit
let input t ~tcp ~udp ~default =
let tcp4 ~src ~dst payload = tcp ~src:(Ipaddr.V4 src) ~dst:(Ipaddr.V4 dst) payload
and tcp6 ~src ~dst payload = tcp ~src:(Ipaddr.V6 src) ~dst:(Ipaddr.V6 dst) payload
and udp4 ~src ~dst payload = udp ~src:(Ipaddr.V4 src) ~dst:(Ipaddr.V4 dst) payload
and udp6 ~src ~dst payload = udp ~src:(Ipaddr.V6 src) ~dst:(Ipaddr.V6 dst) payload
and default4 ~proto ~src ~dst payload = default ~proto ~src:(Ipaddr.V4 src) ~dst:(Ipaddr.V4 dst) payload
and default6 ~proto ~src ~dst payload = default ~proto ~src:(Ipaddr.V6 src) ~dst:(Ipaddr.V6 dst) payload
in
fun buf ->
if Cstruct.length buf >= 1 then
let v = Cstruct.get_uint8 buf 0 lsr 4 in
if v = 4 && not t.ipv6_only then
Ipv4.input t.ipv4 ~tcp:tcp4 ~udp:udp4 ~default:default4 buf
else if v = 6 && not t.ipv4_only then
Ipv6.input t.ipv6 ~tcp:tcp6 ~udp:udp6 ~default:default6 buf
else
Lwt.return_unit
else
Lwt.return_unit
let write t ?fragment ?ttl ?src dst proto ?size headerf bufs =
match dst with
| Ipaddr.V4 dst ->
if not t.ipv6_only then
match
match src with
| None -> Ok None
| Some (Ipaddr.V4 src) -> Ok (Some src)
| _ -> Error (`Msg "source must be V4 if dst is V4")
with
| Error e -> Lwt.return (Error e)
| Ok src ->
Ipv4.write t.ipv4 ?fragment ?ttl ?src dst proto ?size headerf bufs >|= function
| Ok () -> Ok ()
| Error e -> Error (`Ipv4 e)
else begin
Log.warn (fun m -> m "attempted to write an IPv4 packet in a v6 only stack");
Lwt.return (Ok ())
end
| Ipaddr.V6 dst ->
if not t.ipv4_only then
match
match src with
| None -> Ok None
| Some (Ipaddr.V6 src) -> Ok (Some src)
| _ -> Error (`Msg "source must be V6 if dst is V6")
with
| Error e -> Lwt.return (Error e)
| Ok src ->
Ipv6.write t.ipv6 ?fragment ?ttl ?src dst proto ?size headerf bufs >|= function
| Ok () -> Ok ()
| Error e -> Error (`Ipv6 e)
else begin
Log.warn (fun m -> m "attempted to write an IPv6 packet in a v4 only stack");
Lwt.return (Ok ())
end
let pseudoheader t ?src dst proto len =
match dst with
| Ipaddr.V4 dst ->
let src =
match src with
| None -> None
| Some (Ipaddr.V4 src) -> Some src
| _ -> None (* cannot happen *)
in
Ipv4.pseudoheader t.ipv4 ?src dst proto len
| Ipaddr.V6 dst ->
let src =
match src with
| None -> None
| Some (Ipaddr.V6 src) -> Some src
| _ -> None (* cannot happen *)
in
Ipv6.pseudoheader t.ipv6 ?src dst proto len
let src t ~dst =
match dst with
| Ipaddr.V4 dst -> Ipaddr.V4 (Ipv4.src t.ipv4 ~dst)
| Ipaddr.V6 dst -> Ipaddr.V6 (Ipv6.src t.ipv6 ~dst)
[@@@alert "-deprecated"]
let get_ip t =
List.map (fun ip -> Ipaddr.V4 ip) (Ipv4.get_ip t.ipv4) @
List.map (fun ip -> Ipaddr.V6 ip) (Ipv6.get_ip t.ipv6)
[@@@alert "+deprecated"]
let configured_ips t =
List.map (fun cidr -> Ipaddr.V4 cidr) (Ipv4.configured_ips t.ipv4) @
List.map (fun cidr -> Ipaddr.V6 cidr) (Ipv6.configured_ips t.ipv6)
let mtu t ~dst = match dst with
| Ipaddr.V4 dst -> Ipv4.mtu t.ipv4 ~dst
| Ipaddr.V6 dst -> Ipv6.mtu t.ipv6 ~dst
end
module MakeV4V6
(Netif : Mirage_net.S)
(Eth : Ethernet.S)
(Arpv4 : Arp.S)
(Ip : Tcpip.Ip.S with type ipaddr = Ipaddr.t)
(Icmpv4 : Icmpv4.S)
(Udp : Tcpip.Udp.S with type ipaddr = Ipaddr.t)
(Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t) = struct
module UDP = Udp
module TCP = Tcp
module IP = Ip
type t = {
netif : Netif.t;
ethif : Eth.t;
arpv4 : Arpv4.t;
icmpv4 : Icmpv4.t;
ip : IP.t;
udp : Udp.t;
tcp : Tcp.t;
mutable task : unit Lwt.t option;
}
let pp fmt t =
Format.fprintf fmt "mac=%a,ip=%a" Macaddr.pp (Eth.mac t.ethif)
Fmt.(list ~sep:(any ", ") IP.pp_prefix) (IP.configured_ips t.ip)
let tcp { tcp; _ } = tcp
let udp { udp; _ } = udp
let ip { ip; _ } = ip
let listen t =
Lwt.catch (fun () ->
Log.debug (fun f -> f "Establishing or updating listener for stack %a" pp t);
let tcp = Tcp.input t.tcp
and udp = Udp.input t.udp
and default ~proto ~src ~dst buf =
match proto, src, dst with
| 1, Ipaddr.V4 src, Ipaddr.V4 dst -> Icmpv4.input t.icmpv4 ~src ~dst buf
| _ -> Lwt.return_unit
in
let ethif_listener = Eth.input
~arpv4:(Arpv4.input t.arpv4)
~ipv4:(IP.input ~tcp ~udp ~default t.ip)
~ipv6:(IP.input ~tcp ~udp ~default t.ip)
t.ethif
in
Netif.listen t.netif ~header_size:Ethernet.Packet.sizeof_ethernet ethif_listener
>>= function
| Error e ->
Log.warn (fun p -> p "%a" Netif.pp_error e) ;
(* XXX: error should be passed to the caller *)
Lwt.return_unit
| Ok _res ->
let nstat = Netif.get_stats_counters t.netif in
let open Mirage_net in
Log.info (fun f ->
f "listening loop of interface %s terminated regularly:@ %Lu bytes \
(%lu packets) received, %Lu bytes (%lu packets) sent@ "
(Macaddr.to_string (Netif.mac t.netif))
nstat.rx_bytes nstat.rx_pkts
nstat.tx_bytes nstat.tx_pkts) ;
Lwt.return_unit)
(function
| Lwt.Canceled ->
Log.info (fun f -> f "listen of %a cancelled" pp t);
Lwt.return_unit
| e -> Lwt.fail e)
let connect netif ethif arpv4 ip icmpv4 udp tcp =
let t = { netif; ethif; arpv4; ip; icmpv4; tcp; udp; task = None } in
Log.info (fun f -> f "Dual TCP/IP stack assembled: %a" pp t);
Lwt.async (fun () -> let task = listen t in t.task <- Some task; task);
Lwt.return t
let disconnect t =
Log.info (fun f -> f "Dual TCP/IP stack disconnected: %a" pp t);
(match t.task with None -> () | Some task -> Lwt.cancel task);
Lwt.return_unit
end
module TCPV4V6 (S : Tcpip.Stack.V4V6) : sig
include Tcpip.Tcp.S with type ipaddr = Ipaddr.t
and type flow = S.TCP.flow
and type t = S.TCP.t
val connect : S.t -> t Lwt.t
end = struct
include S.TCP
let connect stackv4v6 = Lwt.return (S.tcp stackv4v6)
end

56
unikernel/duniverse/mirage-tcpip/src/stack-direct/tcpip_stack_direct.mli Normal file
View file

@ -0,0 +1,56 @@
(*
* Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
module IPV4V6
(Ipv4 : Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t and type prefix = Ipaddr.V4.Prefix.t)
(Ipv6 : Tcpip.Ip.S with type ipaddr = Ipaddr.V6.t and type prefix = Ipaddr.V6.Prefix.t) : sig
include Tcpip.Ip.S with type ipaddr = Ipaddr.t and type prefix = Ipaddr.Prefix.t
val connect : ipv4_only:bool -> ipv6_only:bool -> Ipv4.t -> Ipv6.t -> t Lwt.t
end
module MakeV4V6
(Netif : Mirage_net.S)
(Ethernet : Ethernet.S)
(Arpv4 : Arp.S)
(Ip : Tcpip.Ip.S with type ipaddr = Ipaddr.t and type prefix = Ipaddr.Prefix.t)
(Icmpv4 : Icmpv4.S)
(Udp : Tcpip.Udp.S with type ipaddr = Ipaddr.t)
(Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t) : sig
include Tcpip.Stack.V4V6
with module IP = Ip
and module TCP = Tcp
and module UDP = Udp
val connect : Netif.t -> Ethernet.t -> Arpv4.t -> Ip.t -> Icmpv4.t -> Udp.t -> Tcp.t -> t Lwt.t
(** [connect] assembles the arguments into a network stack, then calls
`listen` on the assembled stack before returning it to the caller. The
initial `listen` functions to ensure that the lower-level layers are
functioning, so that if the user wishes to establish outbound connections,
they will be able to do so. *)
end
module TCPV4V6
(S : Tcpip.Stack.V4V6)
: sig
include Tcpip.Tcp.S with type ipaddr = Ipaddr.t
and type flow = S.TCP.flow
and type t = S.TCP.t
val connect : S.t -> t Lwt.t
(** [connect] returns the TCP/IP stack from a network stack to let the user to
initiate only TCP/IP connections (regardless UDP/IP). *)
end

50
unikernel/duniverse/mirage-tcpip/src/stack-unix/dune Normal file
View file

@ -0,0 +1,50 @@
(library
(name icmpv4_socket)
(public_name tcpip.icmpv4-socket)
(modules icmpv4_socket)
(wrapped false)
(instrumentation
(backend bisect_ppx))
(libraries lwt.unix ipaddr.unix cstruct-lwt tcpip.icmpv4 tcpip.ipv4
tcpip.ipv6))
(library
(name udpv4v6_socket)
(public_name tcpip.udpv4v6-socket)
(modules udpv4v6_socket)
(wrapped false)
(instrumentation
(backend bisect_ppx))
(libraries lwt.unix ipaddr.unix cstruct-lwt fmt logs))
(library
(name tcp_socket_options)
(public_name tcpip.tcp_socket_options)
(modules tcp_socket_options)
(foreign_stubs
(language c)
(names tcp_socket_options_stubs)
(flags :standard))
(wrapped false)
(instrumentation
(backend bisect_ppx))
(libraries lwt.unix duration))
(library
(name tcpv4v6_socket)
(public_name tcpip.tcpv4v6-socket)
(modules tcp_socket tcpv4v6_socket)
(wrapped false)
(instrumentation
(backend bisect_ppx))
(libraries lwt.unix ipaddr.unix cstruct-lwt fmt tcpip tcp_socket_options logs))
(library
(name tcpip_stack_socket)
(public_name tcpip.stack-socket)
(modules tcpip_stack_socket ipv4_socket ipv6_socket ipv4v6_socket)
(wrapped false)
(instrumentation
(backend bisect_ppx))
(libraries lwt.unix cstruct-lwt ipaddr.unix logs tcpip.ipv4 tcpip.ipv6
tcpip.tcpv4v6-socket tcpip.udpv4v6-socket))

109
unikernel/duniverse/mirage-tcpip/src/stack-unix/icmpv4_socket.ml Normal file
View file

@ -0,0 +1,109 @@
open Lwt.Infix
type ipaddr = Ipaddr.V4.t
type t = {
mutable listening_sockets : Lwt_unix.file_descr list
}
type error = [ `Ip of string ]
let pp_error ppf (`Ip s) = Fmt.string ppf s
let is_win32 = Sys.os_type = "Win32"
let ipproto_icmp = 1 (* according to BSD /etc/protocols *)
let port = 0 (* port isn't meaningful in this context *)
let safe_close fd =
Lwt.catch
(fun () -> Lwt_unix.close fd)
(function
| Unix.Unix_error (Unix.EBADF, _, _) -> Lwt.return_unit
| e -> Lwt.fail e)
let connect () = Lwt.return { listening_sockets = [] }
let disconnect t = Lwt_list.iter_p safe_close t.listening_sockets
let pp_sockaddr fmt sa =
let open Lwt_unix in
match sa with
| ADDR_UNIX s -> Format.fprintf fmt "%s" s
| ADDR_INET (ip, port) -> Format.fprintf fmt "%s, %d" (Unix.string_of_inet_addr ip) port
let src = Logs.Src.create "icmpv4_socket" ~doc:"Mirage ICMPv4 (Sockets Edition)"
module Log = (val Logs.src_log src : Logs.LOG)
let sendto' fd buf flags dst =
if is_win32 then begin
(* Lwt on Win32 doesn't support Lwt_bytes.sendto *)
let bytes = Bytes.make (Cstruct.length buf) '\000' in
Cstruct.blit_to_bytes buf 0 bytes 0 (Cstruct.length buf);
Lwt_unix.sendto fd bytes 0 (Bytes.length bytes) flags dst
end else Lwt_cstruct.sendto fd buf flags dst
let recvfrom' fd buf flags =
if is_win32 then begin
(* Lwt on Win32 doesn't support Lwt_bytes.recvfrom *)
let bytes = Bytes.make (Cstruct.length buf) '\000' in
Lwt_unix.recvfrom fd bytes 0 (Bytes.length bytes) flags
>>= fun (n, sockaddr) ->
Cstruct.blit_from_bytes bytes 0 buf 0 n;
Lwt.return (n, sockaddr)
end else Lwt_cstruct.recvfrom fd buf flags
let write _t ?src:_ ~dst ?ttl:_ttl buf =
let open Lwt_unix in
let flags = [] in
let ipproto_icmp = 1 in (* according to BSD /etc/protocols *)
let port = 0 in (* port isn't meaningful in this context *)
let fd = socket PF_INET SOCK_RAW ipproto_icmp in
let in_addr = Unix.inet_addr_of_string (Ipaddr.V4.to_string dst) in
let sockaddr = ADDR_INET (in_addr, port) in
Lwt.catch (fun () ->
sendto' fd buf flags sockaddr >>= fun sent ->
if (sent <> (Cstruct.length buf)) then
Log.debug (fun f -> f "short write: %d received vs %d expected" sent (Cstruct.length buf));
Lwt_unix.close fd |> Lwt_result.ok
) (fun exn -> Lwt.return @@ Error (`Ip (Printexc.to_string exn)))
let input t ~src ~dst:_ buf =
(* some default logic -- respond to echo requests with echo replies *)
match Icmpv4_packet.Unmarshal.of_cstruct buf with
| Error s ->
Log.debug (fun f -> f "Error decomposing an ICMP packet: %s" s);
Lwt.return_unit
| Ok (icmp, payload) ->
let open Icmpv4_packet in
match icmp.ty, icmp.subheader with
| Icmpv4_wire.Echo_request, Id_and_seq (id, seq) ->
let response =
{ ty = Icmpv4_wire.Echo_reply;
code = 0x00;
subheader = Id_and_seq (id, seq); } in
(* TODO: if `listen` were allowed to report problems,
* it would be sensible not to discard the value returned here,
* but as it is we can only return () *)
write t ~dst:src (Marshal.make_cstruct response ~payload) >>= fun _ -> Lwt.return_unit
| _, _ -> Lwt.return_unit
let listen t addr fn =
let fd = Lwt_unix.socket PF_INET SOCK_RAW ipproto_icmp in
t.listening_sockets <- fd :: t.listening_sockets;
let sa = Lwt_unix.ADDR_INET (Unix.inet_addr_of_string (Ipaddr.V4.to_string addr), port) in
Lwt_unix.bind fd sa >>= fun () ->
Log.debug (fun f -> f "Bound ICMP file descriptor to %a" pp_sockaddr sa);
let rec loop () =
let receive_buffer = Cstruct.create 4096 in
recvfrom' fd receive_buffer [] >>= fun (len, _sockaddr) ->
(* trim the buffer to the amount of data actually received *)
let receive_buffer = Cstruct.sub receive_buffer 0 len in
(* On macOS the IP length field is set to a very large value (16384) which
probably reflects some kernel datastructure size rather than the real
on-the-wire size. This confuses our IPv4 parser so we correct the size
here. *)
let len = Ipv4_wire.get_len receive_buffer in
Ipv4_wire.set_len receive_buffer (min len (Cstruct.length receive_buffer));
Lwt.async (fun () -> fn receive_buffer);
loop ()
in
loop ()

13
unikernel/duniverse/mirage-tcpip/src/stack-unix/icmpv4_socket.mli Normal file
View file

@ -0,0 +1,13 @@
include Icmpv4.S
val connect : unit -> t Lwt.t
val listen : t -> ipaddr -> (Cstruct.t -> unit Lwt.t) -> unit Lwt.t
(** [listen t addr fn] attempts to create an unprivileged listener on IP address [addr].
When a packet is received, the callback [fn] will be called in a fresh background
thread. The callback will be provided a buffer containing an IP datagram with an
ICMP payload inside.
The thread returned by [listen] blocks until the stack is disconnected.
*)

39
unikernel/duniverse/mirage-tcpip/src/stack-unix/ipv4_socket.ml Normal file
View file

@ -0,0 +1,39 @@
(*
* Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
type t = unit
type error = Tcpip.Ip.error
type ipaddr = Ipaddr.V4.t
type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
type prefix = Ipaddr.V4.Prefix.t
let pp_error = Tcpip.Ip.pp_error
let pp_ipaddr = Ipaddr.V4.pp
let pp_prefix = Ipaddr.V4.Prefix.pp
let mtu _ ~dst:_ = 1500 - Ipv4_wire.sizeof_ipv4
let disconnect _ = Lwt.return_unit
let connect _ = Lwt.return_unit
let input _ ~tcp:_ ~udp:_ ~default:_ _ = Lwt.return_unit
let write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ =
Lwt.fail (Failure "Not implemented")
let get_ip _ = [Ipaddr.V4.any]
let configured_ips _ = [Ipaddr.V4.Prefix.global]
let src _ ~dst:_ = raise (Failure "Not implemented")
let pseudoheader _ ?src:_ _ _ _ = raise (Failure "Not implemented")

41
unikernel/duniverse/mirage-tcpip/src/stack-unix/ipv4v6_socket.ml Normal file
View file

@ -0,0 +1,41 @@
(*
* Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
type t = unit
type error = Tcpip.Ip.error
type ipaddr = Ipaddr.t
type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
type prefix = Ipaddr.Prefix.t
let pp_error = Tcpip.Ip.pp_error
let pp_ipaddr = Ipaddr.pp
let pp_prefix = Ipaddr.Prefix.pp
let mtu _ ~dst = match dst with
| Ipaddr.V4 _ -> 1500 - Ipv4_wire.sizeof_ipv4
| Ipaddr.V6 _ -> 1500 - Ipv6_wire.sizeof_ipv6
let disconnect _ = Lwt.return_unit
let connect _ = Lwt.return_unit
let input _ ~tcp:_ ~udp:_ ~default:_ _ = Lwt.return_unit
let write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ =
Lwt.fail (Failure "Not implemented")
let get_ip _ = [Ipaddr.V6 Ipaddr.V6.unspecified]
let configured_ips _ = [Ipaddr.Prefix.of_string_exn "::/0"]
let src _ ~dst:_ = raise (Failure "Not implemented")
let pseudoheader _ ?src:_ _ _ _ = raise (Failure "Not implemented")

40
unikernel/duniverse/mirage-tcpip/src/stack-unix/ipv6_socket.ml Normal file
View file

@ -0,0 +1,40 @@
(*
* Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
* Copyright (c) 2014 Nicolas Ojeda Bar <n.oje.bar@gmail.com>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
type t = unit
type error = Tcpip.Ip.error
type ipaddr = Ipaddr.V6.t
type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
type prefix = Ipaddr.V6.Prefix.t
let pp_error = Tcpip.Ip.pp_error
let pp_ipaddr = Ipaddr.V6.pp
let pp_prefix = Ipaddr.V6.Prefix.pp
let mtu _ ~dst:_ = 1500 - Ipv6_wire.sizeof_ipv6
let disconnect () = Lwt.return_unit
let connect () = Lwt.return_unit
let input _ ~tcp:_ ~udp:_ ~default:_ _ = Lwt.return_unit
let write _ ?fragment:_ ?ttl:_ ?src:_ _ _ ?size:_ _ _ =
Lwt.fail (Failure "Not implemented")
let get_ip _ = [Ipaddr.V6.unspecified]
let configured_ips _ = [Ipaddr.V6.Prefix.of_string_exn "::/0"]
let src _ ~dst:_ = raise (Failure "Not implemented")
let pseudoheader _ ?src:_ _ _ _ = raise (Failure "Not implemented")

76
unikernel/duniverse/mirage-tcpip/src/stack-unix/tcp_socket.ml Normal file
View file

@ -0,0 +1,76 @@
open Lwt
type error = [ Tcpip.Tcp.error | `Exn of exn ]
type write_error = [ Tcpip.Tcp.write_error | `Exn of exn ]
let pp_error ppf = function
| #Tcpip.Tcp.error as e -> Tcpip.Tcp.pp_error ppf e
| `Exn e -> Fmt.exn ppf e
let pp_write_error ppf = function
| #Tcpip.Tcp.write_error as e -> Tcpip.Tcp.pp_write_error ppf e
| `Exn e -> Fmt.exn ppf e
let ignore_canceled = function
| Lwt.Canceled -> Lwt.return_unit
| exn -> raise exn
let disconnect _ =
return_unit
let read fd =
let buflen = 65536 in
let buf = Cstruct.create buflen in
Lwt.catch (fun () ->
Lwt_cstruct.read fd buf
>>= function
| 0 -> return (Ok `Eof)
| n when n = buflen -> return (Ok (`Data buf))
| n -> return @@ Ok (`Data (Cstruct.sub buf 0 n))
)
(fun exn -> return (Error (`Exn exn)))
let rec write fd buf =
Lwt.catch
(fun () ->
Lwt_cstruct.write fd buf
>>= function
| n when n = Cstruct.length buf -> return @@ Ok ()
| 0 -> return @@ Error `Closed
| n -> write fd (Cstruct.sub buf n (Cstruct.length buf - n))
) (function
| Unix.Unix_error(Unix.EPIPE, _, _) -> return @@ Error `Closed
| e -> return (Error (`Exn e)))
let writev fd bufs =
Lwt_list.fold_left_s
(fun res buf ->
match res with
| Error _ as e -> return e
| Ok () -> write fd buf
) (Ok ()) bufs
(* TODO make nodelay a flow option *)
let write_nodelay fd buf =
write fd buf
(* TODO make nodelay a flow option *)
let writev_nodelay fd bufs =
writev fd bufs
let close fd =
Lwt.catch
(fun () -> Lwt_unix.close fd)
(function
| Unix.Unix_error (Unix.EBADF, _, _) -> Lwt.return_unit
| e -> Lwt.fail e)
let shutdown fd mode =
let cmd = match mode with
| `read -> Lwt_unix.SHUTDOWN_RECEIVE
| `write -> Lwt_unix.SHUTDOWN_SEND
| `read_write -> Lwt_unix.SHUTDOWN_ALL
in
Lwt.return (Lwt_unix.shutdown fd cmd)
let input _t ~src:_ ~dst:_ _buf = Lwt.return_unit

24
unikernel/duniverse/mirage-tcpip/src/stack-unix/tcp_socket_options.ml Normal file
View file

@ -0,0 +1,24 @@
(*
* Copyright (c) 2017 Docker Inc
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
external tcp_set_keepalive_params: Unix.file_descr -> int -> int -> int -> unit = "caml_tcp_set_keepalive_params"
let enable_keepalive ~fd ~after ~interval ~probes =
let fd' = Lwt_unix.unix_file_descr fd in
let after = Duration.to_ms after in
let interval = Duration.to_ms interval in
tcp_set_keepalive_params fd' after interval probes;
Lwt_unix.setsockopt fd Lwt_unix.SO_KEEPALIVE true

88
unikernel/duniverse/mirage-tcpip/src/stack-unix/tcp_socket_options_stubs.c Normal file
View file

@ -0,0 +1,88 @@
/*
* Copyright (c) 2017 Docker Inc
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*/
#include <stdio.h>
#include <stdint.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/fail.h>
#include <caml/bigarray.h>
#include <caml/unixsupport.h>
#ifdef _WIN32
#ifdef _MSC_VER
/* https://docs.microsoft.com/en-us/windows/win32/winsock/sio-keepalive-vals */
#include <Mstcpip.h>
#endif
#else
#include <sys/time.h>
#include <sys/types.h>
#include <sys/socket.h>
#include <netinet/tcp.h>
#include <netinet/in.h>
#endif
/* Round up to the next second */
#define SECONDS_OF_MILLISECONDS(x) ( (x + 999) / 1000 )
CAMLprim value
caml_tcp_set_keepalive_params(value v_fd, value v_time, value v_interval, value v_probe)
{
CAMLparam4(v_fd, v_time, v_interval, v_probe);
#ifdef _WIN32
SOCKET s = Socket_val(v_fd);
DWORD dwBytesRet=0;
struct tcp_keepalive alive;
alive.onoff = TRUE;
alive.keepalivetime = Int_val(v_time); /* ms */
alive.keepaliveinterval = Int_val(v_interval); /* ms */
if (WSAIoctl(s, SIO_KEEPALIVE_VALS, &alive, sizeof(alive),
NULL, 0, &dwBytesRet, NULL, NULL) == SOCKET_ERROR) {
win32_maperr(WSAGetLastError());
}
#elif DARWIN
int s = Int_val(v_fd);
int optval = SECONDS_OF_MILLISECONDS(Int_val(v_time));
if(setsockopt(s, IPPROTO_TCP, TCP_KEEPALIVE, &optval, sizeof optval) < 0) {
uerror("setsockopt", Nothing);
}
optval = SECONDS_OF_MILLISECONDS(Int_val(v_interval));
if(setsockopt(s, IPPROTO_TCP, TCP_KEEPINTVL, &optval, sizeof optval) < 0) {
uerror("setsockopt", Nothing);
}
optval = Int_val(v_probe);
if(setsockopt(s, IPPROTO_TCP, TCP_KEEPCNT, &optval, sizeof optval) < 0) {
uerror("setsockopt", Nothing);
}
#elif LINUX
int s = Int_val(v_fd);
int optval = SECONDS_OF_MILLISECONDS(Int_val(v_time));
if(setsockopt(s, SOL_TCP, TCP_KEEPIDLE, &optval, optlen) < 0) {
uerror("setsockopt", Nothing);
}
optval = SECONDS_OF_MILLISECONDS(Int_val(v_interval));
if(setsockopt(s, SOL_TCP, TCP_KEEPINTVL, &optval, sizeof optval) < 0) {
uerror("setsockopt", Nothing);
}
optval = Int_val(v_probe);
if(setsockopt(s, SOL_TCP, TCP_KEEPCNT, &optval, sizeof optval) < 0) {
uerror("setsockopt", Nothing);
}
#else
fprintf(stderr, "Warning: setting TCP keep-alive parameters not supported on this platform\n");
#endif
CAMLreturn(Val_unit);
}

51
unikernel/duniverse/mirage-tcpip/src/stack-unix/tcpip_stack_socket.ml Normal file
View file

@ -0,0 +1,51 @@
(*
* Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Lwt.Infix
let src = Logs.Src.create "tcpip-stack-socket" ~doc:"Platform's native TCP/IP stack"
module Log = (val Logs.src_log src : Logs.LOG)
module V4V6 = struct
module TCP = Tcpv4v6_socket
module UDP = Udpv4v6_socket
module IP = Ipv4v6_socket
type t = {
udp : UDP.t;
tcp : TCP.t;
stop : unit Lwt.u;
switched_off : unit Lwt.t;
}
let udp { udp; _ } = udp
let tcp { tcp; _ } = tcp
let ip _ = ()
let listen t = t.switched_off
let connect udp tcp =
Log.info (fun f -> f "Dual IPv4 and IPv6 socket stack: connect");
let switched_off, stop = Lwt.wait () in
UDP.set_switched_off udp switched_off;
TCP.set_switched_off tcp switched_off;
Lwt.return { tcp; udp; stop; switched_off }
let disconnect t =
TCP.disconnect t.tcp >>= fun () ->
UDP.disconnect t.udp >|= fun () ->
Lwt.wakeup_later t.stop ()
end

23
unikernel/duniverse/mirage-tcpip/src/stack-unix/tcpip_stack_socket.mli Normal file
View file

@ -0,0 +1,23 @@
(*
* Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
module V4V6 : sig
include Tcpip.Stack.V4V6
with module UDP = Udpv4v6_socket
and module TCP = Tcpv4v6_socket
and module IP = Ipv4v6_socket
val connect : Udpv4v6_socket.t -> Tcpv4v6_socket.t -> t Lwt.t
end

196
unikernel/duniverse/mirage-tcpip/src/stack-unix/tcpv4v6_socket.ml Normal file
View file

@ -0,0 +1,196 @@
(*
* Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
* Copyright (c) 2014 Nicolas Ojeda Bar <n.oje.bar@gmail.com>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
let src = Logs.Src.create "tcpv4v6-socket" ~doc:"TCP socket v4v6 (platform native)"
module Log = (val Logs.src_log src : Logs.LOG)
open Lwt.Infix
type ipaddr = Ipaddr.t
type flow = Lwt_unix.file_descr
type t = {
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 *)
mutable active_connections : Lwt_unix.file_descr list;
listen_sockets : (int, Lwt_unix.file_descr list) Hashtbl.t;
mutable switched_off : unit Lwt.t;
}
let set_switched_off t switched_off =
t.switched_off <- Lwt.pick [ switched_off; t.switched_off ]
let any_v6 = Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified
include Tcp_socket
let connect ~ipv4_only ~ipv6_only ipv4 ipv6 =
let interface =
let v4 = Ipaddr.V4.Prefix.address ipv4 in
let v4_unix = Ipaddr_unix.V4.to_inet_addr v4 in
if ipv4_only then
`V4_only v4_unix
else if ipv6_only then
`V6_only (match ipv6 with
| None -> any_v6
| Some x -> Ipaddr_unix.V6.to_inet_addr (Ipaddr.V6.Prefix.address x))
else
match ipv6, Ipaddr.V4.(compare v4 any) with
| None, 0 -> `Any
| None, _ -> `Ip (v4_unix, any_v6)
| Some x, v4_any ->
let v6 = Ipaddr.V6.Prefix.address x in
if Ipaddr.V6.(compare v6 unspecified = 0) && v4_any = 0 then
`Any
else
`Ip (v4_unix, Ipaddr_unix.V6.to_inet_addr v6)
in
Lwt.return {interface; active_connections = []; listen_sockets = Hashtbl.create 7; switched_off = fst (Lwt.wait ())}
let disconnect t =
Lwt_list.iter_p close t.active_connections >>= fun () ->
Lwt_list.iter_p close
(Hashtbl.fold (fun _ fd acc -> fd @ acc) t.listen_sockets []) >>= fun () ->
Lwt.cancel t.switched_off ; Lwt.return_unit
let dst fd =
match Lwt_unix.getpeername fd with
| Unix.ADDR_UNIX _ ->
raise (Failure "unexpected: got a unix instead of tcp sock")
| Unix.ADDR_INET (ia,port) ->
let ip = Ipaddr_unix.of_inet_addr ia in
let ip = match Ipaddr.to_v4 ip with
| None -> ip
| Some v4 -> Ipaddr.V4 v4
in
ip, port
let src fd =
match Lwt_unix.getsockname fd with
| Unix.ADDR_UNIX _ ->
raise (Failure "unexpected: got a unix instead of tcp sock")
| Unix.ADDR_INET (ia,port) ->
let ip = Ipaddr_unix.of_inet_addr ia in
let ip = match Ipaddr.to_v4 ip with
| None -> ip
| Some v4 -> Ipaddr.V4 v4
in
ip, port
let create_connection ?keepalive t (dst,dst_port) =
match
match dst, t.interface with
| Ipaddr.V4 _, (`Any | `Ip _ | `V4_only _) -> Ok (Lwt_unix.PF_INET, fst)
| Ipaddr.V6 _, (`Any | `Ip _ | `V6_only _) -> Ok (Lwt_unix.PF_INET6, snd)
| Ipaddr.V4 _, `V6_only _ ->
Error (`Msg "Attempted to connect to an IPv4 host, but stack is IPv6 only")
| Ipaddr.V6 _, `V4_only _ ->
Error (`Msg "Attempted to connect to an IPv6 host, but stack is IPv4 only")
with
| Error (`Msg m) -> Lwt.return (Error (`Exn (Invalid_argument m)))
| Ok (family, proj) ->
let fd = Lwt_unix.(socket family SOCK_STREAM 0) in
Lwt.catch (fun () ->
(match t.interface with
| `Any -> Lwt.return_unit
| `Ip p -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (proj p, 0))
| `V4_only ip -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, 0))
| `V6_only ip -> Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, 0))) >>= fun () ->
Lwt_unix.connect fd
(Lwt_unix.ADDR_INET ((Ipaddr_unix.to_inet_addr dst), dst_port))
>>= fun () ->
( match keepalive with
| None -> ()
| Some { Tcpip.Tcp.Keepalive.after; interval; probes } ->
Tcp_socket_options.enable_keepalive ~fd ~after ~interval ~probes );
t.active_connections <- fd :: t.active_connections;
Lwt.return (Ok fd))
(fun exn ->
close fd >>= fun () ->
Lwt.return (Error (`Exn exn)))
let unlisten t ~port =
match Hashtbl.find_opt t.listen_sockets port with
| None -> ()
| Some fds ->
Hashtbl.remove t.listen_sockets port;
try List.iter (fun fd -> Unix.close (Lwt_unix.unix_file_descr fd)) fds with _ -> ()
let listen t ~port ?keepalive callback =
if port < 0 || port > 65535 then
raise (Invalid_argument (Printf.sprintf "invalid port number (%d)" port));
unlisten t ~port;
let fds =
match t.interface with
| `Any ->
let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
Lwt_unix.(setsockopt fd SO_REUSEADDR true);
Lwt_unix.(setsockopt fd IPV6_ONLY false);
[ (fd, Lwt_unix.ADDR_INET (any_v6, port)) ]
| `Ip (v4, v6) ->
let fd = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in
Lwt_unix.(setsockopt fd SO_REUSEADDR true);
let fd' = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
Lwt_unix.(setsockopt fd' SO_REUSEADDR true);
Lwt_unix.(setsockopt fd' IPV6_ONLY true);
[ (fd, Lwt_unix.ADDR_INET (v4, port)) ; (fd', Lwt_unix.ADDR_INET (v6, port)) ]
| `V4_only ip ->
let fd = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in
Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true;
[ (fd, Lwt_unix.ADDR_INET (ip, port)) ]
| `V6_only ip ->
let fd = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
Lwt_unix.(setsockopt fd SO_REUSEADDR true);
Lwt_unix.(setsockopt fd IPV6_ONLY true);
[ (fd, Lwt_unix.ADDR_INET (ip, port)) ]
in
List.iter (fun (fd, addr) ->
Unix.bind (Lwt_unix.unix_file_descr fd) addr;
Hashtbl.replace t.listen_sockets port (List.map fst fds);
Lwt_unix.listen fd 10;
(* FIXME: we should not ignore the result *)
Lwt.async (fun () ->
(* TODO cancellation *)
let rec loop () =
if not (Lwt.is_sleeping t.switched_off) then raise Lwt.Canceled ;
Lwt.catch (fun () ->
Lwt_unix.accept fd >|= fun (afd, _) ->
t.active_connections <- afd :: t.active_connections;
(match keepalive with
| None -> ()
| Some { Tcpip.Tcp.Keepalive.after; interval; probes } ->
Tcp_socket_options.enable_keepalive ~fd:afd ~after ~interval ~probes);
Lwt.async
(fun () ->
Lwt.catch
(fun () -> callback afd)
(fun exn ->
Log.warn (fun m -> m "tcp error on port %u in callback %s" port (Printexc.to_string exn)) ;
close afd));
`Continue)
(function
| Unix.Unix_error (Unix.EBADF, _, _) ->
(match Hashtbl.find_opt t.listen_sockets port with
| None -> ()
| Some _ -> Log.warn (fun m -> m "tcp error bad file descriptor in accept on port %u" port)) ;
Lwt.return `Stop
| exn ->
Log.warn (fun m -> m "tcp error on port %u in accept: %s" port (Printexc.to_string exn)) ;
Lwt.return `Continue) >>= function
| `Continue -> loop ()
| `Stop -> Lwt.return_unit
in
Lwt.catch loop ignore_canceled >>= fun () -> close fd)) fds

26
unikernel/duniverse/mirage-tcpip/src/stack-unix/tcpv4v6_socket.mli Normal file
View file

@ -0,0 +1,26 @@
(*
* Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
* Copyright (c) 2014 Nicolas Ojeda Bar <n.oje.bar@gmail.com>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
include Tcpip.Tcp.S
with type ipaddr = Ipaddr.t
and type flow = Lwt_unix.file_descr
and type error = [ Tcpip.Tcp.error | `Exn of exn ]
and type write_error = [ Tcpip.Tcp.write_error | `Exn of exn ]
val connect : ipv4_only:bool -> ipv6_only:bool -> Ipaddr.V4.Prefix.t -> Ipaddr.V6.Prefix.t option -> t Lwt.t
val set_switched_off : t -> unit Lwt.t -> unit

213
unikernel/duniverse/mirage-tcpip/src/stack-unix/udpv4v6_socket.ml Normal file
View file

@ -0,0 +1,213 @@
(*
* Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
* Copyright (c) 2014 Nicolas Ojeda Bar <n.oje.bar@gmail.com>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
let src = Logs.Src.create "udpv4v6-socket" ~doc:"UDP socket v4v6 (platform native)"
module Log = (val Logs.src_log src : Logs.LOG)
open Lwt.Infix
type ipaddr = Ipaddr.t
type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t
let any_v6 = Ipaddr_unix.V6.to_inet_addr Ipaddr.V6.unspecified
type t = {
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 *)
listen_fds: (int, Lwt_unix.file_descr * Lwt_unix.file_descr option) Hashtbl.t; (* UDP fds bound to a particular port *)
mutable switched_off : unit Lwt.t;
}
let set_switched_off t switched_off =
t.switched_off <- Lwt.pick [ switched_off; t.switched_off ]
let ignore_canceled = function
| Lwt.Canceled -> Lwt.return_unit
| exn -> raise exn
let get_udpv4v6_listening_fd ?(preserve = true) ?(v4_or_v6 = `Both) {listen_fds;interface;_} port =
try
Lwt.return
(match Hashtbl.find listen_fds port with
| (fd, None) -> false, [ fd ]
| (fd, Some fd') -> false, [ fd ; fd' ])
with Not_found ->
(match interface with
| `Any ->
let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in
Lwt_unix.(setsockopt fd IPV6_ONLY false);
Lwt_unix.bind fd (Lwt_unix.ADDR_INET (any_v6, port)) >|= fun () ->
((fd, None), [ fd ])
| `Ip (v4, v6) ->
(match v4_or_v6 with
| `Both ->
let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in
Lwt_unix.bind fd (Lwt_unix.ADDR_INET (v4, port)) >>= fun () ->
let fd' = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in
Lwt_unix.(setsockopt fd' IPV6_ONLY true);
Lwt_unix.bind fd' (Lwt_unix.ADDR_INET (v6, port)) >|= fun () ->
((fd, Some fd'), [ fd ; fd' ])
| `V4 ->
let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in
Lwt_unix.bind fd (Lwt_unix.ADDR_INET (v4, port)) >|= fun () ->
((fd, None), [ fd ])
| `V6 ->
let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in
Lwt_unix.(setsockopt fd IPV6_ONLY true);
Lwt_unix.bind fd (Lwt_unix.ADDR_INET (v6, port)) >|= fun () ->
((fd, None), [ fd ]))
| `V4_only ip ->
let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in
Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, port)) >|= fun () ->
((fd, None), [ fd ])
| `V6_only ip ->
let fd = Lwt_unix.(socket PF_INET6 SOCK_DGRAM 0) in
Lwt_unix.bind fd (Lwt_unix.ADDR_INET (ip, port)) >|= fun () ->
((fd, None), [ fd ])) >|= fun (fds, r) ->
if preserve then Hashtbl.add listen_fds port fds;
true, r
type error = [`Sendto_failed | `Different_ip_version]
let pp_error ppf = function
| `Sendto_failed -> Fmt.pf ppf "sendto failed to write any bytes"
| `Different_ip_version ->
Fmt.string ppf "attempting to send to a destination with a different IP protocol version"
let close fd =
Lwt.catch
(fun () -> Lwt_unix.close fd)
(function
| Unix.Unix_error (Unix.EBADF, _, _) -> Lwt.return_unit
| e -> Lwt.fail e)
let connect ~ipv4_only ~ipv6_only ipv4 ipv6 =
let v4 = Ipaddr.V4.Prefix.address ipv4 in
let v4_unix = Ipaddr_unix.V4.to_inet_addr v4 in
let interface =
if ipv4_only then
`V4_only v4_unix
else if ipv6_only then
`V6_only (
match ipv6 with
| None -> any_v6
| Some x -> Ipaddr_unix.V6.to_inet_addr (Ipaddr.V6.Prefix.address x))
else
match ipv6, Ipaddr.V4.(compare v4 any) with
| None, 0 -> `Any
| None, _ -> `Ip (v4_unix, any_v6)
| Some x, v4_any ->
let v6 = Ipaddr.V6.Prefix.address x in
if Ipaddr.V6.(compare v6 unspecified = 0) && v4_any = 0 then
`Any
else
`Ip (v4_unix, Ipaddr_unix.V6.to_inet_addr v6)
in
let listen_fds = Hashtbl.create 7 in
Lwt.return { interface; listen_fds; switched_off = fst (Lwt.wait ()) }
let disconnect t =
Hashtbl.fold (fun _ (fd, fd') r ->
r >>= fun () ->
close fd >>= fun () ->
match fd' with None -> Lwt.return_unit | Some fd -> close fd)
t.listen_fds Lwt.return_unit >>= fun () ->
Lwt.cancel t.switched_off ; Lwt.return_unit
let input _t ~src:_ ~dst:_ _buf = Lwt.return_unit
let write ?src:_ ?src_port ?ttl:_ttl ~dst ~dst_port t buf =
let open Lwt_unix in
let rec write_to_fd fd buf =
Lwt.catch (fun () ->
let dst = match t.interface with `Any -> Ipaddr.(V6 (to_v6 dst)) | _ -> dst in
Lwt_cstruct.sendto fd buf [] (ADDR_INET ((Ipaddr_unix.to_inet_addr dst), dst_port))
>>= function
| n when n = Cstruct.length buf -> Lwt.return (Ok ())
| 0 -> Lwt.return (Error `Sendto_failed)
| n -> write_to_fd fd (Cstruct.sub buf n (Cstruct.length buf - n))) (* keep trying *)
(fun _exn -> Lwt.return (Error `Sendto_failed))
in
let v4_or_v6 = match dst with Ipaddr.V4 _ -> `V4 | Ipaddr.V6 _ -> `V6 in
match t.interface, v4_or_v6 with
| `Any, _ | `Ip _, _ | `V4_only _, `V4 | `V6_only _, `V6 ->
let p = match src_port with None -> 0 | Some x -> x in
get_udpv4v6_listening_fd ~preserve:false ~v4_or_v6 t p >>= fun (created, fds) ->
((match fds, v4_or_v6 with
| [ fd ], _ -> Lwt.return (Ok fd)
| [ v4 ; _v6 ], `V4 -> Lwt.return (Ok v4)
| [ _v4; v6 ], `V6 -> Lwt.return (Ok v6)
| _ -> Lwt.return (Error `Different_ip_version)) >>= function
| Error _ as e -> Lwt.return e
| Ok fd ->
write_to_fd fd buf >>= fun r ->
(if created then close fd else Lwt.return_unit) >|= fun () ->
r)
| _ -> Lwt.return (Error `Different_ip_version)
let unlisten t ~port =
try
let fd, fd' = Hashtbl.find t.listen_fds port in
Hashtbl.remove t.listen_fds port;
(match fd' with None -> () | Some fd' -> Unix.close (Lwt_unix.unix_file_descr fd'));
Unix.close (Lwt_unix.unix_file_descr fd)
with _ -> ()
let listen t ~port callback =
if port < 0 || port > 65535 then
raise (Invalid_argument (Printf.sprintf "invalid port number (%d)" port))
else
(* FIXME: we should not ignore the result *)
Lwt.async (fun () ->
get_udpv4v6_listening_fd t port >|= fun (_, fds) ->
List.iter (fun fd ->
Lwt.async (fun () ->
let buf = Cstruct.create 4096 in
let rec loop () =
if not (Lwt.is_sleeping t.switched_off) then raise Lwt.Canceled ;
Lwt.catch (fun () ->
Lwt_cstruct.recvfrom fd buf [] >>= fun (len, sa) ->
if len = 0 then
Lwt.return `Stop
else
(match sa with
| Lwt_unix.ADDR_INET (addr, src_port) ->
let src = Ipaddr_unix.of_inet_addr addr in
let src =
match Ipaddr.to_v4 src with
| None -> src
| Some v4 -> Ipaddr.V4 v4
in
let dst = Ipaddr.(V6 V6.unspecified) in (* TODO *)
let buf = Cstruct.sub_copy buf 0 len in
callback ~src ~dst ~src_port buf
| _ -> Lwt.return_unit) >|= fun () ->
`Continue)
(function
| Unix.Unix_error (Unix.EBADF, _, _) ->
(match Hashtbl.find_opt t.listen_fds port with
| None -> ()
| Some _ ->
Log.info (fun m -> m "udp error bad file descriptor in accept on port %u" port)) ;
Lwt.return `Stop
| exn ->
Log.warn (fun m -> m "udp exception on port %u in recvfrom: %s" port (Printexc.to_string exn)) ;
Lwt.return `Continue) >>= function
| `Continue -> loop ()
| `Stop -> Lwt.return_unit
in
Lwt.catch loop ignore_canceled >>= fun () -> close fd)) fds)

134
unikernel/duniverse/mirage-tcpip/src/tcp/ack.ml Normal file
View file

@ -0,0 +1,134 @@
(*
* Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Lwt.Infix
(* General signature for all the ack modules *)
module type M = sig
type t
(* ack: put mvar to trigger the transmission of an ack *)
val t : send_ack:Sequence.t Lwt_mvar.t -> last:Sequence.t -> t
(* called when new data is received *)
val receive: t -> Sequence.t -> unit Lwt.t
(* called when new data is received *)
val pushack: t -> Sequence.t -> unit Lwt.t
(* called when an ack is transmitted from elsewhere *)
val transmit: t -> Sequence.t -> unit Lwt.t
end
(* Transmit ACKs immediately, the dumbest (and simplest) way *)
module Immediate : M = struct
type t = {
send_ack: Sequence.t Lwt_mvar.t;
mutable pushpending: bool;
}
let t ~send_ack ~last:_ =
let pushpending = false in
{send_ack; pushpending}
let pushack t ack_number =
t.pushpending <- true;
Lwt_mvar.put t.send_ack ack_number
let receive t ack_number =
match t.pushpending with
| true -> Lwt.return_unit
| false -> pushack t ack_number
let transmit t _ =
t.pushpending <- false;
Lwt.return_unit
end
(* Delayed ACKs *)
module Delayed : M = struct
type delayed_r = {
send_ack: Sequence.t Lwt_mvar.t;
mutable delayedack: Sequence.t;
mutable delayed: bool;
mutable pushpending: bool;
}
type t = {
r: delayed_r;
timer: Tcptimer.t;
}
let transmitacknow r ack_number =
Lwt_mvar.put r.send_ack ack_number
let transmitack r ack_number =
match r.pushpending with
| true -> Lwt.return_unit
| false ->
r.pushpending <- true;
transmitacknow r ack_number
let ontimer r s =
match r.delayed with
| false -> Lwt.return Tcptimer.Stoptimer
| true ->
match r.delayedack = s with
| false ->
Lwt.return (Tcptimer.Continue r.delayedack)
| true ->
r.delayed <- false;
transmitack r s >>= fun () ->
Lwt.return Tcptimer.Stoptimer
let t ~send_ack ~last : t =
let pushpending = false in
let delayed = false in
let delayedack = last in
let r = {send_ack; delayedack; delayed; pushpending} in
let expire = ontimer r in
let period_ns = Duration.of_ms 100 in
let timer = Tcptimer.t ~period_ns ~expire in
{r; timer}
(* Advance the received ACK count *)
let receive t ack_number =
match t.r.delayed with
| true ->
t.r.delayed <- false;
transmitack t.r ack_number
| false ->
t.r.delayed <- true;
t.r.delayedack <- ack_number;
Tcptimer.start t.timer ack_number
(* Force out an ACK *)
let pushack t ack_number =
transmitacknow t.r ack_number
(* Indicate that an ACK has been transmitted *)
let transmit t _ =
t.r.delayed <- false;
t.r.pushpending <- false;
Lwt.return_unit
end

29
unikernel/duniverse/mirage-tcpip/src/tcp/ack.mli Normal file
View file

@ -0,0 +1,29 @@
(*
* Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
module type M =
sig
type t
val t : send_ack:Sequence.t Lwt_mvar.t -> last:Sequence.t -> t
val receive : t -> Sequence.t -> unit Lwt.t
val pushack : t -> Sequence.t -> unit Lwt.t
val transmit : t -> Sequence.t -> unit Lwt.t
end
module Immediate : M
module Delayed : M

8
unikernel/duniverse/mirage-tcpip/src/tcp/dune Normal file
View file

@ -0,0 +1,8 @@
(library
(name tcp)
(public_name tcpip.tcp)
(instrumentation
(backend bisect_ppx))
(libraries logs ipaddr cstruct lwt-dllist tcpip.checksum
tcpip duration randomconv fmt mirage-sleep mirage-mtime
mirage-crypto-rng mirage-flow metrics))

773
unikernel/duniverse/mirage-tcpip/src/tcp/flow.ml Normal file
View file

@ -0,0 +1,773 @@
(*
* Copyright (c) 2010-2012 Anil Madhavapeddy <anil@recoil.org>
* Copyright (c) 2012 Balraj Singh <bs375@cl.cam.ac.uk>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Lwt.Infix
let src = Logs.Src.create "tcp.pcb" ~doc:"Mirage TCP PCB module"
module Log = (val Logs.src_log src : Logs.LOG)
module Make(Ip: Tcpip.Ip.S) =
struct
module ACK = Ack.Immediate
module RXS = Segment.Rx(ACK)
module TXS = Segment.Tx
module UTX = User_buffer.Tx
module WIRE = Wire.Make(Ip)
module KEEPALIVE = Keepalive
type error = [ Tcpip.Tcp.error | WIRE.error]
let pp_error ppf = function
| #Tcpip.Tcp.error as e -> Tcpip.Tcp.pp_error ppf e
| #WIRE.error as e -> WIRE.pp_error ppf e
type write_error = [Tcpip.Tcp.write_error | `Not_ready]
let pp_write_error ppf = function
| `Not_ready ->
Fmt.string ppf "attempted to send data before connection was ready"
| #Tcpip.Tcp.write_error as e -> Tcpip.Tcp.pp_write_error ppf e
type ipaddr = Ip.ipaddr
type pcb = {
id: WIRE.t;
wnd: Window.t; (* Window information *)
rxq: RXS.t; (* Received segments queue for out-of-order data *)
txq: TXS.t; (* Transmit segments queue *)
ack: ACK.t; (* Ack state *)
state: State.t; (* Connection state *)
urx: User_buffer.Rx.t; (* App rx buffer *)
utx: UTX.t; (* App tx buffer *)
keepalive: KEEPALIVE.t option; (* Optional TCP keepalive state *)
}
type flow = pcb
type connection = flow * unit Lwt.t
type t = {
ip : Ip.t;
listeners : (int, Tcpip.Tcp.Keepalive.t option * (flow -> unit Lwt.t)) Hashtbl.t ;
mutable active : bool ;
mutable localport : int;
channels: (WIRE.t, connection) Hashtbl.t;
(* server connections the process of connecting - SYN-ACK sent
waiting for ACK *)
listens: (WIRE.t, (Sequence.t * ((flow -> unit Lwt.t) * connection)))
Hashtbl.t;
(* clients in the process of connecting *)
connects: (WIRE.t, ((connection, error) result Lwt.u * Sequence.t * Tcpip.Tcp.Keepalive.t option)) Hashtbl.t;
}
let num_open_channels t = Hashtbl.length t.channels
let listen t ~port ?keepalive cb =
if port < 0 || port > 65535 then
raise (Invalid_argument (Printf.sprintf "invalid port number (%d)" port))
else
Hashtbl.replace t.listeners port (keepalive, cb)
let unlisten t ~port = Hashtbl.remove t.listeners port
let _pp_pcb fmt pcb =
Format.fprintf fmt "id=[%a] state=[%a]" WIRE.pp pcb.id State.pp pcb.state
let pp_stats fmt t =
Format.fprintf fmt "[channels=%d listens=%d connects=%d]"
(Hashtbl.length t.channels)
(Hashtbl.length t.listens)
(Hashtbl.length t.connects)
let log_with_stats name t = Log.debug (fun fmt -> fmt "%s: %a" name pp_stats t)
let wscale_default = 2
module Tx = struct
(* Output a TCP packet, and calculate some settings from a state descriptor *)
let xmit_pcb ip id ~flags ~wnd ~options ~seq (datav : Cstruct.t) =
let window = Int32.to_int (Window.rx_wnd_unscaled wnd) in
let rx_ack = Some (Window.rx_nxt wnd) in
let syn = match flags with Segment.Syn -> true | _ -> false in
let fin = match flags with Segment.Fin -> true | _ -> false in
let rst = match flags with Segment.Rst -> true | _ -> false in
let psh = match flags with Segment.Psh -> true | _ -> false in
WIRE.xmit ~ip id ~syn ~fin ~rst ~psh ~rx_ack ~seq ~window ~options datav
(* Output an RST response when we dont have a PCB *)
let send_rst { ip; _ } id ~sequence ~ack_number ~syn ~fin =
let datalen = Int32.add (if syn then 1l else 0l) (if fin then 1l else 0l) in
let window = 0 in
let options = [] in
let seq = ack_number in
let rx_ack = Some Sequence.(add sequence (of_int32 datalen)) in
WIRE.xmit ~ip id ~rst:true ~rx_ack ~seq ~window ~options (Cstruct.create 0)
(* Output a SYN packet *)
let send_syn { ip; _ } id ~tx_isn ~options ~window =
WIRE.xmit ~ip id ~syn:true ~rx_ack:None ~seq:tx_isn ~window ~options
(Cstruct.create 0)
(* Queue up an immediate close segment *)
let shutdown ctx pcb =
Log.debug (fun f -> f "%s connection %a" (match ctx with `Close -> "Closing" | `Shutdown -> "Shutting down") WIRE.pp pcb.id);
match State.state pcb.state with
| State.Established | State.Close_wait ->
UTX.wait_for_flushed pcb.utx >>= fun () ->
(let { wnd; _ } = pcb in
State.tick pcb.state (State.Send_fin (Window.tx_nxt wnd));
TXS.output ~flags:Segment.Fin pcb.txq Cstruct.empty
)
| State.Closed | State.Syn_rcvd _ | State.Syn_sent _ when ctx = `Close ->
State.on_close pcb.state;
Lwt.return_unit
| _ ->
Log.debug (fun fmt ->
let msg = match ctx with `Close -> "close" | `Shutdown -> "shutdown" in
fmt "TX.%s: %s requested but no action needed, state=%a" msg msg State.pp pcb.state);
Lwt.return_unit
(* Thread that transmits ACKs in response to received packets,
thus telling the other side that more can be sent, and
also data from the user transmit queue *)
let thread t pcb ~send_ack ~rx_ack =
let { wnd; ack; _ } = pcb in
(* Transmit an empty ack when prompted by the Ack thread *)
let rec send_empty_ack () =
Lwt_mvar.take send_ack >>= fun _ ->
let ack_number = Window.rx_nxt wnd in
let flags = Segment.No_flags in
let options = [] in
let seq = Window.tx_nxt wnd in
ACK.transmit ack ack_number >>= fun () ->
xmit_pcb t.ip pcb.id ~flags ~wnd ~options ~seq (Cstruct.create 0) >>=
fun _ -> (* TODO: what to do if sending failed. Ignoring
* errors gives us the same behavior as if the packet
* was lost in transit *)
send_empty_ack () in
(* When something transmits an ACK, tell the delayed ACK thread *)
let rec notify () =
Lwt_mvar.take rx_ack >>= fun ack_number ->
ACK.transmit ack ack_number >>= fun () ->
notify () in
send_empty_ack () <&> (notify ())
end
module Rx = struct
(* Process an incoming TCP packet that has an active PCB *)
let input _t parsed (pcb,_) =
let { rxq; _ } = pcb in
(* The connection is alive! *)
begin match pcb.keepalive with
| None -> ()
| Some keepalive -> KEEPALIVE.refresh keepalive
end;
(* Coalesce any outstanding segments and retrieve ready segments *)
RXS.input rxq parsed
let shutdown pcb =
User_buffer.Rx.remove_all pcb.urx;
User_buffer.Rx.add_r pcb.urx None
(* Thread that spools the data into an application receive buffer,
and notifies the ACK subsystem that new data is here *)
let thread pcb ~rx_data =
let { wnd; ack; urx; _ } = pcb in
(* Thread to monitor application receive and pass it up *)
let rec rx_application_t () =
Lwt_mvar.take rx_data >>= fun (data, winadv) ->
let signal_ack = function
| None -> Lwt.return_unit
| Some winadv when Sequence.(gt winadv zero) ->
Window.rx_advance wnd winadv;
ACK.receive ack (Window.rx_nxt wnd)
| Some winadv ->
Window.rx_advance wnd winadv;
ACK.pushack ack (Window.rx_nxt wnd)
in
begin match data with
| None ->
(* don't send an ACK in this case; this already happened *)
State.tick pcb.state State.Recv_fin;
User_buffer.Rx.add_r urx None
| Some data ->
signal_ack winadv >>= fun () ->
let rec queue = function
| [] -> Lwt.return_unit
| hd::tl ->
User_buffer.Rx.add_r urx (Some hd) >>= fun () ->
queue tl
in
queue data >>= fun _ ->
rx_application_t ()
end
in
rx_application_t ()
end
module Wnd = struct
let thread ~urx:_ ~utx ~wnd:_ ~state ~tx_wnd_update =
(* Monitor our transmit window when updates are received
remotely, and tell the application that new space is
available when it is blocked *)
let rec tx_window_t () =
Lwt_mvar.take tx_wnd_update >>= fun tx_wnd ->
begin match State.state state with
| State.Reset -> UTX.reset utx
| _ -> UTX.free utx tx_wnd
end >>= fun () ->
tx_window_t ()
in
tx_window_t ()
end
(* Helper function to apply function with contents of hashtbl, or
take default action *)
let with_hashtbl h k fn default =
try fn (Hashtbl.find h k) with Not_found -> default k
let hashtbl_find h k =
try Some (Hashtbl.find h k) with Not_found -> None
let clearpcb t id tx_isn =
log_with_stats "removing pcb from connection tables" t;
match hashtbl_find t.channels id with
| Some _ ->
Hashtbl.remove t.channels id;
Stats.decr_channel ();
Log.debug (fun f -> f "removed %a from active channels" WIRE.pp id);
| None ->
match hashtbl_find t.listens id with
| Some (isn, _) ->
if isn = tx_isn then (
Hashtbl.remove t.listens id;
Stats.decr_listen ();
Log.debug (fun f -> f "removed %a from incomplete listen pcbs" WIRE.pp id);
)
| None ->
Log.debug (fun f -> f "error in removing %a - no such connection" WIRE.pp id)
let pcb_allocs = ref 0
let th_allocs = ref 0
let pcb_frees = ref 0
let th_frees = ref 0
let resolve_wnd_scaling options rx_wnd_scaleoffer =
let tx_wnd_scale = List.fold_left (fun a ->
function Options.Window_size_shift m -> Some m | _ -> a
) None options in
match tx_wnd_scale with
| None -> (0, 0), []
| Some tx_f ->
(rx_wnd_scaleoffer, tx_f),
(Options.Window_size_shift rx_wnd_scaleoffer :: [])
type pcb_params =
{ tx_wnd: int;
sequence: Sequence.t;
options: Options.t list;
tx_isn: Sequence.t;
rx_wnd: int;
rx_wnd_scaleoffer: int }
let keepalive_cb t id wnd state urx = function
| `SendProbe ->
Log.debug (fun f -> f "Sending keepalive on connection %a" WIRE.pp id);
(* From https://tools.ietf.org/html/rfc1122#page-101
> 4.2.3.6 TCP Keep-Alives
...
> Such a segment generally contains SEG.SEQ =
> SND.NXT-1 and may or may not contain one garbage octet
> of data. Note that on a quiet connection SND.NXT =
> RCV.NXT, so that this SEG.SEQ will be outside the
> window. Therefore, the probe causes the receiver to
> return an acknowledgment segment, confirming that the
> connection is still live. If the peer has dropped the
> connection due to a network partition or a crash, it
> will respond with a RST instead of an acknowledgment
> segment.
*)
let flags = Segment.No_flags in
let options = [] in
let seq = Sequence.pred @@ Window.tx_nxt wnd in
(* if the sending fails this behaves like a packet drop which will cause
the connection to be eventually closed after the probes are sent *)
Tx.xmit_pcb t.ip id ~flags ~wnd ~options ~seq (Cstruct.create 0) >>= fun _ ->
Lwt.return_unit
| `Close ->
Log.debug (fun f -> f "Keepalive timer expired, resetting connection %a" WIRE.pp id);
State.tick state State.Recv_rst;
(* Close the read direction *)
User_buffer.Rx.add_r urx None >>= fun () ->
Lwt.return_unit
let emitted_keepalive_warning = ref false
let pcb_id = ref (-1)
let new_pcb t params id keepalive =
let mtu_mss = Ip.mtu t.ip ~dst:(WIRE.dst id) - Tcp_wire.sizeof_tcp in
let { tx_wnd; sequence; options; tx_isn; rx_wnd; rx_wnd_scaleoffer } =
params
in
let tx_mss = List.fold_left (fun a ->
function
| Options.MSS m -> min m mtu_mss
| _ -> a
) mtu_mss options
in
let (rx_wnd_scale, tx_wnd_scale), opts =
resolve_wnd_scaling options rx_wnd_scaleoffer
in
(* Set up the windowing variables *)
let rx_isn = sequence in
(* Initialise the window handler *)
let wnd =
Window.t ~rx_wnd_scale ~tx_wnd_scale ~rx_wnd ~tx_wnd ~rx_isn ~tx_mss
~tx_isn
in
(* When we transmit an ACK for a received segment, rx_ack is written to *)
let rx_ack = Lwt_mvar.create_empty () in
(* When we receive an ACK for a transmitted segment, tx_ack is written to *)
let tx_ack = Lwt_mvar.create_empty () in
(* When new data is received, rx_data is written to *)
let rx_data = Lwt_mvar.create_empty () in
(* Write to this mvar to transmit an empty ACK to the remote side *)
let send_ack = Lwt_mvar.create_empty () in
(* The user application receive buffer and close notification *)
let rx_buf_size = Window.rx_wnd wnd in
let urx = User_buffer.Rx.create ~max_size:rx_buf_size ~wnd in
(* The window handling thread *)
let tx_wnd_update = Lwt_mvar.create_empty () in
(* Set up transmit and receive queues *)
let on_close () = clearpcb t id tx_isn in
let state =
incr pcb_id;
State.t ~id:!pcb_id ~on_close
in
let txq, _tx_t =
TXS.create ~xmit:(Tx.xmit_pcb t.ip id) ~wnd ~state ~rx_ack ~tx_ack ~tx_wnd_update
in
(* Set up ACK module *)
let ack = ACK.t ~send_ack ~last:(Sequence.succ rx_isn) in
(* The user application transmit buffer *)
let utx = UTX.create ~wnd ~txq ~max_size:16384l in
let rxq = RXS.create ~rx_data ~ack ~wnd ~state ~tx_ack in
(* Set up the keepalive state if requested *)
let keepalive = match keepalive with
| None -> None
| Some config ->
(* Only omit the warning once to avoid spamming the logs *)
if not !emitted_keepalive_warning then begin
Log.warn (fun f -> f "using keep-alives can cause excessive memory consumption: https://github.com/mirage/mirage-tcpip/issues/367");
emitted_keepalive_warning := true
end;
Some (KEEPALIVE.create config (keepalive_cb t id wnd state urx)) in
(* Construct basic PCB in Syn_received state *)
let pcb = { state; rxq; txq; wnd; id; ack; urx; utx; keepalive } in
(* Compose the overall thread from the various tx/rx threads
and the main listener function *)
let tx_thread = (Tx.thread t pcb ~send_ack ~rx_ack) in
let rx_thread = (Rx.thread pcb ~rx_data) in
let wnd_thread = (Wnd.thread ~utx ~urx ~wnd ~state ~tx_wnd_update) in
let threads = [ tx_thread; rx_thread; wnd_thread ] in
let catch_and_cancel = function
| Lwt.Canceled -> ()
| ex ->
(* cancel the other threads *)
List.iter Lwt.cancel threads;
Log.err (fun f -> f "thread failure: [%s]. Terminating threads and closing connection"
(Printexc.to_string ex));
on_close ();
!Lwt.async_exception_hook ex
in
List.iter (fun t -> Lwt.on_failure t catch_and_cancel) threads;
let th = Lwt.join threads in
pcb_allocs := !pcb_allocs + 1;
th_allocs := !th_allocs + 1;
let fnpcb = fun _ -> pcb_frees := !pcb_frees + 1 in
let fnth = fun _ -> th_frees := !th_frees + 1 in
Gc.finalise fnpcb pcb;
Gc.finalise fnth th;
Lwt.return (pcb, th, opts)
let new_server_connection t params id pushf keepalive =
log_with_stats "new-server-connection" t;
new_pcb t params id keepalive >>= fun (pcb, th, opts) ->
State.tick pcb.state State.Passive_open;
State.tick pcb.state (State.Send_synack params.tx_isn);
(* Add the PCB to our listens table *)
if Hashtbl.mem t.listens id then (
Log.debug (fun f -> f "duplicate attempt to make a connection: %a .\
Removing the old state and replacing with new attempt" WIRE.pp id);
Hashtbl.remove t.listens id;
Stats.decr_listen ();
);
Hashtbl.add t.listens id (params.tx_isn, (pushf, (pcb, th)));
Stats.incr_listen ();
(* Queue a SYN ACK for transmission *)
let options = Options.MSS (Ip.mtu t.ip ~dst:(WIRE.dst id) - Tcp_wire.sizeof_tcp) :: opts in
TXS.output ~flags:Segment.Syn ~options pcb.txq (Cstruct.create 0) >>= fun () ->
Lwt.return (pcb, th)
let new_client_connection t params id ack_number keepalive =
log_with_stats "new-client-connection" t;
let tx_isn = params.tx_isn in
let params = { params with tx_isn = Sequence.succ tx_isn } in
new_pcb t params id keepalive >>= fun (pcb, th, _) ->
(* A hack here because we create the pcb only after the SYN-ACK is rx-ed*)
State.tick pcb.state (State.Send_syn tx_isn);
(* Add the PCB to our connection table *)
Hashtbl.add t.channels id (pcb, th);
Stats.incr_channel ();
State.tick pcb.state (State.Recv_synack ack_number);
(* xmit ACK *)
TXS.output pcb.txq (Cstruct.create 0) >>= fun () ->
Lwt.return (pcb, th)
let is_correct_ack ~tx_isn ~ack_number =
(Sequence.compare (Sequence.succ tx_isn) ack_number) = 0
let process_reset t id ~ack ~ack_number =
log_with_stats "process-reset" t;
if ack then
match hashtbl_find t.connects id with
| Some (wakener, tx_isn, _) ->
(* We don't send data in the syn request, so the expected ack is tx_isn + 1 *)
if is_correct_ack ~tx_isn ~ack_number then begin
Hashtbl.remove t.connects id;
Stats.decr_connect ();
Lwt.wakeup wakener (Error `Refused);
Lwt.return_unit
end else
Lwt.return_unit
| None ->
match hashtbl_find t.listens id with
| Some (_, (_, (pcb, th))) ->
Hashtbl.remove t.listens id;
Stats.decr_listen ();
State.tick pcb.state State.Recv_rst;
Lwt.cancel th;
Lwt.return_unit
| None ->
(* Incoming RST possibly to listen port - ignore per RFC793 pg65 *)
Lwt.return_unit
else
(* rst without ack, drop it *)
Lwt.return_unit
let process_synack t id ~tx_wnd ~ack_number ~sequence ~options ~syn ~fin =
log_with_stats "process-synack" t;
match hashtbl_find t.connects id with
| Some (wakener, tx_isn, keepalive) ->
if is_correct_ack ~tx_isn ~ack_number then (
Hashtbl.remove t.connects id;
Stats.decr_connect ();
let rx_wnd = 65535 in
(* TODO: fix hardcoded value - it assumes that this value was
sent in the SYN *)
let rx_wnd_scaleoffer = wscale_default in
new_client_connection t
{ tx_wnd; sequence; options; tx_isn; rx_wnd; rx_wnd_scaleoffer }
id ack_number keepalive
>>= fun (pcb, th) ->
Lwt.wakeup wakener (Ok (pcb, th));
Lwt.return_unit
) else
(* Normally sending a RST reply to a random pkt would be in
order but here we stay quiet since we are actively trying
to connect this id *)
Lwt.return_unit
| None ->
(* Incoming SYN-ACK with no pending connect and no matching pcb
- send RST *)
Tx.send_rst t id ~sequence ~ack_number ~syn ~fin
>>= fun _ -> Lwt.return_unit (* discard errors; we won't retry *)
let process_syn t id ~tx_wnd ~ack_number ~sequence ~options ~syn ~fin =
log_with_stats "process-syn" t;
match Hashtbl.find_opt t.listeners (WIRE.src_port id) with
| Some (keepalive, process) ->
let tx_isn = Sequence.of_int32 (Randomconv.int32 Mirage_crypto_rng.generate) in
(* TODO: make this configurable per listener *)
let rx_wnd = 65535 in
let rx_wnd_scaleoffer = wscale_default in
new_server_connection t
{ tx_wnd; sequence; options; tx_isn; rx_wnd; rx_wnd_scaleoffer }
id process keepalive
>>= fun _ ->
Lwt.return_unit
| None ->
Tx.send_rst t id ~sequence ~ack_number ~syn ~fin
>>= fun _ -> Lwt.return_unit (* discard errors; we won't retry *)
let process_ack t id ~pkt =
let open RXS in
log_with_stats "process-ack" t;
match hashtbl_find t.listens id with
| Some (tx_isn, (pushf, newconn)) ->
if Tcp_packet.(is_correct_ack ~tx_isn ~ack_number:pkt.header.ack_number) then begin
(* Established connection - promote to active channels *)
Hashtbl.remove t.listens id;
Stats.decr_listen ();
Hashtbl.add t.channels id newconn;
Stats.incr_channel ();
(* Finish processing ACK, so pcb.state is correct *)
Rx.input t pkt newconn >>= fun () ->
(* send new connection up to listener *)
pushf (fst newconn)
end else
(* No RST because we are trying to connect on this id *)
Lwt.return_unit
| None ->
match hashtbl_find t.connects id with
| Some _ ->
(* No RST because we are trying to connect on this id *)
Lwt.return_unit
| None ->
let { sequence; Tcp_packet.ack_number; syn; fin; _ } = pkt.header in
(* ACK but no matching pcb and no listen - send RST *)
Tx.send_rst t id ~sequence ~ack_number ~syn ~fin
>>= fun _ -> Lwt.return_unit (* if send fails, who cares *)
let input_no_pcb t (parsed, payload) id =
if not t.active then
(* TODO: eventually send an RST? *)
Lwt.return_unit
else
let { sequence; Tcp_packet.ack_number; window; options; syn; fin; rst; ack; _ } = parsed in
match rst, syn, ack with
| true, _, _ -> process_reset t id ~ack ~ack_number
| false, true, true ->
process_synack t id ~ack_number ~sequence ~tx_wnd:window ~options ~syn ~fin
| false, true , false -> process_syn t id ~tx_wnd:window
~ack_number ~sequence ~options ~syn ~fin
| false, false, true ->
let open RXS in
process_ack t id ~pkt:{ header = parsed; payload}
| false, false, false ->
Log.debug (fun f -> f "incoming packet matches no connection table entry and has no useful flags set; dropping it");
Lwt.return_unit
(* Main input function for TCP packets *)
let input t ~src ~dst data =
let open Tcp_packet in
match Unmarshal.of_cstruct data with
| Error s -> Log.debug (fun f -> f "parsing TCP header failed: %s" s);
Lwt.return_unit
| Ok (pkt, payload) ->
let id =
WIRE.v ~src_port:pkt.dst_port ~dst_port:pkt.src_port ~dst:src ~src:dst
in
(* Lookup connection from the active PCB hash *)
with_hashtbl t.channels id
(* PCB exists, so continue the connection state machine in tcp_input *)
(Rx.input t RXS.({header = pkt; payload}))
(* No existing PCB, so check if it is a SYN for a listening function *)
(input_no_pcb t (pkt, payload))
(* Blocking read on a PCB *)
let read pcb =
User_buffer.Rx.take_l pcb.urx
>>= function
| None -> Lwt.return @@ Ok `Eof
| Some t -> Lwt.return @@ Ok (`Data t)
(* Maximum allowed write *)
let write_available pcb =
(* Our effective outgoing MTU is what can fit in a page *)
min 4000 (min (Window.tx_mss pcb.wnd)
(Int32.to_int (UTX.available pcb.utx)))
(* Wait for more write space *)
let write_wait_for pcb sz =
UTX.wait_for pcb.utx (Int32.of_int sz)
let rec writefn pcb wfn data =
match State.state pcb.state with
(* but it's only appropriate to send data if the connection is ready for it *)
| State.Established | State.Close_wait -> begin
let len = Cstruct.length data in
match write_available pcb with
| 0 -> (* no room at all; we must wait *)
write_wait_for pcb 1 >>= fun () ->
writefn pcb wfn data
| av_len when av_len >= len -> (* we have enough room for the whole packet *)
wfn [data] >>= fun n -> Lwt.return (Ok n)
| av_len -> (* partial send is possible *)
let sendable = Cstruct.sub data 0 av_len in
writefn pcb wfn sendable >>= function
| Ok () -> writefn pcb wfn @@ Cstruct.sub data av_len (len - av_len)
| Error _ as e -> Lwt.return e
end
| _ -> Lwt.return (Error `Not_ready)
let rec iter_s f = function
| [] -> Lwt.return (Ok ())
| h :: t -> f h >>= function
| Ok () -> iter_s f t
| e -> Lwt.return e
(* Blocking write on a PCB *)
let cast x = (x :> (unit, write_error) result Lwt.t)
let write pcb data = writefn pcb (UTX.write pcb.utx) data |> cast
let writev pcb data = iter_s (write pcb) data |> cast
let write_nodelay pcb data = writefn pcb (UTX.write_nodelay pcb.utx) data |> cast
let writev_nodelay pcb data = iter_s (write_nodelay pcb) data |> cast
(* Close *)
let close pcb = Tx.shutdown `Close pcb
let shutdown pcb mode =
let wr, rd = match mode with | `read -> false, true | `write -> true, false | `read_write -> true, true in
(if wr then Tx.shutdown `Shutdown pcb else Lwt.return_unit) >>= fun () ->
(if rd then Rx.shutdown pcb else Lwt.return_unit)
let dst pcb = WIRE.dst pcb.id, WIRE.dst_port pcb.id
let src pcb = WIRE.src pcb.id, WIRE.src_port pcb.id
let getid t dst dst_port =
(* TODO: make this more robust and recognise when all ports are gone *)
let islistener _t _port =
(* TODO keep a list of active listen ports *)
false in
let idinuse t id =
Hashtbl.mem t.channels id ||
Hashtbl.mem t.connects id ||
Hashtbl.mem t.listens id
in
let inuse t id = islistener t (WIRE.src_port id) || idinuse t id in
let rec bumpport t =
(match t.localport with
| 65535 -> t.localport <- 10000
| _ -> t.localport <- t.localport + 1);
let id =
WIRE.v ~src:(Ip.src t.ip ~dst) ~src_port:t.localport ~dst ~dst_port
in
if inuse t id then bumpport t else id
in
bumpport t
(* SYN retransmission timer *)
let rec connecttimer t id tx_isn options window count =
let rxtime = match count with
| 0 -> 3 | 1 -> 6 | 2 -> 12 | 3 -> 24 | _ -> 48
in
Mirage_sleep.ns (Duration.of_sec rxtime) >>= fun () ->
match hashtbl_find t.connects id with
| None -> Lwt.return_unit
| Some (wakener, isn, _) ->
if isn = tx_isn then
if count > 3 then (
Hashtbl.remove t.connects id;
Stats.decr_connect ();
Lwt.wakeup wakener (Error `Timeout);
Lwt.return_unit
) else (
Tx.send_syn t id ~tx_isn ~options ~window >>= function
| Ok () -> connecttimer t id tx_isn options window (count + 1)
| Error (`No_route _s) ->
(* normal mechanism for recovery is fine *)
connecttimer t id tx_isn options window (count + 1)
| Error `Would_fragment ->
(* this should not happen, if we've a transport that fragments syn.. *)
Log.err (fun m -> m "syn retransmission timer returned would fragment");
Lwt.return_unit
)
else Lwt.return_unit
let connect ?keepalive t ~dst ~dst_port =
let id = getid t dst dst_port in
let tx_isn = Sequence.of_int32 (Randomconv.int32 Mirage_crypto_rng.generate) in
(* TODO: This is hardcoded for now - make it configurable *)
let rx_wnd_scaleoffer = wscale_default in
let options =
Options.MSS (Ip.mtu t.ip ~dst - Tcp_wire.sizeof_tcp) :: Options.Window_size_shift rx_wnd_scaleoffer :: []
in
let window = 5840 in
let th, wakener = Lwt.wait () in
if Hashtbl.mem t.connects id then (
Log.debug (fun f ->
f "duplicate attempt to make a connection: [%a]. \
Removing the old state and replacing with new attempt"
WIRE.pp id);
Hashtbl.remove t.connects id;
Stats.decr_connect ();
);
Hashtbl.add t.connects id (wakener, tx_isn, keepalive);
Stats.incr_connect ();
Tx.send_syn t id ~tx_isn ~options ~window >>= function
| Ok () | Error _ (* keep trying *) ->
Lwt.async (fun () -> connecttimer t id tx_isn options window 0);
th
let log_failure daddr dport = function
| `Timeout ->
Log.debug (fun fmt ->
fmt "Timeout attempting to connect to %a:%d\n%!"
Ip.pp_ipaddr daddr dport)
| `Refused ->
Log.debug (fun fmt ->
fmt "Refused connection to %a:%d\n%!"
Ip.pp_ipaddr daddr dport)
| e ->
Log.debug (fun fmt ->
fmt "%a error connecting to %a:%d\n%!"
pp_error e Ip.pp_ipaddr daddr dport)
let create_connection ?keepalive tcp (daddr, dport) =
if not tcp.active then
Lwt.return (Error `Timeout) (* TODO: custom error variant *)
else
connect ?keepalive tcp ~dst:daddr ~dst_port:dport >>= function
| Error e -> log_failure daddr dport e; Lwt.return @@ Error e
| Ok (fl, _) -> Lwt.return (Ok fl)
(* Construct the main TCP thread *)
let connect ip =
let localport =
1024 + (Randomconv.int ~bound:(0xFFFF - 1024) Mirage_crypto_rng.generate)
in
let listens = Hashtbl.create 1 in
let connects = Hashtbl.create 1 in
let channels = Hashtbl.create 7 in
Log.info (fun f -> f "TCP layer connected on %a"
Fmt.(list ~sep:(any ", ") Ip.pp_prefix)
(Ip.configured_ips ip));
Lwt.return { ip; listeners = Hashtbl.create 7; active = true; localport; channels; listens; connects }
let disconnect t =
t.active <- false;
Log.info (fun f -> f "TCP layer disconnected on %a"
Fmt.(list ~sep:(any ", ") Ip.pp_prefix)
(Ip.configured_ips t.ip));
let conns = Hashtbl.fold (fun _ (pcb, _) acc -> pcb :: acc) t.channels [] in
Lwt_list.iter_p close conns >|= fun () ->
Hashtbl.reset t.listens;
Hashtbl.reset t.connects
(* TODO: should there be Lwt tasks being cancelled? *)
end

26
unikernel/duniverse/mirage-tcpip/src/tcp/flow.mli Normal file
View file

@ -0,0 +1,26 @@
(*
* Copyright (c) 2011-2014 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
module Make (IP:Tcpip.Ip.S) : sig
include Tcpip.Tcp.S with type ipaddr = IP.ipaddr
val connect : IP.t -> t Lwt.t
(**/**)
(* the number of open connections *)
val num_open_channels : t -> int
(**/**)
end

90
unikernel/duniverse/mirage-tcpip/src/tcp/keepalive.ml Normal file
View file

@ -0,0 +1,90 @@
(*
* Copyright (c) 2017 Docker Inc
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
type action = [
| `SendProbe
| `Wait of Duration.t
| `Close
]
type state = {
probes_sent: int
}
let alive = {
probes_sent = 0;
}
let next ~configuration ~ns state =
let open Tcpip.Tcp.Keepalive in
let after_ns = configuration.after in
(* Wait until [time] has gone past *)
if after_ns > ns
then `Wait (Int64.sub after_ns ns), alive
else begin
let sending_probes_for_ns = Int64.sub ns after_ns in
let interval_ns = configuration.interval in
let should_have_sent = Int64.(to_int (div sending_probes_for_ns interval_ns)) in
if should_have_sent > configuration.probes
then `Close, state
else
if should_have_sent > state.probes_sent
then `SendProbe, { probes_sent = should_have_sent } (* we don't want to send back-to-back probes *)
else begin
let since_last_probe_ns = Int64.rem sending_probes_for_ns interval_ns in
`Wait (Int64.sub interval_ns since_last_probe_ns), state
end
end
type t = {
configuration: Tcpip.Tcp.Keepalive.t;
callback: ([ `SendProbe | `Close ] -> unit Lwt.t);
mutable state: state;
mutable timer: unit Lwt.t;
mutable start: int64;
}
(** A keep-alive timer *)
let rec restart t =
let open Lwt.Infix in
let ns = Int64.sub (Mirage_mtime.elapsed_ns ()) t.start in
match next ~configuration:t.configuration ~ns t.state with
| `Wait ns, state ->
Mirage_sleep.ns ns >>= fun () ->
t.state <- state;
restart t
| `SendProbe, state ->
t.callback `SendProbe >>= fun () ->
t.state <- state;
restart t
| `Close, _ ->
t.callback `Close >>= fun () ->
Lwt.return_unit
let create configuration callback =
let state = alive in
let timer = Lwt.return_unit in
let start = Mirage_mtime.elapsed_ns () in
let t = { configuration; callback; state; timer; start } in
t.timer <- restart t;
t
let refresh t =
t.start <- Mirage_mtime.elapsed_ns ();
t.state <- alive;
Lwt.cancel t.timer;
t.timer <- restart t

57
unikernel/duniverse/mirage-tcpip/src/tcp/keepalive.mli Normal file
View file

@ -0,0 +1,57 @@
(*
* Copyright (c) 2017 Docker Inc
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(** TCP keepalives.
A TCP implementation may send "keep-alives" (empty TCP ACKs with the
sequence number set to one less than the current sequence number for
the connection) in order to provoke the peer to respond with an ACK
of the current sequence number. If the peer doesn't recognise the
connection (e.g. because the connection state has been dropped) then
it will return a RST; if the peer (or the network in-between) fails
to respond to a configured number of repeated probes then the
connection is assumed to be lost.
*)
type action = [
| `SendProbe (** we should send a keep-alive now *)
| `Wait of Duration.t (** sleep for a given number of nanoseconds *)
| `Close (** connection should be closed *)
]
(** An I/O action to perform *)
type state
(** State of a current connection *)
val alive: state
(** An alive connection *)
val next: configuration:Tcpip.Tcp.Keepalive.t -> ns:int64 -> state -> action * state
(** [next ~configuration ~ns state] returns the action we should take given
that we last received a packet [ns] nanoseconds ago and the new state
of the connection *)
type t
(** A keep-alive timer *)
val create: Tcpip.Tcp.Keepalive.t -> ([ `SendProbe | `Close] -> unit Lwt.t) -> t
(** [create configuration f clock] returns a keep-alive timer which will call
[f] in future depending on both the [configuration] and any calls to
[refresh] *)
val refresh: t -> unit
(** [refresh t] marks the connection [t] as alive. This should be called
when packets are received. *)

217
unikernel/duniverse/mirage-tcpip/src/tcp/options.ml Normal file
View file

@ -0,0 +1,217 @@
(*
* Copyright (c) 2011 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(* TCP options parsing *)
type t =
| Noop
| MSS of int (* RFC793 *)
| Window_size_shift of int (* RFC1323 2.2 *)
| SACK_ok (* RFC2018 *)
| SACK of (int32 * int32) list (* RFC2018 *)
| Timestamp of int32 * int32 (* RFC1323 3.2 *)
| Unknown of int * string (* RFC793 *)
let equal x y = match x, y with
| Noop, Noop -> true
| MSS x, MSS y -> x = y
| Window_size_shift x, Window_size_shift y -> x = y
| SACK_ok, SACK_ok -> true
| Timestamp (a, b), Timestamp (x, y) -> a = x && b = y
| SACK l1, SACK l2 -> List.for_all2 (fun x y -> x = y) l1 l2
| Unknown (a, s1), Unknown (b, s2) -> a = b && String.equal s1 s2
| _, _ -> false
let report_error n =
let error = Printf.sprintf "Invalid option %d presented" n in
Error error
let check_mss buf =
let min_mss_size = 88 in
let mss_size = Cstruct.BE.get_uint16 buf 2 in
if mss_size < min_mss_size then
let err = (Printf.sprintf "Invalid MSS %d received" mss_size) in
Error err
else
Ok (MSS mss_size)
let unmarshal buf =
let i = Cstruct.iter
(fun buf ->
match Cstruct.get_uint8 buf 0 with
| 0 -> None (* EOF *)
| 1 -> Some 1 (* NOP *)
| _option_type ->
match Cstruct.length buf with
| 0 | 1 -> None
| buffer_size ->
let option_size = Cstruct.get_uint8 buf 1 in
if option_size <= buffer_size && option_size >= 2 then
Some option_size
else None (* Nothing after this can be trusted, but previous
options might be all right *)
)
(fun buf ->
match Cstruct.get_uint8 buf 0 with
| 0 -> assert false
| 1 -> Ok Noop
| option_number ->
let option_length = Cstruct.get_uint8 buf 1 in
if Cstruct.length buf < option_length then
report_error option_number
else begin
match option_number, option_length with
(* error out for lengths that are always nonsensible when option
* number >1 *)
| _, 0 | _, 1 -> report_error option_number
| 2, 4 -> check_mss buf
| 3, 3 -> Ok (Window_size_shift (Cstruct.get_uint8 buf 2))
| 4, 2 -> Ok SACK_ok
| 5, _ ->
let num = (option_length - 2) / 8 in
let rec to_int32_list off acc = function
|0 -> acc
|n ->
let x =
Cstruct.BE.get_uint32 buf off,
Cstruct.BE.get_uint32 buf (off+4)
in
to_int32_list (off+8) (x::acc) (n-1)
in Ok (SACK (to_int32_list 2 [] num))
| 8, 10 -> Ok (Timestamp (Cstruct.BE.get_uint32 buf 2,
Cstruct.BE.get_uint32 buf 6))
(* error out for lengths that don't match the spec's
fixed length for a given, recognized option number *)
| 2, _ | 3, _ | 4, _ | 8, _ -> report_error option_number
(* Parse apparently well-formed but unrecognized
options *)
| n, _ ->
Ok (Unknown (n, Cstruct.to_string ~off:2 buf))
end
) buf in
Result.map List.rev
(Cstruct.fold (fun a b ->
match a, b with
| Ok items, Ok item -> Ok (item :: items)
| _, Error s | Error s, _ -> Error s
) i (Ok []))
let size_of_option = function
| Noop -> 1
| MSS _ -> 4
| Window_size_shift _ -> 3
| SACK_ok -> 2
| SACK acks -> (List.length acks * 8) + 2
| Timestamp _ -> 10
| Unknown (_, contents) -> String.length contents + 2
(* add padding to word length *)
let pad tlen =
match (4 - (tlen mod 4)) mod 4 with
| 0 -> tlen
| n when n < 4 -> tlen + n
| _ -> assert false
let lenv l =
pad @@ List.fold_left (fun acc item -> size_of_option item + acc) 0 l
let write_iter buf =
let set_tlen t l =
Cstruct.set_uint8 buf 0 t;
Cstruct.set_uint8 buf 1 l
in
function
| Noop ->
Cstruct.set_uint8 buf 0 1;
1
| MSS sz ->
set_tlen 2 4;
Cstruct.BE.set_uint16 buf 2 sz;
4
| Window_size_shift shift ->
set_tlen 3 3;
Cstruct.set_uint8 buf 2 shift;
3
| SACK_ok ->
set_tlen 4 2;
2
| SACK acks ->
let tlen = (List.length acks * 8) + 2 in
set_tlen 5 tlen;
let rec fn off = function
| (le,re)::tl ->
Cstruct.BE.set_uint32 buf off le;
Cstruct.BE.set_uint32 buf (off+4) re;
fn (off+8) tl
| [] -> () in
fn 2 acks;
tlen
| Timestamp (tsval,tsecr) ->
set_tlen 8 10;
Cstruct.BE.set_uint32 buf 2 tsval;
Cstruct.BE.set_uint32 buf 6 tsecr;
10
| Unknown (kind, contents) ->
let content_len = String.length contents in
let tlen = content_len + 2 in
set_tlen kind tlen;
Cstruct.blit_from_string contents 0 buf 2 content_len;
tlen
let marshal buf ts =
(* Apply the write iterator on each stamp *)
let rec write fn off buf =
function
| hd::tl ->
let wlen = fn buf hd in
let buf = Cstruct.shift buf wlen in
write fn (off+wlen) buf tl
| [] -> off
in
let tlen = write write_iter 0 buf ts in
(* add padding to word length *)
match (4 - (tlen mod 4)) mod 4 with
| 0 -> tlen
| 1 ->
Cstruct.set_uint8 buf tlen 0;
tlen+1
| 2 ->
Cstruct.set_uint8 buf tlen 0;
Cstruct.set_uint8 buf (tlen+1) 0;
tlen+2
| 3 ->
Cstruct.set_uint8 buf tlen 0;
Cstruct.set_uint8 buf (tlen+1) 0;
Cstruct.set_uint8 buf (tlen+2) 0;
tlen+3
| _ -> assert false
let pf = Format.fprintf
let pp_sack fmt x =
let pp_v fmt (l, r) = pf fmt "[%lu,%lu]" l r in
Format.pp_print_list pp_v fmt x
let pp fmt = function
| Noop -> pf fmt "Noop"
| MSS m -> pf fmt "MSS=%d" m
| Window_size_shift b -> pf fmt "Window>> %d" b
| SACK_ok -> pf fmt "SACK_ok"
| SACK x -> pf fmt "SACK[%a]" pp_sack x
| Timestamp (a,b) -> pf fmt "Timestamp(%lu,%lu)" a b
| Unknown (t,_) -> pf fmt "%d?" t
let pps = Fmt.Dump.list pp

33
unikernel/duniverse/mirage-tcpip/src/tcp/options.mli Normal file
View file

@ -0,0 +1,33 @@
(*
* Copyright (c) 2011 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(** TCP options parsing *)
type t =
| Noop
| MSS of int (** RFC793 *)
| Window_size_shift of int (** RFC1323 2.2 *)
| SACK_ok (** RFC2018 *)
| SACK of (int32 * int32) list (** RFC2018 *)
| Timestamp of int32 * int32 (** RFC1323 3.2 *)
| Unknown of int * string (** RFC793 *)
val equal: t -> t -> bool
val lenv: t list -> int (* how many bytes are required to marshal this list *)
val marshal: Cstruct.t -> t list -> int
val unmarshal : Cstruct.t -> (t list, string) result
val pp : Format.formatter -> t -> unit
val pps : Format.formatter -> t list -> unit

447
unikernel/duniverse/mirage-tcpip/src/tcp/segment.ml Normal file
View file

@ -0,0 +1,447 @@
(*
* Copyright (c) 2010-2011 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Lwt.Infix
let src = Logs.Src.create "tcp.segment" ~doc:"Mirage TCP Segment module"
module Log = (val Logs.src_log src : Logs.LOG)
let lwt_sequence_add_l s seq =
let (_:'a Lwt_dllist.node) = Lwt_dllist.add_l s seq in
()
let lwt_sequence_add_r s seq =
let (_:'a Lwt_dllist.node) = Lwt_dllist.add_r s seq in
()
let peek_opt_l seq =
match Lwt_dllist.take_opt_l seq with
| None -> None
| Some s ->
lwt_sequence_add_l s seq;
Some s
let peek_l seq =
match Lwt_dllist.take_opt_l seq with
| None -> assert false
| Some s ->
let _ = Lwt_dllist.add_l s seq in
s
let rec reset_seq segs =
match Lwt_dllist.take_opt_l segs with
| None -> ()
| Some _ -> reset_seq segs
(* The receive queue stores out-of-order segments, and can
coalesece them on input and pass on an ordered list up the
stack to the application.
It also looks for control messages and dispatches them to
the Rtx queue to ack messages or close channels.
*)
module Rx(ACK: Ack.M) = struct
open Tcp_packet
(* Individual received TCP segment
TODO: this will change when IP fragments work *)
type segment = { header: Tcp_packet.t; payload: Cstruct.t }
let pp_segment fmt {header; payload} =
Format.fprintf fmt
"RX seg seq=%a acknum=%a ack=%b rst=%b syn=%b fin=%b win=%d len=%d"
Sequence.pp header.sequence Sequence.pp header.ack_number
header.ack header.rst header.syn header.fin
header.window (Cstruct.length payload)
let len seg =
Sequence.of_int ((Cstruct.length seg.payload) +
(if seg.header.fin then 1 else 0) +
(if seg.header.syn then 1 else 0))
(* Set of segments, ordered by sequence number *)
module S = Set.Make(struct
type t = segment
let compare a b = (Sequence.compare a.header.sequence b.header.sequence)
end)
type t = {
mutable segs: S.t;
rx_data: (Cstruct.t list option * Sequence.t option) Lwt_mvar.t; (* User receive channel *)
ack: ACK.t;
tx_ack: (Sequence.t * int) Lwt_mvar.t; (* Acks of our transmitted segs *)
wnd: Window.t;
state: State.t;
}
let create ~rx_data ~ack ~wnd ~state ~tx_ack =
let segs = S.empty in
{ segs; rx_data; ack; tx_ack; wnd; state }
let pp fmt t =
let pp_v fmt seg =
Format.fprintf fmt "%a[%a]" Sequence.pp seg.header.sequence Sequence.pp (len seg)
in
Format.pp_print_list pp_v fmt (S.elements t.segs)
(* If there is a FIN flag at the end of this segment set. TODO:
should look for a FIN and chop off the rest of the set as they
may be orphan segments *)
let fin q =
try (S.max_elt q).header.fin
with Not_found -> false
let is_empty q = S.is_empty q.segs
let check_valid_segment q seg =
if seg.header.rst then
begin match State.state q.state with
| State.Reset ->
`Drop
| _ ->
if Sequence.compare seg.header.sequence (Window.rx_nxt q.wnd) = 0 then
`Reset
else if Window.valid q.wnd seg.header.sequence then
`ChallengeAck
else
`Drop
end
else if seg.header.syn then
`ChallengeAck
else if Window.valid q.wnd seg.header.sequence then
let min = Sequence.(sub (Window.tx_una q.wnd) (of_int32 (Window.max_tx_wnd q.wnd))) in
if Sequence.between seg.header.ack_number min (Window.tx_nxt q.wnd) then
`Ok
else
(* rfc5961 5.2 *)
`ChallengeAck
else
`Drop
let send_challenge_ack q =
(* TODO: rfc5961 ACK Throttling *)
ACK.pushack q.ack Sequence.zero
(* Given an input segment, the window information, and a receive
queue, update the window, extract any ready segments into the
user receive queue, and signal any acks to the Tx queue *)
let input (q:t) seg =
match check_valid_segment q seg with
| `Ok ->
let force_ack = ref false in
(* Insert the latest segment *)
let segs = S.add seg q.segs in
(* Walk through the set and get a list of contiguous segments *)
let ready, waiting = S.fold (fun seg acc ->
match Sequence.compare seg.header.sequence (Window.rx_nxt_inseq q.wnd) with
| (-1) ->
(* Sequence number is in the past, probably an overlapping
segment. Drop it for now, but TODO segment
coalescing *)
force_ack := true;
acc
| 0 ->
(* This is the next segment, so put it into the ready set
and update the receive ack number *)
let (ready,waiting) = acc in
Window.rx_advance_inseq q.wnd (len seg);
(S.add seg ready), waiting
| 1 ->
(* Sequence is in the future, so can't use it yet *)
force_ack := true;
let (ready,waiting) = acc in
ready, (S.add seg waiting)
| _ -> assert false
) segs (S.empty, S.empty) in
q.segs <- waiting;
(* If the segment has an ACK, tell the transmit side *)
let tx_ack =
if seg.header.ack && (Sequence.geq seg.header.ack_number (Window.ack_seq q.wnd)) then begin
State.tick q.state (State.Recv_ack seg.header.ack_number);
let data_in_flight = Window.tx_inflight q.wnd in
let ack_has_advanced = (Window.ack_seq q.wnd) <> seg.header.ack_number in
let win_has_changed = (Window.ack_win q.wnd) <> seg.header.window in
if ((data_in_flight && (Window.ack_serviced q.wnd || not ack_has_advanced)) ||
(not data_in_flight && win_has_changed)) then begin
Window.set_ack_serviced q.wnd false;
Window.set_ack_seq_win q.wnd seg.header.ack_number seg.header.window;
Lwt_mvar.put q.tx_ack ((Window.ack_seq q.wnd), (Window.ack_win q.wnd))
end else begin
Window.set_ack_seq_win q.wnd seg.header.ack_number seg.header.window;
Lwt.return_unit
end
end else Lwt.return_unit
in
(* Inform the user application of new data *)
let urx_inform =
(* TODO: deal with overlapping fragments *)
let elems_r, winadv = S.fold (fun seg (acc_l, acc_w) ->
(if Cstruct.length seg.payload > 0 then seg.payload :: acc_l else acc_l),
(Sequence.add (len seg) acc_w)
) ready ([], Sequence.zero) in
let elems = List.rev elems_r in
let w = if !force_ack || Sequence.(gt winadv zero)
then Some winadv else None in
Lwt_mvar.put q.rx_data (Some elems, w) >>= fun () ->
(* If the last ready segment has a FIN, then mark the receive
window as closed and tell the application *)
(if fin ready then begin
if S.cardinal waiting != 0 then
Log.info (fun f -> f "application receive queue closed, but there are waiting segments.");
Lwt_mvar.put q.rx_data (None, Some Sequence.zero)
end else Lwt.return_unit)
in
tx_ack <&> urx_inform
| `ChallengeAck ->
send_challenge_ack q
| `Drop ->
Lwt.return_unit
| `Reset ->
State.tick q.state State.Recv_rst;
(* Abandon our current segments *)
q.segs <- S.empty;
(* Signal TX side *)
let txalert ack_svcd =
if not ack_svcd then Lwt.return_unit
else Lwt_mvar.put q.tx_ack (Window.ack_seq q.wnd, Window.ack_win q.wnd)
in
txalert (Window.ack_serviced q.wnd) >>= fun () ->
(* Use the fin path to inform the application of end of stream *)
Lwt_mvar.put q.rx_data (None, Some Sequence.zero)
end
(* Transmitted segments are sent in-order, and may also be marked
with control flags (such as urgent, or fin to mark the end).
*)
type tx_flags = (* At most one of Syn/Fin/Rst/Psh allowed *)
| No_flags
| Syn
| Fin
| Rst
| Psh
module Tx = struct
type ('a, 'b) xmit =
flags:tx_flags -> wnd:Window.t -> options:Options.t list ->
seq:Sequence.t -> Cstruct.t -> ('a, 'b) result Lwt.t
type seg = {
data: Cstruct.t;
flags: tx_flags;
seq: Sequence.t;
}
(* Sequence length of the segment *)
let len seg =
Sequence.of_int
((match seg.flags with
| No_flags | Psh | Rst -> 0
| Syn | Fin -> 1) +
(Cstruct.length seg.data))
(* Queue of pre-transmission segments *)
type ('a, 'b) q = {
segs: seg Lwt_dllist.t; (* Retransmitted segment queue *)
xmit: ('a, 'b) xmit; (* Transmit packet to the wire *)
rx_ack: Sequence.t Lwt_mvar.t; (* RX Ack thread that we've sent one *)
wnd: Window.t; (* TCP Window information *)
state: State.t; (* state of the TCP connection associated
with this queue *)
tx_wnd_update: int Lwt_mvar.t; (* Received updates to the transmit window *)
rexmit_timer: Tcptimer.t; (* Retransmission timer for this connection *)
mutable dup_acks: int; (* dup ack count for re-xmits *)
}
type t = T: ('a, 'b) q -> t
let ack_segment _ _ = ()
(* Take any action to the user transmit queue due to this being
successfully ACKed *)
(* URG_TODO: Add sequence number to the Syn_rcvd rexmit to only
rexmit most recent *)
let ontimer xmit st segs wnd seq =
match State.state st with
| State.Syn_rcvd _ | State.Established | State.Fin_wait_1 _
| State.Close_wait | State.Closing _ | State.Last_ack _ ->
begin match peek_opt_l segs with
| None -> Lwt.return Tcptimer.Stoptimer
| Some rexmit_seg ->
match rexmit_seg.seq = seq with
| false ->
Log.debug (fun fmt ->
fmt "PUSHING TIMER - new time=%Lu, new seq=%a"
(Window.rto wnd) Sequence.pp rexmit_seg.seq);
let ret =
Tcptimer.ContinueSetPeriod (Window.rto wnd, rexmit_seg.seq)
in
Lwt.return ret
| true ->
if (Window.max_rexmits_done wnd) then (
(* TODO - include more in log msg like ipaddrs *)
Log.debug (fun f -> f "Max retransmits reached: %a" Window.pp wnd);
Log.info (fun fmt -> fmt "Max retransmits reached for connection - terminating");
State.tick st State.Timeout;
Lwt.return Tcptimer.Stoptimer
) else (
let flags = rexmit_seg.flags in
let options = [] in (* TODO: put the right options *)
Log.debug (fun fmt ->
fmt "TCP retransmission triggered by timer! seq = %d"
(Sequence.to_int rexmit_seg.seq));
Lwt.async
(fun () ->
xmit ~flags ~wnd ~options ~seq rexmit_seg.data
(* TODO should this return value really be ignored? *)
>|= fun (_: ('a,'b) result) -> () );
Window.alert_fast_rexmit wnd rexmit_seg.seq;
Window.backoff_rto wnd;
Log.debug (fun fmt -> fmt "Backed off! %a" Window.pp wnd);
Log.debug (fun fmt ->
fmt "PUSHING TIMER - new time = %Lu, new seq = %a"
(Window.rto wnd) Sequence.pp rexmit_seg.seq);
let ret =
Tcptimer.ContinueSetPeriod (Window.rto wnd, rexmit_seg.seq)
in
Lwt.return ret
)
end
| _ -> Lwt.return Tcptimer.Stoptimer
let rec clearsegs q ack_remaining segs =
match Sequence.(gt ack_remaining zero) with
| false -> Sequence.zero (* here we return 0l instead of ack_remaining in case
the ack was an old packet in the network *)
| true ->
match Lwt_dllist.take_opt_l segs with
| None ->
Log.debug (fun f -> f "Dubious ACK received");
ack_remaining
| Some s ->
let seg_len = (len s) in
match Sequence.lt ack_remaining seg_len with
| true ->
Log.debug (fun f -> f "Partial ACK received");
(* return uncleared segment to the sequence *)
lwt_sequence_add_l s segs;
ack_remaining
| false ->
ack_segment q s;
clearsegs q (Sequence.sub ack_remaining seg_len) segs
let rto_t q tx_ack =
(* Listen for incoming TX acks from the receive queue and ACK
segments in our retransmission queue *)
let rec tx_ack_t () =
let serviceack dupack ack_len seq win =
let partleft = clearsegs q ack_len q.segs in
Window.tx_ack q.wnd (Sequence.sub seq partleft) win;
match dupack || Window.fast_rec q.wnd with
| true ->
q.dup_acks <- q.dup_acks + 1;
if q.dup_acks = 3 ||
(Sequence.to_int32 ack_len > 0l) then begin
(* alert window module to fall into fast recovery *)
Window.alert_fast_rexmit q.wnd seq;
(* retransmit the bottom of the unacked list of packets *)
let rexmit_seg = peek_l q.segs in
Log.debug (fun fmt ->
fmt "TCP fast retransmission seq=%a, dupack=%a"
Sequence.pp rexmit_seg.seq Sequence.pp seq);
let { wnd; _ } = q in
let flags=rexmit_seg.flags in
let options=[] in (* TODO: put the right options *)
Lwt.async (fun () ->
q.xmit ~flags ~wnd ~options ~seq rexmit_seg.data
(* TODO should this return value really be ignored? *)
>|= fun (_: ('a,'b) result) -> () );
Lwt.return_unit
end else
Lwt.return_unit
| false ->
q.dup_acks <- 0;
Lwt.return_unit
in
Lwt_mvar.take tx_ack >>= fun _ ->
Window.set_ack_serviced q.wnd true;
let seq = Window.ack_seq q.wnd in
let win = Window.ack_win q.wnd in
begin match State.state q.state with
| State.Reset ->
(* Note: This is not strictly necessary, as the PCB will be
GCed later on. However, it helps removing pressure on
the GC. *)
reset_seq q.segs;
Lwt.return_unit
| _ ->
let ack_len = Sequence.sub seq (Window.tx_una q.wnd) in
let dupacktest () =
0l = Sequence.to_int32 ack_len &&
Window.tx_wnd_unscaled q.wnd = Int32.of_int win &&
not (Lwt_dllist.is_empty q.segs)
in
serviceack (dupacktest ()) ack_len seq win
end >>= fun () ->
(* Inform the window thread of updates to the transmit window *)
Lwt_mvar.put q.tx_wnd_update win >>= fun () ->
tx_ack_t ()
in
tx_ack_t ()
let create ~xmit ~wnd ~state ~rx_ack ~tx_ack ~tx_wnd_update =
let segs = Lwt_dllist.create () in
let dup_acks = 0 in
let expire = ontimer xmit state segs wnd in
let period_ns = Window.rto wnd in
let rexmit_timer = Tcptimer.t ~period_ns ~expire in
let q =
{ xmit; wnd; state; rx_ack; segs; tx_wnd_update;
rexmit_timer; dup_acks }
in
let t = rto_t q tx_ack in
T q, t
(* Queue a segment for transmission. May block if:
- There is no transmit window available.
- The wire transmit function blocks.
The transmitter should check that the segment size will
will not be greater than the transmit window.
*)
let output ?(flags=No_flags) ?(options=[]) (T q) data =
(* Transmit the packet to the wire
TODO: deal with transmission soft/hard errors here RFC5461 *)
let { wnd; _ } = q in
let ack = Window.rx_nxt wnd in
let seq = Window.tx_nxt wnd in
let seg = { data; flags; seq } in
let seq_len = len seg in
Window.tx_advance q.wnd seq_len;
(* Queue up segment just sent for retransmission if needed *)
let q_rexmit () =
match Sequence.(gt seq_len zero) with
| false -> Lwt.return_unit
| true ->
lwt_sequence_add_r seg q.segs;
let p = Window.rto q.wnd in
Tcptimer.start q.rexmit_timer ~p seg.seq
in
q_rexmit () >>= fun () ->
q.xmit ~flags ~wnd ~options ~seq data >>= fun _ ->
(* Inform the RX ack thread that we've just sent one *)
Lwt_mvar.put q.rx_ack ack
end

85
unikernel/duniverse/mirage-tcpip/src/tcp/segment.mli Normal file
View file

@ -0,0 +1,85 @@
(*
* Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(** TCP segments *)
(** The receive queue stores out-of-order segments, and can coalesece
them on input and pass on an ordered list up the stack to the
application.
It also looks for control messages and dispatches them to
the Rtx queue to ack messages or close channels.
*)
module Rx (ACK:Ack.M) : sig
type segment = { header: Tcp_packet.t; payload: Cstruct.t }
(** Individual received TCP segment *)
val pp_segment: Format.formatter -> segment -> unit
type t
(** Queue of receive segments *)
val pp: Format.formatter -> t -> unit
val create:
rx_data:(Cstruct.t list option * Sequence.t option) Lwt_mvar.t ->
ack:ACK.t ->
wnd:Window.t ->
state:State.t ->
tx_ack:(Sequence.t * int) Lwt_mvar.t ->
t
val is_empty : t -> bool
val input : t -> segment -> unit Lwt.t
(** Given the current receive queue and an incoming packet,
update the window, extract any ready segments into the
user receive queue, and signal any acks to the Tx queue *)
end
type tx_flags = No_flags | Syn | Fin | Rst | Psh
(** Either Syn/Fin/Rst allowed, but not combinations *)
(** Pre-transmission queue *)
module Tx : sig
type ('a, 'b) xmit = flags:tx_flags -> wnd:Window.t -> options:Options.t list ->
seq:Sequence.t -> Cstruct.t -> ('a, 'b) result Lwt.t
type t
(** Queue of pre-transmission segments *)
val create:
xmit:('a, 'b) xmit -> wnd:Window.t -> state:State.t ->
rx_ack:Sequence.t Lwt_mvar.t ->
tx_ack:(Sequence.t * int) Lwt_mvar.t ->
tx_wnd_update:int Lwt_mvar.t -> t * unit Lwt.t
val output:
?flags:tx_flags -> ?options:Options.t list -> t -> Cstruct.t -> unit Lwt.t
(** Queue a segment for transmission. May block if:
{ul
{- There is no transmit window available.}
{- The wire transmit function blocks.}}
The transmitter should check that the segment size will not
be greater than the transmit window. *)
end

57
unikernel/duniverse/mirage-tcpip/src/tcp/sequence.ml Normal file
View file

@ -0,0 +1,57 @@
(*
* Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(* TCP sequence numbers must work with overflow, so this puts them in a
separate type to make sure they dont get mixed up *)
type t = int32
(* a < b *)
let lt a b = (Int32.sub a b) < 0l
(* a <= b *)
let leq a b = (Int32.sub a b) <= 0l
(* a > b *)
let gt a b = (Int32.sub a b) > 0l
(* a >= b *)
let geq a b = (Int32.sub a b) >= 0l
(* b <= a <= c *)
let between a b c = (geq a b) && (leq a c)
(* a + b *)
let add a b = Int32.add a b
(* a - b *)
let sub a b = Int32.sub a b
(* a + 1 *)
let succ a = Int32.succ a
(* a - 1 *)
let pred a = Int32.pred a
let compare a b = Int32.compare a b
let of_int32 t = t
let of_int t = Int32.of_int t
let to_int32 t = t
let to_int t = Int32.to_int t
let zero = Int32.zero
let pp fmt t = Format.fprintf fmt "%lu" t

55
unikernel/duniverse/mirage-tcpip/src/tcp/sequence.mli Normal file
View file

@ -0,0 +1,55 @@
(*
* Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
type t
(* a < b *)
val lt : t -> t -> bool
(* a <= b *)
val leq : t -> t -> bool
(* a > b *)
val gt : t -> t -> bool
(* a >= b *)
val geq : t -> t -> bool
(* b <= a <= c *)
val between : t -> t -> t -> bool
(* a + b *)
val add: t -> t -> t
(* a - b *)
val sub: t -> t -> t
(* a + 1 *)
val succ: t -> t
(* a - 1 *)
val pred: t -> t
val compare: t -> t -> int
val of_int32: int32 -> t
val of_int: int -> t
val to_int32: t -> int32
val to_int: t -> int
(* the value produced by of_int 0 *)
val zero : t
val pp: Format.formatter -> t -> unit

176
unikernel/duniverse/mirage-tcpip/src/tcp/state.ml Normal file
View file

@ -0,0 +1,176 @@
(*
* Copyright (c) 2012 Balraj Singh <bs375@cl.cam.ac.uk>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Lwt.Infix
let src = Logs.Src.create "tcp.state" ~doc:"Mirage TCP State module"
module Log = (val Logs.src_log src : Logs.LOG)
type action =
| Passive_open
| Recv_rst
| Recv_synack of Sequence.t
| Recv_ack of Sequence.t
| Recv_fin
(* | Recv_finack of Sequence.t *)
| Send_syn of Sequence.t
| Send_synack of Sequence.t
| Send_rst
| Send_fin of Sequence.t
| Timeout
type tcpstate =
| Closed
| Listen
| Syn_rcvd of Sequence.t
| Syn_sent of Sequence.t
| Established
| Close_wait
| Last_ack of Sequence.t
| Fin_wait_1 of Sequence.t
| Fin_wait_2 of int
| Closing of Sequence.t
| Time_wait
| Reset
type close_cb = unit -> unit
type t = {
on_close: close_cb;
id: int;
mutable state: tcpstate;
}
let t ~id ~on_close =
{ on_close; id; state=Closed }
let on_close t = t.on_close ()
let state t = t.state
let pf = Format.fprintf
let pp_action fmt = function
| Passive_open -> pf fmt "Passive_open"
| Recv_rst -> pf fmt "Recv_rst"
| Recv_synack x -> pf fmt "Recv_synack(%a)" Sequence.pp x
| Recv_ack x -> pf fmt "Recv_ack(%a)" Sequence.pp x
| Recv_fin -> pf fmt "Recv_fin"
(* | Recv_finack x -> pf fmt "Recv_finack(%a)" Sequence.pp x *)
| Send_syn x -> pf fmt "Send_syn(%a)" Sequence.pp x
| Send_synack x -> pf fmt "Send_synack(%a)" Sequence.pp x
| Send_rst -> pf fmt "Send_rst"
| Send_fin x -> pf fmt "Send_fin(%a)" Sequence.pp x
| Timeout -> pf fmt "Timeout"
let pp_tcpstate fmt = function
| Closed -> pf fmt "Closed"
| Listen -> pf fmt "Listen"
| Syn_rcvd x -> pf fmt "Syn_rcvd(%a)" Sequence.pp x
| Syn_sent x -> pf fmt "Syn_sent(%a)" Sequence.pp x
| Established -> pf fmt "Established"
| Close_wait -> pf fmt "Close_wait"
| Last_ack x -> pf fmt "Last_ack(%a)" Sequence.pp x
| Fin_wait_1 x -> pf fmt "Fin_wait_1(%a)" Sequence.pp x
| Fin_wait_2 i -> pf fmt "Fin_wait_2(%d)" i
| Closing x -> pf fmt "Closing(%a)" Sequence.pp x
| Time_wait -> pf fmt "Time_wait"
| Reset -> pf fmt "Reset"
let pp fmt t = pf fmt "{ %a }" pp_tcpstate t.state
let fin_wait_2_time = (* 60 *) Duration.of_sec 10
let time_wait_time = (* 30 *) Duration.of_sec 2
let rec finwait2timer t count timeout =
Log.debug (fun fmt -> fmt "finwait2timer %Lu" timeout);
Mirage_sleep.ns timeout >>= fun () ->
match t.state with
| Fin_wait_2 i ->
Log.debug (fun f -> f "finwait2timer: Fin_wait_2");
if i = count then begin
t.state <- Closed;
t.on_close ();
Lwt.return_unit
end else begin
finwait2timer t i timeout
end
| s ->
Log.debug (fun fmt -> fmt "finwait2timer: %a" pp_tcpstate s);
Lwt.return_unit
let timewait t twomsl =
Log.debug (fun fmt -> fmt "timewait %Lu" twomsl);
Mirage_sleep.ns twomsl >>= fun () ->
t.state <- Closed;
Log.debug (fun fmt -> fmt "timewait on_close");
t.on_close ();
Lwt.return_unit
let transition_to_timewait t =
Lwt.async (fun () -> timewait t time_wait_time);
Time_wait
let tick t (i:action) =
let diffone x y = Sequence.succ y = x in
let tstr s (i:action) =
match s, i with
| Closed, Passive_open -> Listen
| Closed, Send_syn a -> Syn_sent a
| Listen, Send_synack a -> Syn_rcvd a
| Syn_rcvd _, Timeout -> t.on_close (); Closed
| Syn_rcvd _, Recv_rst -> Closed
| Syn_sent _, Timeout -> t.on_close (); Closed
| Syn_sent a, Recv_synack b-> if diffone b a then Established else Syn_sent a
| Syn_rcvd a, Recv_ack b -> if diffone b a then Established else Syn_rcvd a
| Established, Recv_ack _ -> Established
| Established, Send_fin a -> Fin_wait_1 a
| Established, Recv_fin -> Close_wait
| Established, Timeout -> t.on_close (); Closed
| Established, Recv_rst -> t.on_close (); Reset
| Fin_wait_1 a, Recv_ack b ->
if diffone b a then
let count = 0 in
Lwt.async (fun () -> finwait2timer t count fin_wait_2_time);
Fin_wait_2 count
else
Fin_wait_1 a
| Fin_wait_1 a, Recv_fin -> Closing a
| Fin_wait_1 _, Timeout -> t.on_close (); Closed
| Fin_wait_1 _, Recv_rst -> t.on_close (); Reset
| Fin_wait_2 i, Recv_ack _ -> Fin_wait_2 (i + 1)
| Fin_wait_2 _, Recv_rst -> t.on_close (); Reset
| Fin_wait_2 _, Recv_fin -> transition_to_timewait t
| Closing a, Recv_ack b ->
if diffone b a then
transition_to_timewait t
else Closing a
| Closing _, Timeout -> t.on_close (); Closed
| Closing _, Recv_rst -> t.on_close (); Reset
| Time_wait, Timeout -> t.on_close (); Closed
| Close_wait, Send_fin a -> Last_ack a
| Close_wait, Timeout -> t.on_close (); Closed
| Close_wait, Recv_rst -> t.on_close (); Reset
| Last_ack a, Recv_ack b -> if diffone b a then (t.on_close (); Closed) else Last_ack a
| Last_ack _, Timeout -> t.on_close (); Closed
| Last_ack _, Recv_rst -> t.on_close (); Reset
| x, _ -> x
in
let old_state = t.state in
let new_state = tstr t.state i in
Log.debug (fun fmt -> fmt "%d %a - %a -> %a" t.id
pp_tcpstate old_state pp_action i pp_tcpstate new_state);
t.state <- new_state;

63
unikernel/duniverse/mirage-tcpip/src/tcp/state.mli Normal file
View file

@ -0,0 +1,63 @@
(*
* Copyright (c) 2012 Balraj Singh <bs375@cl.cam.ac.uk>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
type action =
| Passive_open
| Recv_rst
| Recv_synack of Sequence.t
| Recv_ack of Sequence.t
| Recv_fin
(* | Recv_finack of Sequence.t *)
| Send_syn of Sequence.t
| Send_synack of Sequence.t
| Send_rst
| Send_fin of Sequence.t
| Timeout
val pp_action: Format.formatter -> action -> unit
type tcpstate =
| Closed
| Listen
| Syn_rcvd of Sequence.t
| Syn_sent of Sequence.t
| Established
| Close_wait
| Last_ack of Sequence.t
| Fin_wait_1 of Sequence.t
| Fin_wait_2 of int
| Closing of Sequence.t
| Time_wait
| Reset
val pp_tcpstate : Format.formatter -> tcpstate -> unit
type close_cb = unit -> unit
type t
val state : t -> tcpstate
val t : id:int -> on_close:close_cb -> t
val on_close : t -> unit
val pp: Format.formatter -> t -> unit
val fin_wait_2_time : int64
val time_wait_time : int64
val finwait2timer : t -> int -> int64 -> unit Lwt.t
val timewait : t -> int64 -> unit Lwt.t
val tick : t -> action -> unit

121
unikernel/duniverse/mirage-tcpip/src/tcp/stats.ml Normal file
View file

@ -0,0 +1,121 @@
(*
* Copyright (c) 2015 Thomas Gazagnaire <thomas@gazagnaire.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
module Gc = struct
let gc = ref false
let enable () = gc := true
let disable () = gc := false
let full = ref false
let full_major b = full := b
let words () =
let t = Gc.stat () in
t.Gc.live_words / 1_000
let run_full_major () = if !full then Gc.full_major ()
let pp fmt () =
match !gc with
| false -> ()
| true ->
run_full_major ();
Format.fprintf fmt "|%dk" (words ())
end
type t = {
mutable tcp_listens : int;
mutable tcp_channels: int;
mutable tcp_connects: int;
mutable tcp_timers : int;
mutable total_established : int;
mutable total_passive_connections : int;
mutable total_active_connections : int;
mutable total_timers : int;
}
let metrics =
let open Metrics in
let doc = "TCP metrics" in
let data t =
Data.v
[ int "syn-rcvd state" t.tcp_listens
; int "established state" t.tcp_channels
; int "client connections" t.tcp_connects
; int "timers" t.tcp_timers
; int "total timers" t.total_timers
; int "total established" t.total_established
; int "total syn-rcvd" t.total_passive_connections
; int "total client" t.total_active_connections ]
in
Src.v ~doc ~tags:Metrics.Tags.[] ~data "tcp"
let pp fmt t = Format.fprintf fmt "[%d|%d|%d|%d%a]"
t.tcp_timers
t.tcp_listens
t.tcp_channels
t.tcp_connects
Gc.pp ()
let singleton =
{
tcp_listens = 0;
tcp_channels = 0;
tcp_connects = 0;
tcp_timers = 0;
total_timers = 0;
total_established = 0;
total_passive_connections = 0;
total_active_connections = 0;
}
let metrics () =
Metrics.add metrics (fun x -> x) (fun d -> d singleton)
let incr_listen () =
singleton.tcp_listens <- succ singleton.tcp_listens;
singleton.total_passive_connections <- succ singleton.total_passive_connections;
metrics ()
let decr_listen () =
singleton.tcp_listens <- pred singleton.tcp_listens;
metrics ()
let incr_channel () =
singleton.tcp_channels <- succ singleton.tcp_channels;
singleton.total_established <- succ singleton.total_established;
metrics ()
let decr_channel () =
singleton.tcp_channels <- pred singleton.tcp_channels;
metrics ()
let incr_connect () =
singleton.tcp_connects <- succ singleton.tcp_connects;
singleton.total_active_connections <- succ singleton.total_active_connections;
metrics ()
let decr_connect () =
singleton.tcp_connects <- pred singleton.tcp_connects;
metrics ()
let incr_timer () =
singleton.tcp_timers <- succ singleton.tcp_timers;
singleton.total_timers <- succ singleton.total_timers;
metrics ()
let decr_timer () =
singleton.tcp_timers <- pred singleton.tcp_timers;
metrics ()

63
unikernel/duniverse/mirage-tcpip/src/tcp/stats.mli Normal file
View file

@ -0,0 +1,63 @@
(*
* Copyright (c) 2015 Thomas Gazagnaire <thomas@gazagnaire.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(** TCP Statistics *)
type t = {
mutable tcp_listens : int;
mutable tcp_channels: int;
mutable tcp_connects: int;
mutable tcp_timers : int;
mutable total_established : int;
mutable total_passive_connections : int;
mutable total_active_connections : int;
mutable total_timers : int;
}
val pp: Format.formatter -> t -> unit
val incr_listen: unit -> unit
val decr_listen: unit -> unit
val incr_channel: unit -> unit
val decr_channel: unit -> unit
val incr_connect: unit -> unit
val decr_connect: unit -> unit
val incr_timer: unit -> unit
val decr_timer: unit -> unit
val singleton: t
module Gc: sig
(** Show GC stats *)
val enable: unit -> unit
(** Show live works (in k) on every debug line. *)
val disable: unit -> unit
val full_major: bool -> unit
(** [full_major true] runs a [Gc.full_major] before printing any
debug statement. Quite expensive but can sometimes be useful. By
default, it is set to [false].
{b Note:} This is very slow, use it if you really need it!
*)
end

145
unikernel/duniverse/mirage-tcpip/src/tcp/tcp_packet.ml Normal file
View file

@ -0,0 +1,145 @@
type t = {
urg : bool;
ack : bool;
psh : bool;
rst : bool;
syn : bool;
fin : bool;
window : Cstruct.uint16;
options : Options.t list;
sequence : Sequence.t;
ack_number : Sequence.t;
src_port : Cstruct.uint16;
dst_port : Cstruct.uint16;
}
let equal {urg; ack; psh; rst; syn; fin; window; options; sequence; ack_number;
src_port; dst_port} q =
src_port = q.src_port &&
dst_port = q.dst_port &&
window = q.window &&
urg = q.urg && ack = q.ack && psh = q.psh && rst = q.rst && syn = q.syn && fin = q.fin &&
Sequence.compare sequence q.sequence = 0 &&
Sequence.compare ack_number q.ack_number = 0 &&
List.for_all2 Options.equal options q.options
let pp fmt t =
Format.fprintf fmt
"TCP packet seq=%a acknum=%a ack=%b rst=%b syn=%b fin=%b win=%d options=%a"
Sequence.pp t.sequence Sequence.pp t.ack_number
t.ack t.rst t.syn t.fin t.window Options.pps t.options
let ( let* ) = Result.bind
module Unmarshal = struct
type error = string
let of_cstruct pkt =
let open Tcp_wire in
let check_len pkt =
if Cstruct.length pkt < sizeof_tcp then
Error "packet too short to contain a TCP packet of any size"
else
Ok (get_data_offset pkt)
in
let long_enough data_offset = if Cstruct.length pkt < data_offset then
Error "packet too short to contain a TCP packet of the size claimed"
else
Ok ()
in
let options data_offset pkt =
if data_offset > 20 then
Options.unmarshal (Cstruct.sub pkt sizeof_tcp (data_offset - sizeof_tcp))
else if data_offset < 20 then
Error "data offset was unreasonably short; TCP header can't be valid"
else (Ok [])
in
let* data_offset = check_len pkt in
let* () = long_enough data_offset in
let* options = options data_offset pkt in
let sequence = get_sequence pkt |> Sequence.of_int32 in
let ack_number = get_ack_number pkt |> Sequence.of_int32 in
let urg = get_urg pkt in
let ack = get_ack pkt in
let psh = get_psh pkt in
let rst = get_rst pkt in
let syn = get_syn pkt in
let fin = get_fin pkt in
let window = get_window pkt in
let src_port = get_src_port pkt in
let dst_port = get_dst_port pkt in
let data = Cstruct.shift pkt data_offset in
Ok ({ urg; ack; psh; rst; syn; fin; window; options;
sequence; ack_number; src_port; dst_port }, data)
end
module Marshal = struct
open Tcp_wire
type error = string
let unsafe_fill ~pseudoheader ~payload t buf options_len =
let data_off = sizeof_tcp + options_len in
let buf = Cstruct.sub buf 0 data_off in
set_src_port buf t.src_port;
set_dst_port buf t.dst_port;
set_sequence buf (Sequence.to_int32 t.sequence);
set_ack_number buf (Sequence.to_int32 t.ack_number);
set_data_offset buf (data_off / 4);
set_flags buf 0;
if t.urg then set_urg buf;
if t.ack then set_ack buf;
if t.rst then set_rst buf;
if t.syn then set_syn buf;
if t.fin then set_fin buf;
if t.psh then set_psh buf;
set_window buf t.window;
set_checksum buf 0;
set_urg_ptr buf 0;
(* it's possible we've been passed a buffer larger than the size of the header,
* which contains some data after the end of the header we'll write;
* in this case, make sure we compute the checksum properly *)
let checksum = Tcpip_checksum.ones_complement_list [pseudoheader ; buf ;
payload] in
set_checksum buf checksum;
()
let into_cstruct ~pseudoheader ~payload t buf =
let check_header_len () =
if (Cstruct.length buf) < sizeof_tcp then Error "Not enough space for a TCP header"
else Ok ()
in
let check_overall_len header_length =
if (Cstruct.length buf) < header_length then
Error (Printf.sprintf "Not enough space for TCP header: %d < %d"
(Cstruct.length buf) header_length)
else Ok ()
in
let insert_options options_frame =
match t.options with
|[] -> Ok 0
|options ->
try
Ok (Options.marshal options_frame options)
with
(* handle the case where we ran out of room in the buffer while attempting
to write the options *)
| Invalid_argument s -> Error s
in
let options_frame = Cstruct.shift buf sizeof_tcp in
let* () = check_header_len () in
let* options_len = insert_options options_frame in
let* () = check_overall_len (sizeof_tcp + options_len) in
let buf = Cstruct.sub buf 0 (sizeof_tcp + options_len) in
unsafe_fill ~pseudoheader ~payload t buf options_len;
Ok (sizeof_tcp + options_len)
let make_cstruct ~pseudoheader ~payload t =
let buf = Cstruct.create (sizeof_tcp + 40) in (* more than 40 bytes of options can't
be signalled in the length field of
the tcp header *)
let options_buf = Cstruct.shift buf sizeof_tcp in
let options_len = Options.marshal options_buf t.options in
let buf = Cstruct.sub buf 0 (sizeof_tcp + options_len) in
unsafe_fill ~pseudoheader ~payload t buf options_len;
buf
end

50
unikernel/duniverse/mirage-tcpip/src/tcp/tcp_packet.mli Normal file
View file

@ -0,0 +1,50 @@
type t = {
urg : bool;
ack : bool;
psh : bool;
rst : bool;
syn : bool;
fin : bool;
window : Cstruct.uint16;
options : Options.t list;
sequence : Sequence.t;
ack_number : Sequence.t;
src_port : Cstruct.uint16;
dst_port : Cstruct.uint16;
}
val pp : Format.formatter -> t -> unit
val equal : t -> t -> bool
module Unmarshal : sig
type error = string
val of_cstruct : Cstruct.t -> (t * Cstruct.t, error) result
end
module Marshal : sig
type error = string
(** [into_cstruct ~pseudoheader ~payload t buf] attempts to write a valid TCP
header representing [t] into [buf] at offset 0. [pseudoheader] and
[payload] are required to calculate a correct checksum but are not
otherwise reflected in the data written into [buf] -- [buf] will contain
only a TCP header after a call to [into_cstruct].
Returns either the number of bytes written into the buffer on success; if
the buffer supplied is too small to write the entire header, an error is
returned. *)
val into_cstruct :
pseudoheader:Cstruct.t ->
payload:Cstruct.t ->
t -> Cstruct.t ->
(int, error) result
(** [make_cstruct ~pseudoheader ~payload t] allocates, fills, and and returns a buffer
representing the TCP header corresponding to [t]. If [t.options] is
non-empty, [t.options] will be concatenated onto the result as part of the
header.
A variable amount of memory (at least 20 bytes, and at most 60) will be allocated, but
[] is not represented in the output. The checksum will be properly
set to reflect the pseudoheader, header, options, and payload. *)
val make_cstruct : pseudoheader:Cstruct.t -> payload:Cstruct.t -> t -> Cstruct.t
end

67
unikernel/duniverse/mirage-tcpip/src/tcp/tcp_wire.ml Normal file
View file

@ -0,0 +1,67 @@
let sizeof_tcp = 20
let src_port_off = 0
let dst_port_off = 2
let sequence_off = 4
let ack_off = 8
let dataoff_off = 12
let flags_off = 13
let window_off = 14
let checksum_off = 16
let urg_ptr_off = 18
let get_src_port buf = Cstruct.BE.get_uint16 buf src_port_off
let set_src_port buf v = Cstruct.BE.set_uint16 buf src_port_off v
let get_dst_port buf = Cstruct.BE.get_uint16 buf dst_port_off
let set_dst_port buf v = Cstruct.BE.set_uint16 buf dst_port_off v
let get_sequence buf = Cstruct.BE.get_uint32 buf sequence_off
let set_sequence buf v = Cstruct.BE.set_uint32 buf sequence_off v
let get_ack_number buf = Cstruct.BE.get_uint32 buf ack_off
let set_ack_number buf v = Cstruct.BE.set_uint32 buf ack_off v
let get_flags buf = Cstruct.get_uint8 buf flags_off
let set_flags buf v = Cstruct.set_uint8 buf flags_off v
let get_window buf = Cstruct.BE.get_uint16 buf window_off
let set_window buf v = Cstruct.BE.set_uint16 buf window_off v
let get_checksum buf = Cstruct.BE.get_uint16 buf checksum_off
let set_checksum buf value = Cstruct.BE.set_uint16 buf checksum_off value
let get_urg_ptr buf = Cstruct.BE.get_uint16 buf urg_ptr_off
let set_urg_ptr buf value = Cstruct.BE.set_uint16 buf urg_ptr_off value
(* XXX note that we overwrite the lower half of dataoff
* with 0, so be careful when implemented CWE flag which
* sits there *)
let get_data_offset buf = ((Cstruct.get_uint8 buf dataoff_off) lsr 4) * 4
let set_data_offset buf v = Cstruct.set_uint8 buf dataoff_off (v lsl 4)
let get_fin buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 0)) > 0
let get_syn buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 1)) > 0
let get_rst buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 2)) > 0
let get_psh buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 3)) > 0
let get_ack buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 4)) > 0
let get_urg buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 5)) > 0
let _get_ece buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 6)) > 0
let _get_cwr buf = ((Cstruct.get_uint8 buf flags_off) land (1 lsl 7)) > 0
let set_fin buf =
Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 0))
let set_syn buf =
Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 1))
let set_rst buf =
Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 2))
let set_psh buf =
Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 3))
let set_ack buf =
Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 4))
let set_urg buf =
Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 5))
let _set_ece buf =
Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 6))
let _set_cwr buf =
Cstruct.set_uint8 buf flags_off ((Cstruct.get_uint8 buf flags_off) lor (1 lsl 7))

42
unikernel/duniverse/mirage-tcpip/src/tcp/tcp_wire.mli Normal file
View file

@ -0,0 +1,42 @@
val sizeof_tcp : int
val get_src_port : Cstruct.t -> int
val set_src_port : Cstruct.t -> int -> unit
val get_dst_port : Cstruct.t -> int
val set_dst_port : Cstruct.t -> int -> unit
val get_sequence : Cstruct.t -> int32
val set_sequence : Cstruct.t -> int32 -> unit
val get_ack_number : Cstruct.t -> int32
val set_ack_number : Cstruct.t -> int32 -> unit
val get_flags : Cstruct.t -> int
val set_flags : Cstruct.t -> int -> unit
val get_window : Cstruct.t -> int
val set_window : Cstruct.t -> int -> unit
val get_checksum : Cstruct.t -> int
val set_checksum : Cstruct.t -> int -> unit
val get_urg_ptr : Cstruct.t -> int
val set_urg_ptr : Cstruct.t -> int -> unit
val get_data_offset : Cstruct.t -> int
val set_data_offset : Cstruct.t -> int -> unit
val get_fin : Cstruct.t -> bool
val get_syn : Cstruct.t -> bool
val get_rst : Cstruct.t -> bool
val get_psh : Cstruct.t -> bool
val get_ack : Cstruct.t -> bool
val get_urg : Cstruct.t -> bool
val set_fin : Cstruct.t -> unit
val set_syn : Cstruct.t -> unit
val set_rst : Cstruct.t -> unit
val set_psh : Cstruct.t -> unit
val set_ack : Cstruct.t -> unit
val set_urg : Cstruct.t -> unit

70
unikernel/duniverse/mirage-tcpip/src/tcp/tcptimer.ml Normal file
View file

@ -0,0 +1,70 @@
(*
* Copyright (c) 2012 Balraj Singh <bs375@cl.cam.ac.uk>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Lwt.Infix
let src = Logs.Src.create "tcp.tcptimer" ~doc:"Mirage TCP Tcptimer module"
module Log = (val Logs.src_log src : Logs.LOG)
type time = int64
type tr =
| Stoptimer
| Continue of Sequence.t
| ContinueSetPeriod of (time * Sequence.t)
type t = {
expire: (Sequence.t -> tr Lwt.t);
mutable period_ns: time;
mutable running: bool;
}
let t ~period_ns ~expire =
let running = false in
{period_ns; expire; running}
let timerloop t s =
Log.debug (fun f -> f "timerloop");
Stats.incr_timer ();
let rec aux t s =
Log.debug (fun f -> f "timerloop: sleeping for %Lu ns" t.period_ns);
Mirage_sleep.ns t.period_ns >>= fun () ->
t.expire s >>= function
| Stoptimer ->
Stats.decr_timer ();
t.running <- false;
Log.debug (fun f -> f "timerloop: stoptimer");
Lwt.return_unit
| Continue d ->
Log.debug (fun f -> f "timerloop: continuer");
aux t d
| ContinueSetPeriod (p, d) ->
Log.debug (fun f -> f "timerloop: continuesetperiod (new period: %Lu ns)" p);
t.period_ns <- p;
aux t d
in
aux t s
let period_ns t = t.period_ns
let start t ?(p=(period_ns t)) s =
if not t.running then begin
t.period_ns <- p;
t.running <- true;
Lwt.async (fun () -> timerloop t s);
Lwt.return_unit
end else
Lwt.return_unit

28
unikernel/duniverse/mirage-tcpip/src/tcp/tcptimer.mli Normal file
View file

@ -0,0 +1,28 @@
(*
* Copyright (c) 2012 Balraj Singh <bs375@cl.cam.ac.uk>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
type t
type time = int64
type tr =
| Stoptimer
| Continue of Sequence.t
| ContinueSetPeriod of (time * Sequence.t)
val t : period_ns: time -> expire: (Sequence.t -> tr Lwt.t) -> t
val start : t -> ?p:time -> Sequence.t -> unit Lwt.t

329
unikernel/duniverse/mirage-tcpip/src/tcp/user_buffer.ml Normal file
View file

@ -0,0 +1,329 @@
(*
* Copyright (c) 2010 http://github.com/barko 00336ea19fcb53de187740c490f764f4
* Copyright (c) 2011 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Lwt.Infix
let lwt_sequence_add_l s seq =
let (_:'a Lwt_dllist.node) = Lwt_dllist.add_l s seq in
()
(* A bounded queue to receive data segments and let readers block on
receiving them. Also supports a monitor that is informed when the
queue size changes *)
module Rx = struct
(* TODO: check that flow control works on the rx side - ie if the application
stops taking data the window closes so the other side stops sending *)
type t = {
q: Cstruct.t option Lwt_dllist.t;
wnd: Window.t;
writers: unit Lwt.u Lwt_dllist.t;
readers: Cstruct.t option Lwt.u Lwt_dllist.t;
mutable watcher: int32 Lwt_mvar.t option;
mutable max_size: int32;
mutable cur_size: int32;
}
let create ~max_size ~wnd =
let q = Lwt_dllist.create () in
let writers = Lwt_dllist.create () in
let readers = Lwt_dllist.create () in
let watcher = None in
let cur_size = 0l in
{ q; wnd; writers; readers; max_size; cur_size; watcher }
let notify_size_watcher t =
let rx_wnd = max 0l (Int32.sub t.max_size t.cur_size) in
Window.set_rx_wnd t.wnd rx_wnd;
match t.watcher with
|None -> Lwt.return_unit
|Some w -> Lwt_mvar.put w t.cur_size
let seglen s =
match s with
| None -> 0
| Some b -> Cstruct.length b
let remove_all t =
let rec rm = function
| 0 -> ()
| n -> ignore (Lwt_dllist.take_l t.q); rm (pred n)
in
rm (Lwt_dllist.length t.q)
let add_r t s =
if t.cur_size > t.max_size then
let th,u = Lwt.wait () in
let node = Lwt_dllist.add_r u t.writers in
Lwt.on_cancel th (fun _ -> Lwt_dllist.remove node);
(* Update size before blocking, which may push cur_size above max_size *)
t.cur_size <- Int32.(add t.cur_size (of_int (seglen s)));
notify_size_watcher t >>= fun () ->
th >>= fun () ->
ignore(Lwt_dllist.add_r s t.q);
Lwt.return_unit
else match Lwt_dllist.take_opt_l t.readers with
| None ->
t.cur_size <- Int32.(add t.cur_size (of_int (seglen s)));
ignore(Lwt_dllist.add_r s t.q);
notify_size_watcher t
| Some u ->
Lwt.return (Lwt.wakeup u s)
let take_l t =
if Lwt_dllist.is_empty t.q then begin
let th,u = Lwt.wait () in
let node = Lwt_dllist.add_r u t.readers in
Lwt.on_cancel th (fun _ -> Lwt_dllist.remove node);
th
end else begin
let s = Lwt_dllist.take_l t.q in
t.cur_size <- Int32.(sub t.cur_size (of_int (seglen s)));
notify_size_watcher t >>= fun () ->
if t.cur_size < t.max_size then begin
match Lwt_dllist.take_opt_l t.writers with
|None -> ()
|Some w -> Lwt.wakeup w ()
end;
Lwt.return s
end
let cur_size t = t.cur_size
let max_size t = t.max_size
let monitor t mvar =
t.watcher <- Some mvar
end
(* The transmit queue simply advertises how much data is allowed to be
written, and a wakener for when it is full. It is up to the application
to decide how to throttle or breakup its data production with this
information.
*)
module Tx = struct
module TXS = Segment.Tx
type t = {
wnd: Window.t;
writers: unit Lwt.u Lwt_dllist.t;
txq: TXS.t;
buffer: Cstruct.t Lwt_dllist.t;
max_size: int32;
mutable bufbytes: int32;
}
let create ~max_size ~wnd ~txq =
let buffer = Lwt_dllist.create () in
let writers = Lwt_dllist.create () in
let bufbytes = 0l in
{ wnd; writers; txq; buffer; max_size; bufbytes }
let len data =
Int32.of_int (Cstruct.length data)
let lenv datav =
match datav with
|[] -> 0l
|[d] -> Int32.of_int (Cstruct.length d)
|ds -> Int32.of_int (List.fold_left (fun a b -> Cstruct.length b + a) 0 ds)
(* Check how many bytes are available to write to output buffer *)
let available t =
let a = Int32.sub t.max_size t.bufbytes in
match a < (Int32.of_int (Window.tx_mss t.wnd)) with
| true -> 0l
| false -> a
(* Check how many bytes are available to write to wire *)
let available_cwnd t =
Window.tx_available t.wnd
(* Wait until at least sz bytes are available in the window *)
let rec wait_for t sz =
if (available t) >= sz then begin
Lwt.return_unit
end
else begin
let th,u = Lwt.wait () in
let node = Lwt_dllist.add_r u t.writers in
Lwt.on_cancel th (fun _ -> Lwt_dllist.remove node);
th >>= fun () ->
wait_for t sz
end
let compactbufs bl = Cstruct.concat bl
(* Wait until the user buffer is flushed *)
let rec wait_for_flushed t =
if Lwt_dllist.is_empty t.buffer then begin
Lwt.return_unit
end
else begin
let th,u = Lwt.wait () in
let node = Lwt_dllist.add_r u t.writers in
Lwt.on_cancel th (fun _ -> Lwt_dllist.remove node);
th >>= fun () ->
wait_for_flushed t
end
let rec clear_buffer t =
let rec addon_more curr_data l =
match Lwt_dllist.take_opt_l t.buffer with
| None -> List.rev curr_data
| Some s ->
let s_len = len s in
match s_len > l with
| true ->
lwt_sequence_add_l s t.buffer;
List.rev curr_data
| false ->
t.bufbytes <- Int32.sub t.bufbytes s_len;
addon_more (s::curr_data) (Int32.sub l s_len)
in
let get_pkt_to_send () =
let avail_len = min (available_cwnd t) (Int32.of_int (Window.tx_mss t.wnd)) in
let s = Lwt_dllist.take_l t.buffer in
let s_len = len s in
match s_len > avail_len with
| true -> begin
match avail_len with
|0l -> (* return pkt to buffer *)
lwt_sequence_add_l s t.buffer;
None
|_ -> (* split buffer into a partial write *)
let to_send,remaining = Cstruct.split s (Int32.to_int avail_len) in
(* queue remaining view *)
lwt_sequence_add_l remaining t.buffer;
t.bufbytes <- Int32.sub t.bufbytes avail_len;
Some [to_send]
end
| false ->
match s_len < avail_len with
| true ->
t.bufbytes <- Int32.sub t.bufbytes s_len;
Some (addon_more (s::[]) (Int32.sub avail_len s_len))
| false ->
t.bufbytes <- Int32.sub t.bufbytes s_len;
Some [s]
in
match Lwt_dllist.is_empty t.buffer with
| true -> Lwt.return_unit
| false ->
match get_pkt_to_send () with
| None -> Lwt.return_unit
| Some pkt ->
let b = compactbufs pkt in
TXS.output ~flags:Segment.Psh t.txq b >>= fun () ->
clear_buffer t
(* Chunk up the segments into MSS max for transmission *)
let transmit_segments ~mss ~txq datav =
let transmit acc =
let b = compactbufs (List.rev acc) in
TXS.output ~flags:Segment.Psh txq b
in
let rec chunk datav acc =
match datav with
|[] -> begin
match acc with
|[] -> Lwt.return_unit
|_ -> transmit acc
end
|hd::tl ->
let curlen = Cstruct.lenv acc in
let tlen = Cstruct.length hd + curlen in
if tlen > mss then begin
let a,b = Cstruct.split hd (mss - curlen) in
transmit (a::acc) >>= fun () ->
chunk (b::tl) []
end else
chunk tl (hd::acc)
in
chunk datav []
let write t datav =
let l = lenv datav in
let mss = Int32.of_int (Window.tx_mss t.wnd) in
match Lwt_dllist.is_empty t.buffer &&
(l = mss || not (Window.tx_inflight t.wnd)) with
| false ->
t.bufbytes <- Int32.add t.bufbytes l;
List.iter (fun data -> ignore(Lwt_dllist.add_r data t.buffer)) datav;
if t.bufbytes < mss then
Lwt.return_unit
else
clear_buffer t
| true ->
let avail_len = available_cwnd t in
match avail_len < l with
| true ->
t.bufbytes <- Int32.add t.bufbytes l;
List.iter (fun data -> ignore(Lwt_dllist.add_r data t.buffer)) datav;
Lwt.return_unit
| false ->
let max_size = Window.tx_mss t.wnd in
transmit_segments ~mss:max_size ~txq:t.txq datav
let write_nodelay t datav =
let l = lenv datav in
match Lwt_dllist.is_empty t.buffer with
| false ->
t.bufbytes <- Int32.add t.bufbytes l;
List.iter (fun data -> ignore(Lwt_dllist.add_r data t.buffer)) datav;
Lwt.return_unit
| true ->
let avail_len = available_cwnd t in
match avail_len < l with
| true ->
t.bufbytes <- Int32.add t.bufbytes l;
List.iter (fun data -> ignore(Lwt_dllist.add_r data t.buffer)) datav;
Lwt.return_unit
| false ->
let max_size = Window.tx_mss t.wnd in
transmit_segments ~mss:max_size ~txq:t.txq datav
let inform_app t =
match Lwt_dllist.take_opt_l t.writers with
| None -> Lwt.return_unit
| Some w ->
Lwt.wakeup w ();
(* TODO: check if this should wake all writers not just one *)
Lwt.return_unit
(* Indicate that more bytes are available for waiting writers.
Note that sz does not take window scaling into account, and so
should be passed as unscaled (i.e. from the wire) here.
Window will internally scale it up. *)
let free t _sz =
clear_buffer t >>= fun () ->
inform_app t
let reset t =
(* FIXME: duplicated code with Segment.reset_seq *)
let rec reset_seq segs =
match Lwt_dllist.take_opt_l segs with
| None -> ()
| Some _ -> reset_seq segs
in
reset_seq t.buffer;
inform_app t
end

48
unikernel/duniverse/mirage-tcpip/src/tcp/user_buffer.mli Normal file
View file

@ -0,0 +1,48 @@
(*
* Copyright (c) 2010 http://github.com/barko 00336ea19fcb53de187740c490f764f4
* Copyright (c) 2011 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
module Rx : sig
type t
val create : max_size:int32 -> wnd:Window.t -> t
val remove_all : t -> unit
val add_r : t -> Cstruct.t option -> unit Lwt.t
val take_l : t -> Cstruct.t option Lwt.t
val cur_size : t -> int32
val max_size : t -> int32
val monitor: t -> int32 Lwt_mvar.t -> unit
end
module Tx : sig
type t
module TXS : sig
type t = Segment.Tx.t
val output : ?flags:Segment.tx_flags -> ?options:Options.t list -> t ->
Cstruct.t -> unit Lwt.t
end
val create: max_size:int32 -> wnd:Window.t -> txq:TXS.t -> t
val available: t -> int32
val wait_for: t -> int32 -> unit Lwt.t
val wait_for_flushed: t -> unit Lwt.t
val write: t -> Cstruct.t list -> unit Lwt.t
val write_nodelay: t -> Cstruct.t list -> unit Lwt.t
val free: t -> int -> unit Lwt.t
val reset: t -> unit Lwt.t
end

257
unikernel/duniverse/mirage-tcpip/src/tcp/window.ml Normal file
View file

@ -0,0 +1,257 @@
(*
* Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
let src = Logs.Src.create "tcp.window" ~doc:"Mirage TCP Window module"
module Log = (val Logs.src_log src : Logs.LOG)
type time = int64
type t = {
tx_mss: int;
tx_isn: Sequence.t;
rx_isn: Sequence.t;
max_rx_wnd: int32; (* Max RX Window size after scaling *)
tx_wnd_scale: int; (* TX Window scaling option *)
rx_wnd_scale: int; (* RX Window scaling option *)
mutable ack_serviced: bool;
mutable ack_seq: Sequence.t;
mutable ack_win: int;
mutable snd_una: Sequence.t;
mutable tx_nxt: Sequence.t;
mutable rx_nxt: Sequence.t;
mutable rx_nxt_inseq: Sequence.t;
mutable fast_rec_th: Sequence.t;
mutable max_tx_wnd : int32; (* Max seen TX window after scaling *)
mutable tx_wnd: int32; (* TX Window size after scaling *)
mutable rx_wnd: int32; (* RX Window size after scaling *)
mutable ssthresh: int32; (* threshold to switch from exponential
slow start to linear congestion
avoidance *)
mutable cwnd: int32; (* congestion window *)
mutable fast_recovery: bool; (* flag to mark if this tcp is in
fast recovery *)
mutable rtt_timer_on: bool;
mutable rtt_timer_reset: bool;
mutable rtt_timer_seq: Sequence.t;
mutable rtt_timer_starttime: time;
mutable srtt: time;
mutable rttvar: time;
mutable rto: int64;
mutable backoff_count: int;
}
(* To string for debugging *)
let pp fmt t =
Format.fprintf fmt
"Window: rx_nxt=%a rx_nxt_inseq=%a tx_nxt=%a rx_wnd=%lu tx_wnd=%lu snd_una=%a backoffs=%d rto=%Lu"
Sequence.pp t.rx_nxt
Sequence.pp t.rx_nxt_inseq
Sequence.pp t.tx_nxt
t.rx_wnd t.tx_wnd
Sequence.pp t.snd_una
t.backoff_count t.rto
(* Initialise the sequence space *)
let t ~rx_wnd_scale ~tx_wnd_scale ~rx_wnd ~tx_wnd ~rx_isn ~tx_mss ~tx_isn =
let tx_nxt = tx_isn in
let rx_nxt = Sequence.succ rx_isn in
let rx_nxt_inseq = Sequence.succ rx_isn in
let snd_una = tx_nxt in
let fast_rec_th = tx_nxt in
let ack_serviced = true in
let ack_seq = tx_nxt in
let ack_win = rx_wnd in
let rx_wnd = Int32.(shift_left (of_int rx_wnd) rx_wnd_scale) in
let max_rx_wnd = rx_wnd in
let tx_wnd = Int32.(shift_left (of_int tx_wnd) tx_wnd_scale) in
let max_tx_wnd = tx_wnd in
(* ssthresh is initialized per RFC 2581 to a large value so slow-start
can be used all the way till first loss *)
let ssthresh = tx_wnd in
let cwnd = Int32.of_int (tx_mss * 2) in
let fast_recovery = false in
let rtt_timer_on = false in
let rtt_timer_reset = true in
let rtt_timer_seq = tx_nxt in
let rtt_timer_starttime = 0L in
let srtt = (Duration.of_ms 667) in
let rttvar = 0L in
let rto = (Duration.of_ms 667) in
let backoff_count = 0 in
{ tx_isn; rx_isn; max_rx_wnd; max_tx_wnd;
ack_serviced; ack_seq; ack_win;
snd_una; tx_nxt; tx_wnd; rx_nxt; rx_nxt_inseq;
fast_rec_th; rx_wnd; tx_wnd_scale; rx_wnd_scale;
ssthresh; cwnd; tx_mss; fast_recovery;
rtt_timer_on; rtt_timer_reset;
rtt_timer_seq; rtt_timer_starttime; srtt; rttvar; rto; backoff_count }
(* Check if a sequence number is in the right range *)
let valid t seq =
let redge = Sequence.(add t.rx_nxt (of_int32 t.rx_wnd)) in
let ledge = Sequence.(sub t.rx_nxt (of_int32 t.max_rx_wnd)) in
let r = Sequence.between seq ledge redge in
Log.debug (fun f -> f "sequence validation: seq=%a range=%a[%lu] res=%b"
Sequence.pp seq Sequence.pp t.rx_nxt t.rx_wnd r);
r
(* Advance received packet sequence number *)
let rx_advance t b =
t.rx_nxt <- Sequence.add t.rx_nxt b
(* Early advance received packet sequence number for packet ordering *)
let rx_advance_inseq t b =
t.rx_nxt_inseq <- Sequence.add t.rx_nxt_inseq b
(* Next expected receive sequence number *)
let rx_nxt t = t.rx_nxt
let rx_nxt_inseq t = t.rx_nxt_inseq
let rx_wnd t = t.rx_wnd
let rx_wnd_unscaled t = Int32.shift_right t.rx_wnd t.rx_wnd_scale
let ack_serviced t = t.ack_serviced
let ack_seq t = t.ack_seq
let ack_win t = t.ack_win
let set_ack_serviced t v = t.ack_serviced <- v
let set_ack_seq_win t s w =
t.ack_seq <- s;
t.ack_win <- w
(* TODO: scale the window down so we can advertise it correctly with
window scaling on the wire *)
let set_rx_wnd t sz =
t.rx_wnd <- max sz (Int32.of_int (3 * t.tx_mss + 1 lsl t.rx_wnd_scale))
(* Take an unscaled value and scale it up *)
let set_tx_wnd t sz =
let wnd = Int32.(shift_left (of_int sz) t.tx_wnd_scale) in
t.tx_wnd <- wnd;
if wnd > t.max_tx_wnd then
t.max_tx_wnd <- wnd
(* transmit MSS of current connection *)
let tx_mss t =
t.tx_mss
(* Advance transmitted packet sequence number *)
let tx_advance t b =
if not t.rtt_timer_on && not t.fast_recovery then begin
t.rtt_timer_on <- true;
t.rtt_timer_seq <- t.tx_nxt;
t.rtt_timer_starttime <- Mirage_mtime.elapsed_ns ();
end;
t.tx_nxt <- Sequence.add t.tx_nxt b
(* An ACK was received - use it to adjust cwnd *)
let tx_ack t r win =
set_tx_wnd t win;
if t.fast_recovery then begin
if Sequence.gt r t.snd_una then
t.snd_una <- r;
if Sequence.geq r t.fast_rec_th then begin
Log.debug (fun f -> f "EXITING fast recovery");
t.cwnd <- t.ssthresh;
t.fast_recovery <- false;
end else begin
t.cwnd <- (Int32.add t.cwnd (Int32.of_int t.tx_mss));
end
end else begin
if Sequence.gt r t.snd_una then begin
t.backoff_count <- 0;
t.snd_una <- r;
if t.rtt_timer_on && Sequence.gt r t.rtt_timer_seq then begin
t.rtt_timer_on <- false;
let rtt_m = Int64.sub (Mirage_mtime.elapsed_ns ()) t.rtt_timer_starttime in
if t.rtt_timer_reset then begin
t.rtt_timer_reset <- false;
t.rttvar <- Int64.div rtt_m 2L;
t.srtt <- rtt_m;
end else begin
let (/) = Int64.div
and ( * ) = Int64.mul
and (-) = Int64.sub
and (+) = Int64.add
in
(* RFC2988 2.3 *)
t.rttvar <- (3L * t.rttvar / 4L) + (Int64.abs (t.srtt - rtt_m) / 4L);
t.srtt <- (7L * t.srtt / 8L) + (rtt_m / 8L)
end;
t.rto <- max (Duration.of_ms 667) Int64.(add t.srtt (mul t.rttvar 4L));
end;
end;
let cwnd_incr = match t.cwnd < t.ssthresh with
| true -> Int32.of_int t.tx_mss
| false -> max (Int32.div (Int32.of_int (t.tx_mss * t.tx_mss)) t.cwnd) 1l
in
t.cwnd <- Int32.add t.cwnd cwnd_incr
end
let tx_nxt t = t.tx_nxt
let tx_wnd t = t.tx_wnd
let tx_wnd_unscaled t = Int32.shift_right t.tx_wnd t.tx_wnd_scale
let max_tx_wnd t = t.max_tx_wnd
let tx_una t = t.snd_una
let fast_rec t = t.fast_recovery
let tx_available t =
let inflight = Sequence.to_int32 (Sequence.sub t.tx_nxt t.snd_una) in
let win = min t.cwnd t.tx_wnd in
let avail_win = Int32.sub win inflight in
match avail_win < Int32.of_int t.tx_mss with
| true -> 0l
| false -> avail_win
let tx_inflight t =
t.tx_nxt <> t.snd_una
let alert_fast_rexmit t _ =
if not t.fast_recovery then begin
let inflight = Sequence.to_int32 (Sequence.sub t.tx_nxt t.snd_una) in
let newssthresh = max (Int32.div inflight 2l) (Int32.of_int (t.tx_mss * 2)) in
let newcwnd = Int32.add inflight (Int32.of_int (t.tx_mss * 2)) in
Log.debug (fun fmt ->
fmt "ENTERING fast recovery inflight=%ld, ssthresh=%ld -> %ld, \
cwnd=%ld -> %ld"
inflight t.ssthresh newssthresh t.cwnd newcwnd);
t.fast_recovery <- true;
t.fast_rec_th <- t.tx_nxt;
t.ssthresh <- newssthresh;
t.rtt_timer_on <- false;
t.cwnd <- newcwnd
end
let rto t =
match t.backoff_count with
| 0 -> t.rto
| _ -> Int64.(mul t.rto (shift_left 2L t.backoff_count))
let backoff_rto t =
t.backoff_count <- t.backoff_count + 1;
t.rtt_timer_on <- false;
t.rtt_timer_reset <- true
let max_rexmits_done t =
(t.backoff_count > 5)
let tx_totalbytes t =
Sequence.(to_int (sub t.tx_nxt t.tx_isn))
let rx_totalbytes t =
(-) Sequence.(to_int (sub t.rx_nxt t.rx_isn)) 1

69
unikernel/duniverse/mirage-tcpip/src/tcp/window.mli Normal file
View file

@ -0,0 +1,69 @@
(*
* Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
type t
val pp: Format.formatter -> t -> unit
val t : rx_wnd_scale:int -> tx_wnd_scale:int -> rx_wnd:int ->
tx_wnd:int -> rx_isn:Sequence.t -> tx_mss:int -> tx_isn:Sequence.t -> t
val valid : t -> Sequence.t -> bool
val rx_advance : t -> Sequence.t -> unit
val rx_advance_inseq : t -> Sequence.t -> unit
val rx_nxt : t -> Sequence.t
val rx_nxt_inseq : t -> Sequence.t
val tx_advance : t -> Sequence.t -> unit
val tx_ack: t -> Sequence.t -> int -> unit
val tx_nxt : t -> Sequence.t
val tx_una : t -> Sequence.t
val tx_mss : t -> int
val fast_rec : t -> bool
val ack_serviced : t -> bool
val ack_seq : t -> Sequence.t
val ack_win : t -> int
val set_ack_serviced : t -> bool -> unit
val set_ack_seq_win : t -> Sequence.t -> int -> unit
(* rx_wnd: number of bytes we are willing to accept *)
val rx_wnd : t -> int32
val rx_wnd_unscaled : t -> int32
val set_rx_wnd : t -> int32 -> unit
(* tx_wnd: number of bytes other side is willing to accept *)
val tx_wnd : t -> int32
val tx_wnd_unscaled : t -> int32
(* tx_available: number of bytes we can currently send after
accounting for congestion *)
val tx_available : t -> int32
(* tx_inflight: is there any data in flight *)
val tx_inflight : t -> bool
val set_tx_wnd : t -> int -> unit
val max_tx_wnd : t -> int32
val alert_fast_rexmit : t -> Sequence.t -> unit
val rto : t -> int64
val backoff_rto : t -> unit
val max_rexmits_done : t -> bool
val tx_totalbytes : t -> int
val rx_totalbytes : t -> int

83
unikernel/duniverse/mirage-tcpip/src/tcp/wire.ml Normal file
View file

@ -0,0 +1,83 @@
(*
* Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Lwt.Infix
let src = Logs.Src.create "tcp.wire" ~doc:"Mirage TCP Wire module"
module Log = (val Logs.src_log src : Logs.LOG)
module Make (Ip : Tcpip.Ip.S) = struct
type error = Tcpip.Ip.error
let pp_error = Tcpip.Ip.pp_error
type t = {
dst_port: int; (* Remote TCP port *)
dst: Ip.ipaddr; (* Remote IP address *)
src_port: int; (* Local TCP port *)
src: Ip.ipaddr; (* Local IP address *)
}
let v ~src ~src_port ~dst ~dst_port = { dst_port ; dst ; src_port ; src }
let src t = t.src
let dst t = t.dst
let src_port t = t.src_port
let dst_port t = t.dst_port
let pp ppf t =
Fmt.pf ppf "remote %a,%d to local %a, %d"
Ip.pp_ipaddr t.dst t.dst_port Ip.pp_ipaddr t.src t.src_port
let xmit ~ip { src_port; dst_port; src; dst } ?(rst=false) ?(syn=false)
?(fin=false) ?(psh=false)
~rx_ack ~seq ~window ~options payload
=
let (ack, ack_number) = match rx_ack with
| None -> (false, Sequence.zero)
| Some n -> (true, n)
in
let header = {
sequence = seq; Tcp_packet.ack_number; window;
urg = false; ack; psh; rst; syn; fin;
options;
src_port; dst_port;
}
in
(* Make a TCP/IP header frame *)
let tcp_size = Tcp_wire.sizeof_tcp + Options.lenv options + Cstruct.length payload in
let fill_buffer buf =
let pseudoheader = Ip.pseudoheader ip ~src dst `TCP tcp_size in
match Tcp_packet.Marshal.into_cstruct header buf ~pseudoheader ~payload with
| Error s ->
Log.err (fun l -> l "Error writing TCP packet header: %s" s) ;
0
(* TODO: better to avoid this entirely, now we're sending empty IP
frame and drop the payload.. oops *)
| Ok l ->
Cstruct.blit payload 0 buf l (Cstruct.length payload) ;
tcp_size
in
Ip.write ip ~fragment:false ~src dst `TCP ~size:tcp_size fill_buffer [] >|= function
| Ok () -> Ok ()
(* swallow errors so normal recovery mechanisms can be used *)
(* For errors which aren't transient, or are too long-lived for TCP to recover
* from, this will eventually result in a higher-level notification
* that communication over the TCP flow has failed *)
| Error e ->
Log.warn (fun l -> l "Error sending TCP packet via IP: %a" Ip.pp_error e);
Ok ()
end

54
unikernel/duniverse/mirage-tcpip/src/tcp/wire.mli Normal file
View file

@ -0,0 +1,54 @@
(*
* Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
module Make (Ip : Tcpip.Ip.S) : sig
type error = Tcpip.Ip.error
(** The type for TCP wire errors. *)
val pp_error: error Fmt.t
(** [pp_error] is the pretty-printer for TCP wire {!error}s. *)
type t
(** The type for TCP wire values. *)
val pp: t Fmt.t
(** [pp] is the pretty-printer for TCP wire values. *)
val dst_port : t -> int
(** Remote TCP port *)
val dst: t -> Ip.ipaddr
(** Remote IP address *)
val src_port : t -> int
(** Local TCP port *)
val src: t -> Ip.ipaddr
(** Local IP address *)
val v: src:Ip.ipaddr -> src_port:int -> dst:Ip.ipaddr -> dst_port:int -> t
(** [v ~src ~src_port ~dst ~dst_port] is the wire value [v] with the
corresponding local and remote IP/TCP parameters. *)
val xmit: ip:Ip.t -> t ->
?rst:bool -> ?syn:bool -> ?fin:bool -> ?psh:bool ->
rx_ack:Sequence.t option -> seq:Sequence.t -> window:int ->
options:Options.t list ->
Cstruct.t -> (unit, error) result Lwt.t
(** [xmit] emits a TCP packet over the network. *)
end

333
unikernel/duniverse/mirage-tcpip/src/tcpip_checksum/checksum_stubs.c Normal file
View file

@ -0,0 +1,333 @@
/*
* Copyright (c) 2010-2011 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*/
#include <stdio.h>
#include <stdint.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/fail.h>
#include <caml/bigarray.h>
#ifdef __x86_64__
/* WARNING: This code assumes that it is running on a little endian machine (x86) */
static inline uint16_t
local_htons(uint16_t v)
{
return (((v & 0xFF) << 8) | ((v & 0xFF00) >> 8));
}
static inline uint16_t
local_ntohs(uint16_t v)
{
return (local_htons(v));
}
static uint16_t
ones_complement_checksum_bigarray(unsigned char *addr, size_t ofs, size_t count, uint64_t sum64)
{
addr += ofs;
uint64_t *data64 = (uint64_t *) addr;
while (count >= 8) {
uint64_t s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
count -= 8;
}
addr = (unsigned char *) data64;
while (count > 1) {
uint16_t v = *((uint16_t *) addr);
sum64 += v;
if (sum64 < v) sum64++;
count -= 2;
addr += 2;
}
if (count > 0) {
uint16_t v = local_ntohs((*addr) << 8);
sum64 += v;
if (sum64 < v) sum64++;
}
while (sum64 >> 16)
sum64 = (sum64 & 0xffff) + (sum64 >> 16);
return local_htons(~sum64);
}
CAMLprim value
mirage_tcpip_ones_complement_checksum(value v_cstruct)
{
CAMLparam1(v_cstruct);
CAMLlocal3(v_ba, v_ofs, v_len);
uint16_t checksum = 0;
v_ba = Field(v_cstruct, 0);
v_ofs = Field(v_cstruct, 1);
v_len = Field(v_cstruct, 2);
checksum = ones_complement_checksum_bigarray(Caml_ba_data_val(v_ba), Int_val(v_ofs), Int_val(v_len), 0);
CAMLreturn(Val_int(checksum));
}
/* Checksum a list of cstruct.ts. The complexity of overflow is due to
* having potentially odd-sized buffers, and the odd byte must be carried
* forward as 16-byte 1s complement addition if there are more buffers in
* the chain. */
CAMLprim value
mirage_tcpip_ones_complement_checksum_list(value v_cstruct_list)
{
CAMLparam1(v_cstruct_list);
CAMLlocal4(v_hd, v_ba, v_ofs, v_len);
uint16_t checksum = 0;
uint16_t overflow_val = 0;
uint16_t overflow = 0;
size_t count = 0;
struct caml_ba_array *a = NULL;
unsigned char *addr;
uint64_t *data64;
uint64_t sum64 = 0;
const size_t sizeof_ll = 8; /* sizeof (uint64_t) */
while (v_cstruct_list != Val_emptylist) {
v_hd = Field(v_cstruct_list, 0);
v_cstruct_list = Field(v_cstruct_list, 1);
v_ba = Field(v_hd, 0);
v_ofs = Field(v_hd, 1);
v_len = Field(v_hd, 2);
a = Caml_ba_array_val(v_ba);
addr = a->data + Int_val(v_ofs);
count = Int_val(v_len);
if (count <= 0) continue;
if (overflow != 0) {
overflow_val = local_ntohs((overflow_val << 8) + (*addr));
sum64 += overflow_val;
if (sum64 < overflow_val) sum64++;
overflow = 0;
addr++;
count--;
}
data64 = (uint64_t *) addr;
#define checksum_DO_PARTIAL_LOOP_UNROLL
#ifdef checksum_DO_PARTIAL_LOOP_UNROLL
while (count >= (20 * sizeof_ll)) {
uint64_t s;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
count -= (20 * sizeof_ll);
}
#endif
while (count >= sizeof_ll) {
uint64_t s = *data64++;
sum64 += s;
if (sum64 < s) sum64++;
count -= sizeof_ll;
}
addr = (unsigned char *) data64;
while (count > 1) {
uint16_t v = *((uint16_t *) addr);
sum64 += v;
if (sum64 < v) sum64++;
count -= 2;
addr += 2;
}
if (count > 0) {
overflow_val = *addr;
overflow = 1;
}
}
if (overflow != 0) {
overflow_val = local_ntohs(overflow_val << 8);
sum64 += overflow_val;
if (sum64 < overflow_val) sum64++;
}
while (sum64 >> 16)
sum64 = (sum64 & 0xffff) + (sum64 >> 16);
checksum = local_htons(~sum64);
CAMLreturn(Val_int(checksum));
}
#else /* Generic implementation */
static uint32_t
checksum_bigarray(unsigned char *addr, size_t ofs, size_t count, uint32_t sum)
{
addr += ofs;
while (count > 1) {
uint16_t v = (*addr << 8) + (*(addr+1));
sum += v;
count -= 2;
addr += 2;
}
if (count > 0)
sum += (*(unsigned char *)addr) << 8;
while (sum >> 16)
sum = (sum & 0xffff) + (sum >> 16);
return sum;
}
CAMLprim value
mirage_tcpip_ones_complement_checksum(value v_cstruct)
{
CAMLparam1(v_cstruct);
CAMLlocal3(v_ba, v_ofs, v_len);
uint32_t sum = 0;
uint16_t checksum = 0;
v_ba = Field(v_cstruct, 0);
v_ofs = Field(v_cstruct, 1);
v_len = Field(v_cstruct, 2);
sum = checksum_bigarray(Caml_ba_data_val(v_ba), Int_val(v_ofs), Int_val(v_len), 0);
checksum = ~sum;
CAMLreturn(Val_int(checksum));
}
/* Checksum a list of cstruct.ts. The complexity of overflow is due to
* having potentially odd-sized buffers, and the odd byte must be carried
* forward as 16-byte 1s complement addition if there are more buffers in
* the chain. */
CAMLprim value
mirage_tcpip_ones_complement_checksum_list(value v_cstruct_list)
{
CAMLparam1(v_cstruct_list);
CAMLlocal4(v_hd, v_ba, v_ofs, v_len);
uint32_t sum = 0;
uint16_t checksum = 0;
uint16_t overflow = 0;
size_t count = 0;
struct caml_ba_array *a = NULL;
unsigned char *addr;
while (v_cstruct_list != Val_emptylist) {
v_hd = Field(v_cstruct_list, 0);
v_cstruct_list = Field(v_cstruct_list, 1);
v_ba = Field(v_hd, 0);
v_ofs = Field(v_hd, 1);
v_len = Field(v_hd, 2);
a = Caml_ba_array_val(v_ba);
addr = (unsigned char *) (a->data) + Int_val(v_ofs);
count = Int_val(v_len);
if (count <= 0) continue;
if (overflow != 0) {
sum += (overflow << 8) + (*addr);
overflow = 0;
addr++;
count--;
}
while (count > 1) {
uint16_t v = (*addr << 8) + (*(addr+1));
sum += v;
count -= 2;
addr += 2;
}
if (count > 0) {
if (v_cstruct_list == Val_emptylist)
sum += (*(unsigned char *)addr) << 8;
else
overflow = *addr;
}
}
if (overflow != 0)
sum += overflow << 8;
while (sum >> 16)
sum = (sum & 0xffff) + (sum >> 16);
checksum = ~sum;
CAMLreturn(Val_int(checksum));
}
#endif

12
unikernel/duniverse/mirage-tcpip/src/tcpip_checksum/dune Normal file
View file

@ -0,0 +1,12 @@
(library
(name tcpip_checksum)
(public_name tcpip.checksum)
(modules tcpip_checksum)
(instrumentation
(backend bisect_ppx))
(libraries cstruct)
(foreign_stubs
(language c)
(names checksum_stubs)
(flags :standard))
(wrapped false))

20
unikernel/duniverse/mirage-tcpip/src/tcpip_checksum/tcpip_checksum.ml Normal file
View file

@ -0,0 +1,20 @@
(*
* Copyright (c) 2010-2011 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(** One's complement checksum, RFC1071 *)
external ones_complement: Cstruct.t -> int = "mirage_tcpip_ones_complement_checksum"
external ones_complement_list: Cstruct.t list -> int = "mirage_tcpip_ones_complement_checksum_list"

22
unikernel/duniverse/mirage-tcpip/src/tcpip_checksum/tcpip_checksum.mli Normal file
View file

@ -0,0 +1,22 @@
(*
* Copyright (c) 2010-2011 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
(** Checksum functions for TCP/IP *)
(** One's complement checksum, RFC1071 *)
val ones_complement: Cstruct.t -> int
val ones_complement_list: Cstruct.t list -> int

7
unikernel/duniverse/mirage-tcpip/src/udp/dune Normal file
View file

@ -0,0 +1,7 @@
(library
(name tcpip_udpv4)
(public_name tcpip.udp)
(instrumentation
(backend bisect_ppx))
(libraries mirage-crypto-rng logs tcpip randomconv tcpip.checksum)
(wrapped false))

101
unikernel/duniverse/mirage-tcpip/src/udp/udp.ml Normal file
View file

@ -0,0 +1,101 @@
(*
* Copyright (c) 2010-2014 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Lwt.Infix
let src = Logs.Src.create "udp" ~doc:"Mirage UDP"
module Log = (val Logs.src_log src : Logs.LOG)
module Make (Ip : Tcpip.Ip.S) = struct
type ipaddr = Ip.ipaddr
type callback = src:ipaddr -> dst:ipaddr -> src_port:int -> Cstruct.t -> unit Lwt.t
type error = [ `Ip of Ip.error ]
let pp_error ppf (`Ip e) = Ip.pp_error ppf e
type t = {
ip : Ip.t;
listeners : (int, callback) Hashtbl.t;
}
let pp_ip = Ip.pp_ipaddr
let listen t ~port callback =
if port < 0 || port > 65535 then
raise (Invalid_argument (Printf.sprintf "invalid port number (%d)" port))
else
Hashtbl.replace t.listeners port callback
let unlisten t ~port = Hashtbl.remove t.listeners port
(* TODO: ought we to check to make sure the destination is relevant
here? Currently we process all incoming packets without making
sure they're either unicast for us or otherwise interesting. *)
let input t ~src ~dst buf =
match Udp_packet.Unmarshal.of_cstruct buf with
| Error s ->
Log.debug (fun f ->
f "Discarding received UDP message: error parsing: %s" s);
Lwt.return_unit
| Ok ({ Udp_packet.src_port; dst_port}, payload) ->
match Hashtbl.find_opt t.listeners dst_port with
| None -> Lwt.return_unit
| Some fn -> fn ~src ~dst ~src_port payload
let writev ?src ?src_port ?ttl ~dst ~dst_port t bufs =
let src_port = match src_port with
| None ->
Randomconv.int ~bound:65535 (fun x -> Mirage_crypto_rng.generate x)
| Some p -> p
in
let fill_hdr buf =
let payload_size = Cstruct.lenv bufs in
let ph =
Ip.pseudoheader t.ip ?src dst `UDP (payload_size + Udp_wire.sizeof_udp)
in
let udp_header = Udp_packet.({ src_port; dst_port; }) in
match Udp_packet.Marshal.into_cstruct udp_header buf ~pseudoheader:ph ~payload:(Cstruct.concat bufs) with
| Ok () -> 8
| Error msg ->
Logs.err (fun m -> m "error while assembling udp header: %s, ignoring" msg);
8
in
Ip.write t.ip ?src dst ?ttl `UDP ~size:8 fill_hdr bufs >|= function
| Ok () -> Ok ()
| Error e ->
Log.err (fun f -> f "IP module couldn't send UDP packet to %a: %a"
pp_ip dst Ip.pp_error e);
(* we're supposed to make our best effort, and we did *)
Ok ()
let write ?src ?src_port ?ttl ~dst ~dst_port t buf =
writev ?src ?src_port ?ttl ~dst ~dst_port t [buf]
let connect ip =
Log.info (fun f -> f "UDP layer connected on %a"
Fmt.(list ~sep:(any ", ") Ip.pp_prefix)
(Ip.configured_ips ip));
let t = { ip ; listeners = Hashtbl.create 7 } in
Lwt.return t
let disconnect t =
Log.info (fun f -> f "UDP layer disconnected on %a"
Fmt.(list ~sep:(any ", ") Ip.pp_prefix)
(Ip.configured_ips t.ip));
Lwt.return_unit
end

20
unikernel/duniverse/mirage-tcpip/src/udp/udp.mli Normal file
View file

@ -0,0 +1,20 @@
(*
* Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
module Make (IP : Tcpip.Ip.S) : sig
include Tcpip.Udp.S with type ipaddr = IP.ipaddr
val connect : IP.t -> t Lwt.t
end

85
unikernel/duniverse/mirage-tcpip/src/udp/udp_packet.ml Normal file
View file

@ -0,0 +1,85 @@
type t = {
src_port : Cstruct.uint16;
dst_port : Cstruct.uint16;
}
let equal {src_port; dst_port} q =
src_port = q.src_port &&
dst_port = q.dst_port
let pp fmt t =
Format.fprintf fmt "UDP port %d -> %d" t.src_port t.dst_port
module Unmarshal = struct
type error = string
let ( let* ) = Result.bind
let of_cstruct buf =
let open Udp_wire in
let check_header_length () =
if Cstruct.length buf < sizeof_udp then Error "UDP header too short" else Ok ()
in
let check_payload_length length_from_header length_of_buffer =
if length_from_header < sizeof_udp then
Error "UDP header claimed a total length < the size of just the header"
else begin
let payload_len = length_from_header - sizeof_udp in
if payload_len > (length_of_buffer - sizeof_udp)
then Error (Printf.sprintf
"UDP header claimed a payload longer than the supplied buffer: %d vs %d."
payload_len length_of_buffer)
else Ok payload_len
end
in
let* () = check_header_length () in
let total_length_from_header = get_length buf in
let* payload_len = check_payload_length total_length_from_header (Cstruct.length buf) in
let src_port = get_src_port buf in
let dst_port = get_dst_port buf in
let payload = Cstruct.sub buf sizeof_udp payload_len in
Ok ({ src_port; dst_port; }, payload)
end
module Marshal = struct
type error = string
let unsafe_fill ~pseudoheader ~payload {src_port; dst_port} udp_buf len =
let open Udp_wire in
let udp_buf = Cstruct.sub udp_buf 0 sizeof_udp in
set_src_port udp_buf src_port;
set_dst_port udp_buf dst_port;
set_length udp_buf len;
set_checksum udp_buf 0;
(* if we've been passed a buffer larger than sizeof_udp, make sure we
* consider only the portion which will actually contain the header
* when calculating this bit of the checksum *)
let csum = Tcpip_checksum.ones_complement_list [ pseudoheader ; udp_buf ; payload ] in
(* Convert zero checksum to the equivalent 0xffff, to prevent it
* seeming like no checksum at all. From RFC768: "If the computed
* checksum is zero, it is transmitted as all ones (the equivalent
* in one's complement arithmetic)." *)
let csum = if csum = 0 then 0xffff else csum in
set_checksum udp_buf csum
let into_cstruct ~pseudoheader ~payload t udp_buf =
let open Udp_wire in
let check_header_len () =
if Cstruct.length udp_buf < sizeof_udp then
Error "Not enough space for a UDP header"
else
Ok ()
in
Result.bind (check_header_len ())
(fun () ->
let len = Cstruct.length payload + sizeof_udp in
let buf = Cstruct.sub udp_buf 0 sizeof_udp in
unsafe_fill ~pseudoheader ~payload t buf len;
Ok ())
let make_cstruct ~pseudoheader ~payload t =
let buf = Cstruct.create Udp_wire.sizeof_udp in
let len = Udp_wire.sizeof_udp + Cstruct.length payload in
unsafe_fill ~pseudoheader ~payload t buf len;
buf
end

40
unikernel/duniverse/mirage-tcpip/src/udp/udp_packet.mli Normal file
View file

@ -0,0 +1,40 @@
type t = {
src_port : Cstruct.uint16;
dst_port : Cstruct.uint16;
}
val pp : Format.formatter -> t -> unit
val equal : t -> t -> bool
module Unmarshal : sig
type error = string
(** [of_cstruct buf] attempts to interpret [buf] as a UDP header. If
successful, it returns [Ok (header, payload)], although [payload] may be an
empty Cstruct.t . *)
val of_cstruct : Cstruct.t -> (t * Cstruct.t, error) result
end
module Marshal : sig
type error = string
(** [into_cstruct ~pseudoheader ~payload t buf] attempts to
assemble a UDP header in [buf] with [t.src_port] and [t.dst_port] set,
along with the correct length and checksum.
It does not write [pseudoheader] or [payload] into the buffer,
but requires them to calculate the correct checksum. *)
val into_cstruct :
pseudoheader:Cstruct.t ->
payload:Cstruct.t ->
t -> Cstruct.t ->
(unit, error) result
(** [make_cstruct ~pseudoheader ~payload t] allocates, fills, and and returns a buffer
representing the UDP header corresponding to [t]. [make_cstruct] will
allocate 8 bytes for the UDP header.
[payload] and [pseudoheader] are not directly represented in the output,
and are required for correct computation of the UDP checksum only.
The checksum will be properly set to reflect the pseudoheader, header, and payload. *)
val make_cstruct : pseudoheader:Cstruct.t -> payload:Cstruct.t -> t -> Cstruct.t
end

18
unikernel/duniverse/mirage-tcpip/src/udp/udp_wire.ml Normal file
View file

@ -0,0 +1,18 @@
let sizeof_udp = 8
let src_port_offset = 0
let dst_port_offset = 2
let length_offset = 4
let checksum_offset = 6
let get_src_port buf = Cstruct.BE.get_uint16 buf src_port_offset
let set_src_port buf v = Cstruct.BE.set_uint16 buf src_port_offset v
let get_dst_port buf = Cstruct.BE.get_uint16 buf dst_port_offset
let set_dst_port buf v = Cstruct.BE.set_uint16 buf dst_port_offset v
let get_length buf = Cstruct.BE.get_uint16 buf length_offset
let set_length buf v = Cstruct.BE.set_uint16 buf length_offset v
let get_checksum buf = Cstruct.BE.get_uint16 buf checksum_offset
let set_checksum buf value = Cstruct.BE.set_uint16 buf checksum_offset value

13
unikernel/duniverse/mirage-tcpip/src/udp/udp_wire.mli Normal file
View file

@ -0,0 +1,13 @@
val sizeof_udp : int
val get_src_port : Cstruct.t -> int
val set_src_port : Cstruct.t -> int -> unit
val get_dst_port : Cstruct.t -> int
val set_dst_port : Cstruct.t -> int -> unit
val get_length : Cstruct.t -> int
val set_length : Cstruct.t -> int -> unit
val get_checksum : Cstruct.t -> int
val set_checksum : Cstruct.t -> int -> unit

Some files were not shown because too many files have changed in this diff Show more