Showing preview only (539K chars total). Download the full file or copy to clipboard to get everything.
Repository: mirage/mirage-tcpip
Branch: main
Commit: c230b14accc3
Files: 126
Total size: 505.8 KB
Directory structure:
gitextract_4op6_m_t/
├── .github/
│ ├── dependabot.yml
│ └── workflows/
│ └── main.yml
├── .gitignore
├── CHANGES.md
├── LICENSE.md
├── Makefile
├── README.md
├── dune-project
├── examples/
│ ├── ping/
│ │ ├── dune
│ │ └── ping.ml
│ └── unikernel/
│ ├── config.ml
│ └── services.ml
├── src/
│ ├── core/
│ │ ├── dune
│ │ ├── ip.ml
│ │ ├── ip.mli
│ │ ├── stack.ml
│ │ ├── tcp.ml
│ │ ├── tcp.mli
│ │ ├── udp.ml
│ │ └── udp.mli
│ ├── icmp/
│ │ ├── dune
│ │ ├── icmpv4.ml
│ │ ├── icmpv4.mli
│ │ ├── icmpv4_packet.ml
│ │ ├── icmpv4_packet.mli
│ │ ├── icmpv4_wire.ml
│ │ └── icmpv4_wire.mli
│ ├── ipv4/
│ │ ├── dune
│ │ ├── fragments.ml
│ │ ├── fragments.mli
│ │ ├── ipv4_packet.ml
│ │ ├── ipv4_packet.mli
│ │ ├── ipv4_wire.ml
│ │ ├── ipv4_wire.mli
│ │ ├── routing.ml
│ │ ├── static_ipv4.ml
│ │ └── static_ipv4.mli
│ ├── ipv6/
│ │ ├── dune
│ │ ├── ipv6.ml
│ │ ├── ipv6.mli
│ │ ├── ipv6_wire.ml
│ │ ├── ndpv6.ml
│ │ └── ndpv6.mli
│ ├── stack-direct/
│ │ ├── dune
│ │ ├── tcpip_stack_direct.ml
│ │ └── tcpip_stack_direct.mli
│ ├── stack-unix/
│ │ ├── dune
│ │ ├── icmpv4_socket.ml
│ │ ├── icmpv4_socket.mli
│ │ ├── ipv4_socket.ml
│ │ ├── ipv4v6_socket.ml
│ │ ├── ipv6_socket.ml
│ │ ├── tcp_socket.ml
│ │ ├── tcp_socket_options.ml
│ │ ├── tcp_socket_options_stubs.c
│ │ ├── tcpip_stack_socket.ml
│ │ ├── tcpip_stack_socket.mli
│ │ ├── tcpv4v6_socket.ml
│ │ ├── tcpv4v6_socket.mli
│ │ └── udpv4v6_socket.ml
│ ├── tcp/
│ │ ├── ack.ml
│ │ ├── ack.mli
│ │ ├── dune
│ │ ├── flow.ml
│ │ ├── flow.mli
│ │ ├── keepalive.ml
│ │ ├── keepalive.mli
│ │ ├── options.ml
│ │ ├── options.mli
│ │ ├── segment.ml
│ │ ├── segment.mli
│ │ ├── sequence.ml
│ │ ├── sequence.mli
│ │ ├── state.ml
│ │ ├── state.mli
│ │ ├── stats.ml
│ │ ├── stats.mli
│ │ ├── tcp_packet.ml
│ │ ├── tcp_packet.mli
│ │ ├── tcp_wire.ml
│ │ ├── tcp_wire.mli
│ │ ├── tcptimer.ml
│ │ ├── tcptimer.mli
│ │ ├── user_buffer.ml
│ │ ├── user_buffer.mli
│ │ ├── window.ml
│ │ ├── window.mli
│ │ ├── wire.ml
│ │ └── wire.mli
│ ├── tcpip_checksum/
│ │ ├── checksum_stubs.c
│ │ ├── dune
│ │ ├── tcpip_checksum.ml
│ │ └── tcpip_checksum.mli
│ └── udp/
│ ├── dune
│ ├── udp.ml
│ ├── udp.mli
│ ├── udp_packet.ml
│ ├── udp_packet.mli
│ ├── udp_wire.ml
│ └── udp_wire.mli
├── tcpip.opam
└── test/
├── common.ml
├── dune
├── low_level.ml
├── mock-clock/
│ ├── dune
│ └── test_tcp_window.ml
├── static_arp.ml
├── test.ml
├── test_checksums.ml
├── test_connect.ml
├── test_connect_ipv6.ml
├── test_deadlock.ml
├── test_icmpv4.ml
├── test_iperf.ml
├── test_iperf_ipv6.ml
├── test_ipv4.ml
├── test_ipv6.ml
├── test_keepalive.ml
├── test_mtus.ml
├── test_rfc5961.ml
├── test_simulatenous_close.ml
├── test_socket.ml
├── test_tcp_options.ml
├── test_udp.ml
├── vnetif_backends.ml
└── vnetif_common.ml
================================================
FILE CONTENTS
================================================
================================================
FILE: .github/dependabot.yml
================================================
version: 2
updates:
- package-ecosystem: github-actions
directory: /
schedule:
interval: weekly
================================================
FILE: .github/workflows/main.yml
================================================
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:
# NOTE: use just "5" when bisect_ppx becomes compatible with ocaml >= 5.4
- 5.3
- 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
================================================
FILE: .gitignore
================================================
_build
.merlin
*.install
================================================
FILE: CHANGES.md
================================================
### 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.
================================================
FILE: LICENSE.md
================================================
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.
================================================
FILE: Makefile
================================================
.PHONY: build clean test
build:
dune build
test:
dune runtest
install:
dune install
uninstall:
dune uninstall
clean:
dune clean
================================================
FILE: README.md
================================================
# 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.
================================================
FILE: dune-project
================================================
(lang dune 2.7)
(name tcpip)
(formatting disabled)
================================================
FILE: examples/ping/dune
================================================
(executables
(names ping)
(libraries cmdliner logs logs.fmt tcpip.icmpv4-socket tcpip))
================================================
FILE: examples/ping/ping.ml
================================================
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)
================================================
FILE: examples/unikernel/config.ml
================================================
(* mirage >= 4.6.0 & < 4.11.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 ]
================================================
FILE: examples/unikernel/services.ml
================================================
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
================================================
FILE: src/core/dune
================================================
(library
(name tcpip)
(public_name tcpip)
(instrumentation
(backend bisect_ppx))
(libraries cstruct lwt fmt ipaddr mirage-flow duration))
================================================
FILE: src/core/ip.ml
================================================
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
================================================
FILE: src/core/ip.mli
================================================
(** {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
================================================
FILE: src/core/stack.ml
================================================
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
================================================
FILE: src/core/tcp.ml
================================================
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
================================================
FILE: src/core/tcp.mli
================================================
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
================================================
FILE: src/core/udp.ml
================================================
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
================================================
FILE: src/core/udp.mli
================================================
(** 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
================================================
FILE: src/icmp/dune
================================================
(library
(name tcpip_icmpv4)
(public_name tcpip.icmpv4)
(instrumentation
(backend bisect_ppx))
(libraries logs tcpip ipaddr tcpip.checksum)
(wrapped false))
================================================
FILE: src/icmp/icmpv4.ml
================================================
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
================================================
FILE: src/icmp/icmpv4.mli
================================================
(** {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
================================================
FILE: src/icmp/icmpv4_packet.ml
================================================
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
================================================
FILE: src/icmp/icmpv4_packet.mli
================================================
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
================================================
FILE: src/icmp/icmpv4_wire.ml
================================================
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
================================================
FILE: src/icmp/icmpv4_wire.mli
================================================
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
================================================
FILE: src/ipv4/dune
================================================
(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))
================================================
FILE: src/ipv4/fragments.ml
================================================
(*
* 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)
================================================
FILE: src/ipv4/fragments.mli
================================================
(*
* 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. *)
================================================
FILE: src/ipv4/ipv4_packet.ml
================================================
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
================================================
FILE: src/ipv4/ipv4_packet.mli
================================================
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
================================================
FILE: src/ipv4/ipv4_wire.ml
================================================
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_tos buf = Cstruct.get_uint8 buf tos_off
let set_tos buf v = Cstruct.set_uint8 buf tos_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)
================================================
FILE: src/ipv4/ipv4_wire.mli
================================================
val sizeof_ipv4 : int
val get_hlen_version : Cstruct.t -> int
val set_hlen_version : Cstruct.t -> int -> unit
val get_tos : Cstruct.t -> int
val set_tos : 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
================================================
FILE: src/ipv4/routing.ml
================================================
(* 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
================================================
FILE: src/ipv4/static_ipv4.ml
================================================
(*
* 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
================================================
FILE: src/ipv4/static_ipv4.mli
================================================
(*
* 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
================================================
FILE: src/ipv6/dune
================================================
(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))
================================================
FILE: src/ipv6/ipv6.ml
================================================
(*
* 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
================================================
FILE: src/ipv6/ipv6.mli
================================================
(*
* 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
================================================
FILE: src/ipv6/ipv6_wire.ml
================================================
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 *)
================================================
FILE: src/ipv6/ndpv6.ml
================================================
(*
* 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.
*)
(*
References:
- Transmission of IPv6 packets over Ethernet networks
http://tools.ietf.org/html/rfc2464
- IPv6 Stateless Address Autoconfiguration
https://tools.ietf.org/html/rfc2462
- Neighbor Discovery for IP Version 6 (IPv6)
https://tools.ietf.org/html/rfc2461
- Internet Control Message Protocol (ICMPv6)
http://tools.ietf.org/html/rfc2463
- IPv6 Node Requirements
http://tools.ietf.org/html/rfc6434
- Multicast Listener Discovery Version 2 (MLDv2) for IPv6
http://tools.ietf.org/html/rfc3810
*)
let src = Logs.Src.create "ndpc6" ~doc:"Mirage IPv6 discovery"
module Log = (val Logs.src_log src : Logs.LOG)
module Ipaddr = Ipaddr.V6
type ipaddr = Ipaddr.t
type prefix = Ipaddr.Prefix.t
type time = int64
module BoundedMap (K : Map.OrderedType) : sig
type 'a t
val empty: int -> 'a t
val push: K.t -> 'a -> 'a t -> 'a t
val pop: K.t -> 'a t -> 'a list * 'a t
end = struct
module M = Map.Make (K)
type 'a t = 'a list M.t * int
let empty n = (M.empty, n)
let push k d (m, n) =
let l = try M.find k m with Not_found -> [] in
match l, List.length l >= n with
| _, false ->
M.add k (l @ [d]) m, n
| _ :: l, true ->
M.add k (d :: l) m, n
| [], true ->
m, n
let pop k (m, n) =
let l = try M.find k m with Not_found -> [] in
l, (M.remove k m, n)
end
module PacketQueue = BoundedMap (Ipaddr)
let solicited_node_prefix =
Ipaddr.(Prefix.make 104 (of_int16 (0xff02, 0, 0, 0, 0, 1, 0xff00, 0)))
module Defaults = struct
let _max_rtr_solicitation_delay = Duration.of_sec 1
let _ptr_solicitation_interval = 4
let _max_rtr_solicitations = 3
let max_multicast_solicit = 3
let max_unicast_solicit = 3
let _max_anycast_delay_time = 1
let _max_neighbor_advertisement = 3
let delay_first_probe_time = Duration.of_sec 5
let link_mtu = 1500 (* RFC 2464, 2. *)
let _min_link_mtu = 1280
let dup_addr_detect_transmits = 1
let min_random_factor = 0.5
let max_random_factor = 1.5
let reachable_time = Duration.of_sec 30
let retrans_timer = Duration.of_sec 1
end
let interface_addr mac =
let bmac = Macaddr.to_octets mac in
let c i = Char.code (String.get bmac i) in
Ipaddr.make
0 0 0 0
((c 0 lxor 2) lsl 8 + c 1)
(c 2 lsl 8 + 0xff)
(0xfe00 + c 3)
(c 4 lsl 8 + c 5)
let link_local_addr mac =
let addr = Ipaddr.(Prefix.network_address Prefix.link (interface_addr mac)) in
Ipaddr.Prefix.(make (bits link) addr)
let multicast_mac =
let pbuf = Cstruct.create 6 in
Cstruct.BE.set_uint16 pbuf 0 0x3333;
fun ip ->
let _, _, _, n = Ipaddr.to_int32 ip in
Cstruct.BE.set_uint32 pbuf 2 n;
Macaddr_cstruct.of_cstruct_exn pbuf
(* vary the reachable time by some random factor between 0.5 and 1.5 *)
let compute_reachable_time reachable_time =
let factor =
Defaults.min_random_factor +.
Randomconv.float ~bound:Defaults.(max_random_factor -. min_random_factor)
Mirage_crypto_rng.generate
in
Int64.of_float (factor *. Int64.to_float reachable_time)
let cksum_buf = Cstruct.create 8
let checksum' ~proto frame bufs =
Cstruct.BE.set_uint32 cksum_buf 0 (Int32.of_int (Cstruct.lenv bufs));
Cstruct.BE.set_uint32 cksum_buf 4 (Int32.of_int proto);
let src_dst = Cstruct.sub frame 8 (2 * 16) in
Tcpip_checksum.ones_complement_list (src_dst :: cksum_buf :: bufs)
let checksum frame bufs =
let proto = Ipv6_wire.get_nhdr frame in
checksum' ~proto frame bufs
module Allocate = struct
let hdr ~hlim ~src ~dst ~proto ~size fillf =
let size' = size + Ipv6_wire.sizeof_ipv6 in
let fill ipbuf =
Ipv6_wire.set_version_flow ipbuf 0x60000000l; (* IPv6 *)
Ipv6_wire.set_len ipbuf size;
Ipv6_wire.set_src ipbuf src;
Ipv6_wire.set_dst ipbuf dst;
Ipv6_wire.set_hlim ipbuf hlim;
Ipv6_wire.set_nhdr ipbuf (Ipv6_wire.protocol_to_int proto);
let hdr, payload = Cstruct.split ipbuf Ipv6_wire.sizeof_ipv6 in
let len' = fillf hdr payload in
len' + Ipv6_wire.sizeof_ipv6
in
(size', fill)
let ns ~specified ~mac ~src ~dst ~tgt =
let size = Ipv6_wire.Ns.sizeof_ns + if specified then Ipv6_wire.Llopt.sizeof_llopt else 0 in
let fillf hdr icmpbuf =
let optbuf = Cstruct.shift icmpbuf Ipv6_wire.Ns.sizeof_ns in
Ipv6_wire.set_ty icmpbuf 135; (* NS *)
Ipv6_wire.set_code icmpbuf 0;
Ipv6_wire.Ns.set_reserved icmpbuf 0l;
Ipv6_wire.Ns.set_target icmpbuf tgt;
if specified then begin
Ipv6_wire.set_ty optbuf 1;
Ipv6_wire.Llopt.set_len optbuf 1;
Ipv6_wire.Llopt.set_addr optbuf mac;
end;
Ipv6_wire.Icmpv6.set_checksum icmpbuf 0;
Ipv6_wire.Icmpv6.set_checksum icmpbuf @@ checksum hdr [ icmpbuf ];
size
in
hdr ~src ~dst ~hlim:255 ~proto:`ICMP ~size fillf
let na ~mac ~src ~dst ~tgt ~sol =
let size = Ipv6_wire.Na.sizeof_na + Ipv6_wire.Llopt.sizeof_llopt in
let fillf hdr icmpbuf =
let optbuf = Cstruct.shift icmpbuf Ipv6_wire.Na.sizeof_na in
Ipv6_wire.set_ty icmpbuf 136; (* NA *)
Ipv6_wire.set_code icmpbuf 0;
Ipv6_wire.Na.set_reserved icmpbuf (if sol then 0x60000000l else 0x20000000l);
Ipv6_wire.Na.set_target icmpbuf tgt;
Ipv6_wire.set_ty optbuf 2;
Ipv6_wire.Llopt.set_len optbuf 1;
Ipv6_wire.Llopt.set_addr optbuf mac;
Ipv6_wire.Icmpv6.set_checksum icmpbuf 0;
Ipv6_wire.Icmpv6.set_checksum icmpbuf @@ checksum hdr [ icmpbuf ];
size
in
hdr ~src ~dst ~hlim:255 ~proto:`ICMP ~size fillf
let rs ~mac select_source =
let dst = Ipaddr.link_routers in
let src = select_source ~dst in
let cmp = Ipaddr.compare in
let include_slla = (cmp src Ipaddr.unspecified) != 0 in
let slla_len = if include_slla then Ipv6_wire.Llopt.sizeof_llopt else 0 in
let size = Ipv6_wire.Rs.sizeof_rs + slla_len in
let fillf hdr icmpbuf =
Ipv6_wire.set_ty icmpbuf 133;
Ipv6_wire.set_code icmpbuf 0;
Ipv6_wire.Rs.set_reserved icmpbuf 0l;
if include_slla then begin
let optbuf = Cstruct.shift icmpbuf Ipv6_wire.Rs.sizeof_rs in
Ipv6_wire.set_ty optbuf 1;
Ipv6_wire.Llopt.set_len optbuf 1;
Ipv6_wire.Llopt.set_addr optbuf mac
end;
Ipv6_wire.Icmpv6.set_checksum icmpbuf 0;
Ipv6_wire.Icmpv6.set_checksum icmpbuf @@ checksum hdr [ icmpbuf ];
size
in
hdr ~src ~dst ~hlim:255 ~proto:`ICMP ~size fillf
let pong ~src ~dst ~hlim ~id ~seq ~data =
(* TODO data may exceed size, fragment? *)
let size = Ipv6_wire.Pingv6.sizeof_pingv6 + Cstruct.length data in
let fillf hdr icmpbuf =
Ipv6_wire.set_ty icmpbuf 129; (* ECHO REPLY *)
Ipv6_wire.set_code icmpbuf 0;
Ipv6_wire.Pingv6.set_id icmpbuf id;
Ipv6_wire.Pingv6.set_seq icmpbuf seq;
Ipv6_wire.Pingv6.set_checksum icmpbuf 0;
Cstruct.blit data 0 icmpbuf Ipv6_wire.Pingv6.sizeof_pingv6 (Cstruct.length data);
Ipv6_wire.Pingv6.set_checksum icmpbuf @@ checksum hdr [ icmpbuf ];
size
in
hdr ~src ~dst ~hlim ~proto:`ICMP ~size fillf
end
type ns =
{ ns_target : Ipaddr.t;
ns_slla : Macaddr.t option }
type pfx =
{ pfx_on_link : bool;
pfx_autonomous : bool;
pfx_valid_lifetime : time option;
pfx_preferred_lifetime : time option;
pfx_prefix : Ipaddr.Prefix.t }
type ra =
{ ra_cur_hop_limit : int;
ra_router_lifetime : time;
ra_reachable_time : time option;
ra_retrans_timer : time option;
ra_slla : Macaddr.t option;
ra_prefix : pfx list }
type na =
{ na_router : bool;
na_solicited : bool;
na_override : bool;
na_target : Ipaddr.t;
na_tlla : Macaddr.t option }
type redirect =
{ target : Ipaddr.t;
destination : Ipaddr.t }
type action =
| SendNS of [`Unspecified | `Specified ] * ipaddr * ipaddr
| SendNA of ipaddr * ipaddr * ipaddr * [`Solicited | `Unsolicited]
| SendRS
| SendQueued of ipaddr * Macaddr.t
| CancelQueued of ipaddr
module AddressList = struct
type state =
| TENTATIVE of (time * time option) option * int * time
| PREFERRED of (time * time option) option
| DEPRECATED of time option
type t =
(Ipaddr.Prefix.t * state) list
let empty =
[]
let to_list al =
let rec loop = function
| [] -> []
| (_, TENTATIVE _) :: rest -> loop rest
| (ip, (PREFERRED _ | DEPRECATED _)) :: rest -> ip :: loop rest
in
loop al
let select_source al ~dst:_ =
let rec loop = function
| (_, TENTATIVE _) :: rest -> loop rest
| (ip, _) :: _ -> Ipaddr.Prefix.address ip (* FIXME *)
| [] -> Ipaddr.unspecified
in
loop al
let tick_one ~now ~retrans_timer = function
| (prefix, TENTATIVE (timeout, n, t)) when t <= now ->
if n + 1 >= Defaults.dup_addr_detect_transmits then
let timeout = match timeout with
| None -> None
| Some (preferred_lifetime, valid_lifetime) ->
Some (Int64.add now preferred_lifetime, valid_lifetime)
in
let ip = Ipaddr.Prefix.address prefix in
Log.debug (fun f -> f "SLAAC: %a --> PREFERRED" Ipaddr.pp ip);
Some (prefix, PREFERRED timeout), []
else
let ip = Ipaddr.Prefix.address prefix in
let dst = Ipaddr.Prefix.network_address solicited_node_prefix ip in
Some (prefix, TENTATIVE (timeout, n+1, Int64.add now retrans_timer)),
[SendNS (`Unspecified, dst, ip)]
| prefix, PREFERRED (Some (preferred_timeout, valid_lifetime)) when preferred_timeout <= now ->
let ip = Ipaddr.Prefix.address prefix in
Log.debug (fun f -> f "SLAAC: %a --> DEPRECATED" Ipaddr.pp ip);
let valid_timeout = match valid_lifetime with
| None -> None
| Some valid_lifetime -> Some (Int64.add now valid_lifetime)
in
Some (prefix, DEPRECATED valid_timeout), []
| prefix, DEPRECATED (Some t) when t <= now ->
let ip = Ipaddr.Prefix.address prefix in
Log.debug (fun f -> f "SLAAC: %a --> EXPIRED" Ipaddr.pp ip);
None, []
| x ->
Some x, []
let tick al ~now ~retrans_timer =
List.fold_right (fun ip (ips, acts) ->
let addr, acts' = tick_one ~now ~retrans_timer ip in
let acts = acts' @ acts in
let ips = match addr with Some ip -> ip :: ips | None -> ips in
ips, acts
) al ([], [])
let _expired al ~now =
List.exists (function
| _, TENTATIVE (_, _, t)
| _, PREFERRED (Some (t, _))
| _, DEPRECATED (Some t) -> t <= now
| _ -> false
) al
let add al ~now ~retrans_timer ~lft ip =
match List.mem_assoc ip al with
| false ->
let al = (ip, TENTATIVE (lft, 0, Int64.add now retrans_timer)) :: al in
let src = Ipaddr.Prefix.address ip in
let dst = Ipaddr.Prefix.network_address solicited_node_prefix src in
al, [SendNS (`Unspecified, dst, src)]
| true ->
Log.warn (fun f -> f "ndpv6: attempted to add ip %a already in address list"
Ipaddr.Prefix.pp ip);
al, []
let is_my_addr al ip =
List.exists (function
| _, TENTATIVE _ -> false
| ip', (PREFERRED _ | DEPRECATED _) -> Ipaddr.(compare (Prefix.address ip') ip) = 0
) al
let find_prefix al pfx =
let rec loop = function
| (ip, _) :: _ when Ipaddr.Prefix.mem (Ipaddr.Prefix.address ip) pfx -> Some ip
| _ :: rest -> loop rest
| [] -> None
in
loop al
let configure al ~now ~retrans_timer ~lft mac pfx =
(* FIXME is this the same as add ? *)
match find_prefix al pfx with
| Some _addr ->
(* TODO handle already configured SLAAC address 5.5.3 e). *)
al, []
| None ->
let ip = Ipaddr.Prefix.network_address pfx (interface_addr mac) in
let prefix = Ipaddr.Prefix.(make (bits pfx) ip) in
add al ~now ~retrans_timer ~lft prefix
let handle_na al ip =
(* FIXME How to notify the client? *)
match List.partition (fun (pre, _) -> Ipaddr.Prefix.mem ip pre) al with
| [ (_, TENTATIVE _) ], rest ->
Log.info (fun f -> f "DAD: Failed: %a" Ipaddr.pp ip);
rest
| _ -> al
end
module PrefixList = struct
type t =
(Ipaddr.Prefix.t * time option) list
let link_local =
[Ipaddr.Prefix.link, None]
let to_list pl =
List.map fst pl
let is_local pl ip =
List.exists (fun (pfx, _) -> Ipaddr.Prefix.mem ip pfx) pl
let tick pl ~now =
List.filter (function (_, Some t) -> t > now | (_, None) -> true) pl
let add pl ~now pfx ~vlft =
let vlft = match vlft with
| None -> None
| Some dt -> Some (Int64.add now dt)
in
match List.mem_assoc pfx pl with
| false ->
(pfx, vlft) :: pl
| true ->
let pl = List.remove_assoc pfx pl in
(pfx, vlft) :: pl
let handle_ra pl ~now ~vlft pfx =
(* RFC 2461, 6.3.4.
For each Prefix Information option with the on-link flag set, a host
does the following:
- If the prefix is the link-local prefix, silently ignore the
Prefix Information option.
- If the prefix is not already present in the Prefix List, and the Prefix
Information option's Valid Lifetime field is non-zero, create a new
entry for the prefix and initialize its invalidation timer to the Valid
Lifetime value in the Prefix Information option.
- If the prefix is already present in the host's Prefix List as the
result of a previously-received advertisement, reset its invalidation
timer to the Valid Lifetime value in the Prefix Information option. If
the new Lifetime value is zero, time-out the prefix immediately (see
Section 6.3.5).
- If the Prefix Information option's Valid Lifetime field is zero, and
the prefix is not present in the host's Prefix List, silently ignore
the option. *)
Log.debug (fun f -> f "ND6: Processing PREFIX option in RA");
if Ipaddr.Prefix.link <> pfx then
match vlft, List.mem_assoc pfx pl with
| Some 0L, true ->
Log.debug (fun f -> f "ND6: Removing PREFIX: pfx=%a" Ipaddr.Prefix.pp pfx);
List.remove_assoc pfx pl, []
| Some 0L, false ->
pl, []
| Some dt, true ->
Log.debug (fun f -> f "ND6: Refreshing PREFIX: pfx=%a lft=%Lu" Ipaddr.Prefix.pp pfx dt);
let pl = List.remove_assoc pfx pl in
(pfx, Some (Int64.add now dt)) :: pl, []
| Some dt, false ->
Log.debug (fun f -> f "ND6: Received new PREFIX: pfx=%a lft=%Lu" Ipaddr.Prefix.pp pfx dt);
(pfx, Some (Int64.add now dt)) :: pl, []
| None, true ->
Log.debug (fun f -> f "ND6: Refreshing PREFIX: pfx=%a lft=inf" Ipaddr.Prefix.pp pfx);
let pl = List.remove_assoc pfx pl in
(pfx, None) :: pl, []
| None, false ->
Log.debug (fun f -> f "ND6: Received new PREFIX: pfx=%a lft=inf" Ipaddr.Prefix.pp pfx);
(pfx, None) :: pl, []
else
pl, []
end
module NeighborCache = struct
type state =
| INCOMPLETE of time * int
| REACHABLE of time * Macaddr.t
| STALE of Macaddr.t
| DELAY of time * Macaddr.t
| PROBE of time * int * Macaddr.t
type info =
{ state : state;
is_router : bool }
module IpMap = Map.Make (Ipaddr)
type t =
info IpMap.t
let empty =
IpMap.empty
let tick_one ~now ~retrans_timer ip nb nc =
match nb.state with
| INCOMPLETE (t, tn) when t <= now ->
if tn < Defaults.max_multicast_solicit then begin
Log.debug (fun f -> f "NUD: %a --> INCOMPLETE [Timeout]" Ipaddr.pp ip);
let dst = Ipaddr.Prefix.network_address solicited_node_prefix ip in
IpMap.add ip {nb with state = INCOMPLETE ((Int64.add now retrans_timer), tn+1)} nc,
[SendNS (`Specified, dst, ip)]
end else begin
Log.debug (fun f -> f "NUD: %a --> UNREACHABLE [Discarding]" Ipaddr.pp ip);
(* TODO Generate ICMP error: Destination Unreachable *)
IpMap.remove ip nc, [CancelQueued ip]
end
| REACHABLE (t, mac) when t <= now ->
Log.debug (fun f -> f "NUD: %a --> STALE" Ipaddr.pp ip);
IpMap.add ip {nb with state = STALE mac} nc, []
| DELAY (t, dmac) when t <= now ->
Log.debug (fun f -> f "NUD: %a --> PROBE" Ipaddr.pp ip);
IpMap.add ip {nb with state = PROBE ((Int64.add now retrans_timer), 0, dmac)} nc,
[SendNS (`Specified, ip, ip)]
| PROBE (t, tn, dmac) when t <= now ->
if tn < Defaults.max_unicast_solicit then begin
Log.debug (fun f -> f "NUD: %a --> PROBE [Timeout]" Ipaddr.pp ip);
IpMap.add ip {nb with state = PROBE ((Int64.add now retrans_timer), tn+1, dmac)} nc,
[SendNS (`Specified, ip, ip)]
end else begin
Log.debug (fun f -> f "NUD: %a --> UNREACHABLE [Discarding]" Ipaddr.pp ip);
IpMap.remove ip nc, []
end
| _ ->
nc, []
let tick nc ~now ~retrans_timer =
IpMap.fold
(fun ip nb (nc, acts) ->
let nc, acts' = tick_one ~now ~retrans_timer ip nb nc in
nc, acts' @ acts) nc (nc, [])
let handle_ns nc ~src new_mac =
let nb =
if IpMap.mem src nc then
IpMap.find src nc
else
{state = STALE new_mac; is_router = false}
in
let nb, acts =
match nb.state with
| INCOMPLETE _ ->
let nb = {nb with state = STALE new_mac} in
nb, [SendQueued (src, new_mac)]
| REACHABLE (_, mac) | STALE mac | DELAY (_, mac) | PROBE (_, _, mac) ->
let nb = if mac <> new_mac then {nb with state = STALE new_mac} else nb in
nb, []
in
IpMap.add src nb nc, acts
let handle_ra nc ~src new_mac =
Log.debug (fun f -> f "ND6: Processing SLLA option in RA");
let nb =
try
let nb = IpMap.find src nc in
{nb with is_router = true}
with
| Not_found ->
{state = STALE new_mac; is_router = true}
in
match nb.state with
| INCOMPLETE _ ->
let nb = {nb with state = STALE new_mac} in
IpMap.add src nb nc, [SendQueued (src, new_mac)]
| REACHABLE (_, mac) | STALE mac | DELAY (_, mac) | PROBE (_, _, mac) ->
let nb = if mac <> new_mac then {nb with state = STALE new_mac} else nb in
IpMap.add src nb nc, []
let handle_na nc ~now ~reachable_time ~rtr ~sol ~ovr ~tgt ~lladdr =
let new_mac = lladdr in
let update nb =
match nb.state, new_mac, sol, ovr with
| INCOMPLETE _, Some new_mac, false, _ ->
Log.debug (fun f -> f "NUD: %a --> STALE" Ipaddr.pp tgt);
let nb = {nb with state = STALE new_mac} in
IpMap.add tgt nb nc, [SendQueued (tgt, new_mac)]
| INCOMPLETE _, Some new_mac, true, _ ->
Log.debug (fun f -> f "NUD: %a --> REACHABLE" Ipaddr.pp tgt);
let nb = {nb with state = REACHABLE ((Int64.add now reachable_time), new_mac)} in
IpMap.add tgt nb nc, [SendQueued (tgt, new_mac)]
| INCOMPLETE _, None, _, _ ->
let nc =
if nb.is_router != rtr then
IpMap.add tgt {nb with is_router = rtr} nc
else
nc
in
nc, []
| PROBE (_, _, mac), Some new_mac, true, false when mac = new_mac ->
Log.debug (fun f -> f "NUD: %a --> REACHABLE" Ipaddr.pp tgt);
let nb = {nb with state = REACHABLE ((Int64.add now reachable_time), new_mac)} in
IpMap.add tgt nb nc, []
| PROBE (_, _, mac), None, true, false ->
Log.debug (fun f -> f "NUD: %a --> REACHABLE" Ipaddr.pp tgt);
let nb = {nb with state = REACHABLE ((Int64.add now reachable_time), mac)} in
IpMap.add tgt nb nc, []
| (REACHABLE _ | STALE _ | DELAY _ | PROBE _), None, _, _ ->
let nc =
if nb.is_router != rtr then
IpMap.add tgt {nb with is_router = rtr} nc
else
nc
in
nc, []
| REACHABLE (_, mac), Some new_mac, true, false when mac <> new_mac ->
Log.debug (fun f -> f "NUD: %a --> STALE" Ipaddr.pp tgt);
let nb = {nb with state = STALE mac} in (* TODO check mac or new_mac *)
IpMap.add tgt nb nc, []
| (REACHABLE _ | STALE _ | DELAY _ | PROBE _), Some new_mac, true, true ->
Log.debug (fun f -> f "NUD: %a --> REACHABLE" Ipaddr.pp tgt);
let nb = {nb with state = REACHABLE ((Int64.add now reachable_time), new_mac)} in
IpMap.add tgt nb nc, []
| (REACHABLE (_, mac) | STALE mac | DELAY (_, mac) | PROBE (_, _, mac)),
Some new_mac, false, true when mac <> new_mac ->
Log.debug (fun f -> f "NUD: %a --> STALE" Ipaddr.pp tgt);
let nb = {nb with state = STALE mac} in
IpMap.add tgt nb nc, []
| _ ->
nc, []
in
try
let nb = IpMap.find tgt nc in
update nb
with
| Not_found ->
nc, []
let query nc ~now ~retrans_timer ip =
try
let nb = IpMap.find ip nc in
match nb.state with
| INCOMPLETE _ ->
nc, None, []
| REACHABLE (_, dmac) | DELAY (_, dmac) | PROBE (_, _, dmac) ->
nc, Some dmac, []
| STALE dmac ->
let dt = Defaults.delay_first_probe_time in
let nc = IpMap.add ip {nb with state = DELAY (Int64.add now dt, dmac)} nc in
nc, Some dmac, []
with
| Not_found ->
let nb = {state = INCOMPLETE (Int64.add now retrans_timer, 0); is_router = false} in
let nc = IpMap.add ip nb nc in
let dst = Ipaddr.Prefix.network_address solicited_node_prefix ip in
nc, None, [SendNS (`Specified, dst, ip)]
let reachable nc ip =
try
let nb = IpMap.find ip nc in
match nb.state with
| INCOMPLETE _ -> false
| _ -> true
with
| Not_found -> false
end
module RouterList = struct
type t =
(Ipaddr.t * time) list
let empty =
[]
let to_list rl =
List.map fst rl
let add rl ~now ?(lifetime = Duration.of_year 1) ip =
(* FIXME *)
(* yomimono 2016-06-30: fix what? *)
(* yomimono 2016-08-17: maybe fix this default lifetime. *)
(ip, Int64.add now lifetime) :: rl
(* FIXME if we are keeping a destination cache, we must remove the stale routers from there as well. *)
let tick rl ~now =
List.filter (fun (_, t) -> t > now) rl
let handle_ra rl ~now ~src ~lft =
match List.mem_assoc src rl with
| true ->
let rl = List.remove_assoc src rl in
if lft > 0L then begin
Log.info (fun f -> f "RA: Refreshing Router: src=%a lft=%Lu" Ipaddr.pp src lft);
(src, Int64.add now lft) :: rl, []
end else begin
Log.info (fun f -> f "RA: Router Expired: src=%a" Ipaddr.pp src);
rl, []
end
| false ->
if lft > 0L then begin
Log.debug (fun f -> f "RA: Adding Router: src=%a" Ipaddr.pp src);
(add rl ~now ~lifetime:lft src), []
end else
rl, []
let add rl ~now:_ ip =
match List.mem_assoc ip rl with
| true -> rl
| false -> (ip, Duration.of_year 1) :: rl
let select rl reachable ip =
let rec loop = function
| [] ->
begin match rl with
| [] -> ip, rl
| (ip, _) as r :: rest ->
ip, rest @ [r]
end
| (ip, _) :: _ when reachable ip -> ip, rl
| _ :: rest -> loop rest
in
loop rl
end
module Parser = struct
type packet =
| Drop
| DropWithError of int * int * int
| NA of Ipaddr.t * Ipaddr.t * na
| NS of Ipaddr.t * Ipaddr.t * ns
| RA of Ipaddr.t * Ipaddr.t * ra
| Ping of Ipaddr.t * Ipaddr.t * int * int * Cstruct.t
| Pong of Cstruct.t
| Udp of Ipaddr.t * Ipaddr.t * Cstruct.t
| Tcp of Ipaddr.t * Ipaddr.t * Cstruct.t
| Default of int * Ipaddr.t * Ipaddr.t * Cstruct.t
type option =
| SLLA of Macaddr.t
| TLLA of Macaddr.t
| MTU of int
| PREFIX of pfx
let rec parse_options1 opts =
if Cstruct.length opts >= Ipv6_wire.Opt.sizeof_opt then
(* TODO check for invalid len == 0 *)
let opt, opts = Cstruct.split opts (Ipv6_wire.Opt.get_len opts * 8) in
match Ipv6_wire.get_ty opt, Ipv6_wire.Opt.get_len opt with
| 1, 1 ->
SLLA (Ipv6_wire.Llopt.get_addr opt) :: parse_options1 opts
| 2, 1 ->
TLLA (Ipv6_wire.Llopt.get_addr opt) :: parse_options1 opts
| 5, 1 ->
MTU (Int32.to_int (Cstruct.BE.get_uint32 opt 4)) :: parse_options1 opts
| 3, 4 ->
let pfx_prefix =
Ipaddr.Prefix.make
(Ipv6_wire.Opt_prefix.get_len opt)
(Ipv6_wire.Opt_prefix.get_prefix opt)
in
let pfx_on_link = Ipv6_wire.Opt_prefix.on_link opt in
let pfx_autonomous = Ipv6_wire.Opt_prefix.autonomous opt in
let pfx_valid_lifetime =
let n = Ipv6_wire.Opt_prefix.get_valid_lifetime opt in
match n with
| 0xffffffffl -> None
| n -> Some (Int64.of_int32 n)
in
let pfx_preferred_lifetime =
let n = Ipv6_wire.Opt_prefix.get_preferred_lifetime opt in
match n with
| 0xffffffffl -> None
| n -> Some (Int64.of_int32 n)
in
let pfx =
{pfx_on_link; pfx_autonomous; pfx_valid_lifetime; pfx_preferred_lifetime; pfx_prefix}
in
PREFIX pfx :: parse_options1 opts
| ty, len ->
Log.info (fun f -> f "ND6: Unsupported ND option in RA: ty=%d len=%d" ty len);
parse_options1 opts
else
[]
let parse_ra buf =
let ra_cur_hop_limit = Ipv6_wire.Ra.get_cur_hop_limit buf in
let ra_router_lifetime =
Int64.of_int (Ipv6_wire.Ra.get_router_lifetime buf)
in
let ra_reachable_time =
let n = Ipv6_wire.Ra.get_reachable_time buf in
if n = 0l then None
else
let dt = Int64.of_int32 @@ Int32.div n 1000l in
Some dt
in
let ra_retrans_timer =
let n = Ipv6_wire.Ra.get_retrans_timer buf in
if n = 0l then None
else
let dt = Int64.of_int32 @@ Int32.div n 1000l in
Some dt
in
let opts = Cstruct.shift buf Ipv6_wire.Ra.sizeof_ra in
let ra_slla, ra_prefix =
let opts = parse_options1 opts in
List.fold_left (fun ra opt ->
match ra, opt with
| (_, pfxs), SLLA slla -> Some slla, pfxs
| (slla, pfxs), PREFIX pfx -> slla, (pfx :: pfxs)
| _ -> ra
) (None, []) opts
in
{ra_cur_hop_limit; ra_router_lifetime; ra_reachable_time; ra_retrans_timer; ra_slla; ra_prefix}
let parse_ns buf =
(* FIXME check code = 0 or drop *)
let ns_target = Ipv6_wire.Ns.get_target buf in
let opts = Cstruct.shift buf Ipv6_wire.Ns.sizeof_ns in
let ns_slla =
let opts = parse_options1 opts in
List.fold_left (fun ns opt ->
match opt with
| SLLA slla -> Some slla
| _ -> ns
) None opts
in
{ns_target; ns_slla}
let parse_na buf =
(* FIXME check code = 0 or drop *)
let na_router = Ipv6_wire.Na.get_router buf in
let na_solicited = Ipv6_wire.Na.get_solicited buf in
let na_override = Ipv6_wire.Na.get_override buf in
let na_target = Ipv6_wire.Na.get_target buf in
let na_tlla =
let opts = Cstruct.shift buf Ipv6_wire.Na.sizeof_na in
let opts = parse_options1 opts in
List.fold_left (fun na opt ->
match opt with
| TLLA tlla -> Some tlla
| _ -> na
) None opts
in
{na_router; na_solicited; na_override; na_target; na_tlla}
let parse_redirect buf =
let destination = Ipv6_wire.Redirect.get_destination buf in
let target = Ipv6_wire.Redirect.get_target buf in
{ target; destination }
let dst_unreachable icmpbuf =
match Ipv6_wire.get_code icmpbuf with
| 0 -> "No route to destination"
| 1 -> "Communication with destination administratively prohibited"
| 2 -> "Beyond scope of source address"
| 3 -> "Address unreachable"
| 4 -> "Port unreachable"
| 5 -> "Source address failed ingress/egress policy"
| 6 -> "Reject route to destination"
| 7 -> "Error in Source Routing Header"
| c -> "Unknown code: " ^ string_of_int c
let time_exceeded icmpbuf =
match Ipv6_wire.get_code icmpbuf with
| 0 -> "Hop limit exceeded in transit"
| 1 -> "Fragment reassembly time exceeded"
| c -> "Unknown code: " ^ string_of_int c
let parameter_problem icmpbuf =
match Ipv6_wire.get_code icmpbuf with
| 0 -> "Erroneous header field encountered"
| 1 -> "Unrecognized Next Header type encountered"
| 2 -> "Unrocognized IPv6 option encountered"
| c -> "Unknown code: " ^ string_of_int c
(* buf : icmp packet with ipv6 header *)
let parse_icmp ~src ~dst buf poff =
let icmpbuf = Cstruct.shift buf poff in
let csum = checksum' ~proto:58 buf [ icmpbuf ] in
if csum != 0 then begin
Log.info (fun f -> f "ICMP6: Checksum error, dropping packet: csum=0x%x" csum);
Drop
end else begin
match Ipv6_wire.get_ty icmpbuf with
| 128 -> (* Echo request *)
let id = Cstruct.BE.get_uint16 icmpbuf 4 in
let seq = Cstruct.BE.get_uint16 icmpbuf 6 in
Ping (src, dst, id, seq, Cstruct.shift icmpbuf 8)
| 129 (* Echo reply *) ->
Pong (Cstruct.shift buf poff)
| 133 (* RS *) ->
(* RFC 4861, 2.6.2 *)
Drop
| 134 (* RA *) ->
if Ipv6_wire.get_hlim buf <> 255 then
Drop
else
RA (src, dst, parse_ra icmpbuf)
| 135 (* NS *) ->
if Ipv6_wire.get_hlim buf <> 255 then
Drop
else
let ns = parse_ns icmpbuf in
if Ipaddr.is_multicast ns.ns_target then
Drop
else
NS (src, dst, ns)
| 136 (* NA *) ->
if Ipv6_wire.get_hlim buf <> 255 then
Drop
else
let na = parse_na icmpbuf in
if Ipaddr.is_multicast na.na_target ||
(na.na_solicited && Ipaddr.is_multicast dst) then
Drop
else
NA (src, dst, na)
| 137 (* Redirect *) ->
if Ipv6_wire.get_hlim buf <> 255 then
Drop
else
let redirect = parse_redirect icmpbuf in
Log.info (fun f -> f "ICMP6 Redirect: %a via %a"
Ipaddr.pp redirect.destination
Ipaddr.pp redirect.target);
Drop
| 1 ->
Log.info (fun f -> f "ICMP6 Destination Unreachable: %s" (dst_unreachable icmpbuf));
Drop
| 2 ->
Log.info (fun f -> f "ICMP6 Packet Too Big");
Drop
| 3 ->
Log.info (fun f -> f "ICMP6 Time Exceeded: %s" (time_exceeded icmpbuf));
Drop
| 4 ->
Log.info (fun f -> f "ICMP6 Parameter Problem: %s" (parameter_problem icmpbuf));
Drop
| n ->
Log.info (fun f -> f "ICMP6: Unknown packet type: ty=%d" n);
Drop
end
let rec parse_extension ~src ~dst buf first hdr (poff : int) =
match hdr with
| 0 (* HOPTOPT *) when first ->
Log.debug (fun f -> f "IP6: Processing HOPOPT header");
parse_options ~src ~dst buf poff
| 0 ->
Drop
| 60 (* IPv6-Opts *) ->
Log.debug (fun f -> f "IP6: Processing DESTOPT header");
parse_options ~src ~dst buf poff
| 43 (* IPv6-Route *)
| 44 (* IPv6-Frag *)
| 50 (* ESP *)
| 51 (* AH *)
| 135 (* Mobility Header *)
| 59 (* NO NEXT HEADER *) ->
Drop
| 58 (* ICMP *) ->
parse_icmp ~src ~dst buf poff
| 17 (* UDP *) ->
Udp (src, dst, Cstruct.shift buf poff)
| 6 (* TCP *) ->
Tcp (src, dst, Cstruct.shift buf poff)
| n when 143 <= n && n <= 255 ->
(* UNASSIGNED, EXPERIMENTAL & RESERVED *)
Drop
| n ->
Default (n, src, dst, Cstruct.shift buf poff)
and parse_options ~src ~dst buf poff =
let pbuf = Cstruct.shift buf poff in
let nhdr = Ipv6_wire.get_ty pbuf in
let olen = Ipv6_wire.Opt.get_len pbuf * 8 + 8 in
let oend = olen + poff in
let rec loop ooff =
if ooff < oend then begin
let obuf = Cstruct.shift buf ooff in
match Ipv6_wire.get_ty obuf with
| 0 ->
Log.debug (fun f -> f "IP6: Processing PAD1 option");
loop (ooff+1)
| 1 ->
Log.debug (fun f -> f "IP6: Processing PADN option");
let len = Ipv6_wire.Opt.get_len obuf in
loop (ooff+len+2)
| _ as n ->
Log.info (fun f -> f "IP6: Processing unknown option, MSB %x" n);
let len = Ipv6_wire.Opt.get_len obuf in
match n land 0xc0 with
| 0x00 ->
loop (ooff+len+2)
| 0x40 ->
(* discard the packet *)
Drop
| 0x80 ->
(* discard, send icmp error *)
DropWithError (4, 2, ooff)
| 0xc0 ->
(* discard, send icmp error if dest is not mcast *)
if Ipaddr.is_multicast dst then
Drop
else
DropWithError (4, 2, ooff)
| _ ->
assert false
end else
parse_extension ~src ~dst buf false nhdr oend
in
loop (poff+2)
let packet is_my_addr buf =
if Cstruct.length buf < Ipv6_wire.sizeof_ipv6 || Cstruct.length buf < Ipv6_wire.sizeof_ipv6 + Ipv6_wire.get_len buf then begin
Log.debug (fun m -> m "short IPv6 packet received, dropping");
Drop
end else if Int32.logand (Ipv6_wire.get_version_flow buf) 0xF0000000l <> 0x60000000l then begin
Log.debug (fun m -> m "version in IPv6 packet not 6");
Drop
end else begin
let buf = Cstruct.sub buf 0 (Ipv6_wire.sizeof_ipv6 + Ipv6_wire.get_len buf) in
let src = Ipv6_wire.get_src buf in
let dst = Ipv6_wire.get_dst buf in
if Ipaddr.Prefix.(mem src multicast) then begin
Log.debug (fun f -> f "IP6: Dropping packet, src is mcast");
Drop
end else
if not (is_my_addr dst || Ipaddr.Prefix.(mem dst multicast)) then begin
Log.debug (fun f -> f "IP6: Dropping packet, not for me");
Drop
end
else
parse_extension ~src ~dst buf true (Ipv6_wire.get_nhdr buf) Ipv6_wire.sizeof_ipv6
end
end
type event =
[ `Tcp of ipaddr * ipaddr * Cstruct.t
| `Udp of ipaddr * ipaddr * Cstruct.t
| `Default of int * ipaddr * ipaddr * Cstruct.t ]
(* TODO add destination cache *)
type context =
{ neighbor_cache : NeighborCache.t;
prefix_list : PrefixList.t;
router_list : RouterList.t;
mac : Macaddr.t;
address_list : AddressList.t;
link_mtu : int;
cur_hop_limit : int;
base_reachable_time : time;
reachable_time : time;
retrans_timer : time;
packet_queue : (int * (Cstruct.t -> int)) PacketQueue.t;
handle_ra : bool }
let next_hop ctx ip =
if PrefixList.is_local ctx.prefix_list ip then
ctx, ip
else
let ip, router_list =
RouterList.select ctx.router_list (NeighborCache.reachable ctx.neighbor_cache) ip
in
{ctx with router_list}, ip
let rec process_actions ~now ctx actions =
let aux ctx = function
| SendNS (unspec, dst, tgt) ->
let src, specified = match unspec with
| `Unspecified -> Ipaddr.unspecified, false
| `Specified -> AddressList.select_source ctx.address_list ~dst, true
in
Log.debug (fun f -> f "ND6: Sending NS src=%a dst=%a tgt=%a"
Ipaddr.pp src Ipaddr.pp dst Ipaddr.pp tgt);
let size, fillf = Allocate.ns ~specified ~mac:ctx.mac ~src ~dst ~tgt in
send' ~now ctx dst size fillf
| SendNA (src, dst, tgt, sol) ->
let sol = match sol with `Solicited -> true | `Unsolicited -> false in
Log.debug (fun f -> f "ND6: Sending NA: src=%a dst=%a tgt=%a sol=%B"
Ipaddr.pp src Ipaddr.pp dst Ipaddr.pp tgt sol);
let size, fillf = Allocate.na ~mac:ctx.mac ~src ~dst ~tgt ~sol in
send' ~now ctx dst size fillf
| SendRS ->
Log.debug (fun f -> f "ND6: Sending RS");
let size, fillf = Allocate.rs ~mac:ctx.mac (AddressList.select_source ctx.address_list) in
let dst = Ipaddr.link_routers in
send' ~now ctx dst size fillf
| SendQueued (ip, dmac) ->
Log.debug (fun f -> f "IP6: Releasing queued packets: dst=%a mac=%a" Ipaddr.pp ip Macaddr.pp dmac);
let outs, packet_queue = PacketQueue.pop ip ctx.packet_queue in
let outs' = List.map (fun (size, fillf) -> dmac, size, fillf) outs in
let ctx = {ctx with packet_queue} in
ctx, outs'
| CancelQueued ip ->
Log.debug (fun f -> f "IP6: Cancelling packets: dst = %a" Ipaddr.pp ip);
let _, packet_queue = PacketQueue.pop ip ctx.packet_queue in
let ctx = {ctx with packet_queue} in
ctx, []
in
List.fold_left (fun (ctx, bufs) action ->
let ctx, bufs' = aux ctx action in
ctx, bufs @ bufs'
) (ctx, []) actions
and send' ~now ctx dst size fillf =
match Ipaddr.is_multicast dst with
| true -> ctx, [(multicast_mac dst, size, fillf)]
| false ->
let ctx, ip = next_hop ctx dst in
let neighbor_cache, mac, actions =
NeighborCache.query ctx.neighbor_cache ~now ~retrans_timer:ctx.retrans_timer ip in
let ctx = {ctx with neighbor_cache} in
match mac with
| Some dmac ->
Log.debug (fun f -> f "IP6: Sending packet: dst=%a mac=%a" Ipaddr.pp dst Macaddr.pp dmac);
let ctx, outs = process_actions ~now ctx actions in
ctx, (dmac, size, fillf) :: outs
| None ->
Log.debug (fun f -> f "IP6: Queueing packet: dst=%a" Ipaddr.pp dst);
let packet_queue = PacketQueue.push ip (size, fillf) ctx.packet_queue in
let ctx = {ctx with packet_queue} in
process_actions ~now ctx actions
let send ~now ctx ?src dst proto size fillf =
let src = match src with None -> AddressList.select_source ctx.address_list ~dst | Some s -> s in
let siz, fill = Allocate.hdr ~hlim:ctx.cur_hop_limit ~src ~dst ~proto ~size fillf in
send' ~now ctx dst siz fill
let local ~handle_ra ~now mac =
let ctx =
{ neighbor_cache = NeighborCache.empty;
prefix_list = PrefixList.link_local;
router_list = RouterList.empty;
mac = mac;
address_list = AddressList.empty;
link_mtu = Defaults.link_mtu;
cur_hop_limit = 64; (* TODO *)
base_reachable_time = Defaults.reachable_time;
reachable_time = compute_reachable_time Defaults.reachable_time;
retrans_timer = Defaults.retrans_timer;
packet_queue = PacketQueue.empty 3;
handle_ra }
in
let ip = link_local_addr mac in
let address_list, actions =
AddressList.add ctx.address_list ~now ~retrans_timer:ctx.retrans_timer ~lft:None ip
in
let ctx, actions = {ctx with address_list}, SendRS :: actions in
process_actions ~now ctx actions
let add_ip ~now ctx ip =
let address_list, actions =
AddressList.add ctx.address_list ~now ~retrans_timer:ctx.retrans_timer ~lft:None ip
in
let ctx = {ctx with address_list} in
process_actions ~now ctx actions
let get_ip ctx =
List.map Ipaddr.Prefix.address (AddressList.to_list ctx.address_list)
let configured_ips ctx =
AddressList.to_list ctx.address_list
let select_source ctx dst =
AddressList.select_source ctx.address_list ~dst
let handle_ra ~now ctx ~src ~dst ra =
Log.debug (fun f -> f "ND: Received RA: src=%a dst=%a" Ipaddr.pp src Ipaddr.pp dst);
let ctx =
if ra.ra_cur_hop_limit <> 0 then
{ctx with cur_hop_limit = ra.ra_cur_hop_limit}
else ctx
in
let ctx = match ra.ra_reachable_time with
| None -> ctx
| Some rt ->
if ctx.base_reachable_time <> rt then
{ctx with base_reachable_time = rt;
reachable_time = compute_reachable_time rt}
else
ctx
in
let ctx = match ra.ra_retrans_timer with
| None -> ctx
| Some rt ->
{ctx with retrans_timer = rt}
in
let ctx, actions =
match ra.ra_slla with
| Some new_mac ->
let neighbor_cache, actions = NeighborCache.handle_ra ctx.neighbor_cache ~src new_mac in
{ctx with neighbor_cache}, actions
| None ->
ctx, []
in
let ctx, actions' =
List.fold_left
(fun (state, _) pfx ->
let vlft = pfx.pfx_valid_lifetime in
let prefix_list, acts = PrefixList.handle_ra state.prefix_list ~now ~vlft pfx.pfx_prefix in
match pfx.pfx_autonomous, vlft with
| _, Some 0L ->
{state with prefix_list}, acts
| true, Some _ ->
let plft = pfx.pfx_preferred_lifetime in
let lft = match plft with
| None -> None
| Some plft -> Some (plft, vlft)
in
let address_list, acts' = (* FIXME *)
AddressList.configure state.address_list ~now ~retrans_timer:state.retrans_timer
~lft state.mac pfx.pfx_prefix
in
{state with address_list; prefix_list}, acts @ acts'
| _ ->
{state with prefix_list}, acts) (ctx, actions) ra.ra_prefix
in
let router_list, actions'' =
RouterList.handle_ra ctx.router_list ~now ~src ~lft:ra.ra_router_lifetime
in
let actions = actions @ actions' @ actions'' in
{ctx with router_list}, actions
let handle_ns ~now:_ ctx ~src ~dst ns =
Log.debug (fun f -> f "ND: Received NS: src=%a dst=%a tgt=%a"
Ipaddr.pp src Ipaddr.pp dst Ipaddr.pp ns.ns_target);
(* TODO check hlim = 255, target not mcast, code = 0 *)
let ctx, actions = match ns.ns_slla with
| Some new_mac ->
let neighbor_cache, actions = NeighborCache.handle_ns ctx.neighbor_cache ~src new_mac in
{ctx with neighbor_cache}, actions
(* handle_ns_slla ~state ~src new_mac *)
| None ->
ctx, []
in
if AddressList.is_my_addr ctx.address_list ns.ns_target then begin
let src = ns.ns_target
and dst, sol =
if Ipaddr.(compare src unspecified = 0) then
Ipaddr.link_nodes, `Unsolicited
else
src, `Solicited
in
(* Log.debug (fun f -> f "Sending NA to %a from %a with target address %a"
Ipaddr.pp dst Ipaddr.pp src Ipaddr.pp ns.ns_target); *)
ctx, SendNA (src, dst, ns.ns_target, sol) :: actions
end else
ctx, actions
let handle_na ~now ctx ~src ~dst na =
Log.debug (fun f -> f "ND: Received NA: src=%a dst=%a tgt=%a"
Ipaddr.pp src Ipaddr.pp dst Ipaddr.pp na.na_target);
(* TODO Handle case when na.target is one of my bound IPs. *)
(* If my_ip is TENTATIVE then fail DAD. *)
let address_list = AddressList.handle_na ctx.address_list na.na_target in
let neighbor_cache, actions =
NeighborCache.handle_na ctx.neighbor_cache
~now ~reachable_time:ctx.reachable_time
~rtr:na.na_router ~sol:na.na_solicited ~ovr:na.na_override ~tgt:na.na_target
~lladdr:na.na_tlla
in
let ctx = {ctx with neighbor_cache; address_list} in
ctx, actions
let handle ~now ctx buf =
let open Parser in
match packet (AddressList.is_my_addr ctx.address_list) buf with
| RA (src, dst, ra) ->
if ctx.handle_ra then
let ctx, actions = handle_ra ~now ctx ~src ~dst ra in
let ctx, bufs = process_actions ~now ctx actions in
ctx, bufs, []
else begin
Log.info (fun m -> m "Ignoring router advertisement (stack is configured to not handle them)");
ctx, [], []
end
| NS (src, dst, ns) ->
let ctx, actions = handle_ns ~now ctx ~src ~dst ns in
let ctx, bufs = process_actions ~now ctx actions in
ctx, bufs, []
| NA (src, dst, na) ->
let ctx, actions = handle_na ~now ctx ~src ~dst na in
let ctx, bufs = process_actions ~now ctx actions in
ctx, bufs, []
| Ping (src, dst, id, seq, data) ->
Log.info (fun f -> f "ICMP6: Received PING: src=%a dst=%a id=%d seq=%d" Ipaddr.pp src
Ipaddr.pp dst id seq);
let dst = src
and src =
if Ipaddr.is_multicast dst then
AddressList.select_source ctx.address_list ~dst
else
dst
in
let frame, bufs =
Allocate.pong ~src ~dst ~hlim:ctx.cur_hop_limit ~id ~seq ~data
in
let ctx, bufs = send' ~now ctx dst frame bufs in
ctx, bufs, []
| DropWithError _ (* TODO *) | Drop ->
ctx, [], []
| Pong _ ->
ctx, [], []
| Tcp (src, dst, buf) ->
ctx, [], [`Tcp (src, dst, buf)]
| Udp (src, dst, buf) ->
ctx, [], [`Udp (src, dst, buf)]
| Default (proto, src, dst, buf) ->
ctx, [], [`Default (proto, src, dst, buf)]
let tick ~now ctx =
let retrans_timer = ctx.retrans_timer in
let address_list, actions = AddressList.tick ctx.address_list ~now ~retrans_timer in
let prefix_list = PrefixList.tick ctx.prefix_list ~now in
let neighbor_cache, actions' = NeighborCache.tick ctx.neighbor_cache ~now ~retrans_timer in
let router_list = RouterList.tick ctx.router_list ~now in
let ctx = {ctx with address_list; prefix_list; neighbor_cache; router_list} in
let actions = actions @ actions' in
process_actions ~now ctx actions
let add_prefix ~now ctx pfx =
let prefix_list = PrefixList.add ctx.prefix_list ~now pfx ~vlft:None in
{ctx with prefix_list}
let get_prefix ctx =
PrefixList.to_list ctx.prefix_list
let add_routers ~now ctx ips =
let router_list = List.fold_left (RouterList.add ~now) ctx.router_list ips in
{ctx with router_list}
let get_routers ctx =
RouterList.to_list ctx.router_list
================================================
FILE: src/ipv6/ndpv6.mli
================================================
(*
* 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]. *)
================================================
FILE: src/stack-direct/dune
================================================
(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))
================================================
FILE: src/stack-direct/tcpip_stack_direct.ml
================================================
(*
* 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
================================================
FILE: src/stack-direct/tcpip_stack_direct.mli
================================================
(*
* 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
================================================
FILE: src/stack-unix/dune
================================================
(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))
================================================
FILE: src/stack-unix/icmpv4_socket.ml
================================================
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 ()
================================================
FILE: src/stack-unix/icmpv4_socket.mli
================================================
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.
*)
================================================
FILE: src/stack-unix/ipv4_socket.ml
================================================
(*
* 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")
================================================
FILE: src/stack-unix/ipv4v6_socket.ml
================================================
(*
* 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")
================================================
FILE: src/stack-unix/ipv6_socket.ml
================================================
(*
* 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")
================================================
FILE: src/stack-unix/tcp_socket.ml
================================================
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
================================================
FILE: src/stack-unix/tcp_socket_options.ml
================================================
(*
* 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 F
gitextract_4op6_m_t/
├── .github/
│ ├── dependabot.yml
│ └── workflows/
│ └── main.yml
├── .gitignore
├── CHANGES.md
├── LICENSE.md
├── Makefile
├── README.md
├── dune-project
├── examples/
│ ├── ping/
│ │ ├── dune
│ │ └── ping.ml
│ └── unikernel/
│ ├── config.ml
│ └── services.ml
├── src/
│ ├── core/
│ │ ├── dune
│ │ ├── ip.ml
│ │ ├── ip.mli
│ │ ├── stack.ml
│ │ ├── tcp.ml
│ │ ├── tcp.mli
│ │ ├── udp.ml
│ │ └── udp.mli
│ ├── icmp/
│ │ ├── dune
│ │ ├── icmpv4.ml
│ │ ├── icmpv4.mli
│ │ ├── icmpv4_packet.ml
│ │ ├── icmpv4_packet.mli
│ │ ├── icmpv4_wire.ml
│ │ └── icmpv4_wire.mli
│ ├── ipv4/
│ │ ├── dune
│ │ ├── fragments.ml
│ │ ├── fragments.mli
│ │ ├── ipv4_packet.ml
│ │ ├── ipv4_packet.mli
│ │ ├── ipv4_wire.ml
│ │ ├── ipv4_wire.mli
│ │ ├── routing.ml
│ │ ├── static_ipv4.ml
│ │ └── static_ipv4.mli
│ ├── ipv6/
│ │ ├── dune
│ │ ├── ipv6.ml
│ │ ├── ipv6.mli
│ │ ├── ipv6_wire.ml
│ │ ├── ndpv6.ml
│ │ └── ndpv6.mli
│ ├── stack-direct/
│ │ ├── dune
│ │ ├── tcpip_stack_direct.ml
│ │ └── tcpip_stack_direct.mli
│ ├── stack-unix/
│ │ ├── dune
│ │ ├── icmpv4_socket.ml
│ │ ├── icmpv4_socket.mli
│ │ ├── ipv4_socket.ml
│ │ ├── ipv4v6_socket.ml
│ │ ├── ipv6_socket.ml
│ │ ├── tcp_socket.ml
│ │ ├── tcp_socket_options.ml
│ │ ├── tcp_socket_options_stubs.c
│ │ ├── tcpip_stack_socket.ml
│ │ ├── tcpip_stack_socket.mli
│ │ ├── tcpv4v6_socket.ml
│ │ ├── tcpv4v6_socket.mli
│ │ └── udpv4v6_socket.ml
│ ├── tcp/
│ │ ├── ack.ml
│ │ ├── ack.mli
│ │ ├── dune
│ │ ├── flow.ml
│ │ ├── flow.mli
│ │ ├── keepalive.ml
│ │ ├── keepalive.mli
│ │ ├── options.ml
│ │ ├── options.mli
│ │ ├── segment.ml
│ │ ├── segment.mli
│ │ ├── sequence.ml
│ │ ├── sequence.mli
│ │ ├── state.ml
│ │ ├── state.mli
│ │ ├── stats.ml
│ │ ├── stats.mli
│ │ ├── tcp_packet.ml
│ │ ├── tcp_packet.mli
│ │ ├── tcp_wire.ml
│ │ ├── tcp_wire.mli
│ │ ├── tcptimer.ml
│ │ ├── tcptimer.mli
│ │ ├── user_buffer.ml
│ │ ├── user_buffer.mli
│ │ ├── window.ml
│ │ ├── window.mli
│ │ ├── wire.ml
│ │ └── wire.mli
│ ├── tcpip_checksum/
│ │ ├── checksum_stubs.c
│ │ ├── dune
│ │ ├── tcpip_checksum.ml
│ │ └── tcpip_checksum.mli
│ └── udp/
│ ├── dune
│ ├── udp.ml
│ ├── udp.mli
│ ├── udp_packet.ml
│ ├── udp_packet.mli
│ ├── udp_wire.ml
│ └── udp_wire.mli
├── tcpip.opam
└── test/
├── common.ml
├── dune
├── low_level.ml
├── mock-clock/
│ ├── dune
│ └── test_tcp_window.ml
├── static_arp.ml
├── test.ml
├── test_checksums.ml
├── test_connect.ml
├── test_connect_ipv6.ml
├── test_deadlock.ml
├── test_icmpv4.ml
├── test_iperf.ml
├── test_iperf_ipv6.ml
├── test_ipv4.ml
├── test_ipv6.ml
├── test_keepalive.ml
├── test_mtus.ml
├── test_rfc5961.ml
├── test_simulatenous_close.ml
├── test_socket.ml
├── test_tcp_options.ml
├── test_udp.ml
├── vnetif_backends.ml
└── vnetif_common.ml
SYMBOL INDEX (9 symbols across 2 files) FILE: src/stack-unix/tcp_socket_options_stubs.c function CAMLprim (line 41) | CAMLprim value FILE: src/tcpip_checksum/checksum_stubs.c function local_htons (line 27) | static inline uint16_t function local_ntohs (line 33) | static inline uint16_t function ones_complement_checksum_bigarray (line 39) | static uint16_t function CAMLprim (line 71) | CAMLprim value function CAMLprim (line 88) | CAMLprim value function checksum_bigarray (line 249) | static uint32_t function CAMLprim (line 266) | CAMLprim value function CAMLprim (line 285) | CAMLprim value
Condensed preview — 126 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (541K chars).
[
{
"path": ".github/dependabot.yml",
"chars": 112,
"preview": "version: 2\nupdates:\n - package-ecosystem: github-actions\n directory: /\n schedule:\n interval: weekly\n"
},
{
"path": ".github/workflows/main.yml",
"chars": 1399,
"preview": "name: Builds, tests & co\n\non:\n pull_request:\n push:\n schedule:\n # Prime the caches every Monday\n - cron: 0 1 * "
},
{
"path": ".gitignore",
"chars": 25,
"preview": "_build\n.merlin\n*.install\n"
},
{
"path": "CHANGES.md",
"chars": 28707,
"preview": "### v9.0.1 (2025-04-15)\n\n* Unix: avoid spurious warnings when the fd is scheduled to be closed (#527\n @hannesm, review "
},
{
"path": "LICENSE.md",
"chars": 1706,
"preview": "Copyright (c) Anil Madhavapeddy <anil@recoil.org>\nCopyright (c) Balraj Singh <balrajsingh@ieee.org>\nCopyright (c) Citrix"
},
{
"path": "Makefile",
"chars": 139,
"preview": "\n.PHONY: build clean test\n\nbuild:\n\tdune build\n\ntest:\n\tdune runtest\n\ninstall:\n\tdune install\n\nuninstall:\n\tdune uninstall\n\n"
},
{
"path": "README.md",
"chars": 1531,
"preview": "# mirage-tcpip - an OCaml TCP/IP networking stack\n\n`mirage-tcpip` provides a networking stack for the [Mirage operating\n"
},
{
"path": "dune-project",
"chars": 51,
"preview": "(lang dune 2.7)\n(name tcpip)\n(formatting disabled)\n"
},
{
"path": "examples/ping/dune",
"chars": 90,
"preview": "(executables\n (names ping)\n (libraries cmdliner logs logs.fmt tcpip.icmpv4-socket tcpip))\n"
},
{
"path": "examples/ping/ping.ml",
"chars": 6967,
"preview": "\nlet src =\n let src = Logs.Src.create \"ping\" ~doc:\"Mirage ping\" in\n Logs.Src.set_level src (Some Logs.Info);\n src\n\nmo"
},
{
"path": "examples/unikernel/config.ml",
"chars": 259,
"preview": "(* mirage >= 4.6.0 & < 4.11.0 *)\n\nopen Mirage\n\nlet main =\n let packages = [ package ~min:\"2.9.0\" \"ipaddr\" ] in\n main ~"
},
{
"path": "examples/unikernel/services.ml",
"chars": 1917,
"preview": "open Lwt.Infix\n\nmodule Main (S: Tcpip.Stack.V4V6) = struct\n let report_and_close flow pp e message =\n let ip, port ="
},
{
"path": "src/core/dune",
"chars": 144,
"preview": "(library\n (name tcpip)\n (public_name tcpip)\n (instrumentation\n (backend bisect_ppx))\n (libraries cstruct lwt fmt ipaddr"
},
{
"path": "src/core/ip.ml",
"chars": 1318,
"preview": "type error = [\n | `No_route of string (** can't send a message to that destination *)\n | `Would_fragment\n]\nlet pp_erro"
},
{
"path": "src/core/ip.mli",
"chars": 3984,
"preview": "(** {2 IP layer} *)\n\n(** IP errors and protocols. *)\ntype error = [\n | `No_route of string (** can't send a message to "
},
{
"path": "src/core/stack.ml",
"chars": 1157,
"preview": "module type V4V6 = sig\n type t\n (** The type representing the internal state of the dual IPv4 and IPv6 stack. *)\n\n va"
},
{
"path": "src/core/tcp.ml",
"chars": 1339,
"preview": "type error = [ `Timeout | `Refused]\ntype write_error = [ error | Mirage_flow.write_error]\n\nlet pp_error ppf = function\n "
},
{
"path": "src/core/tcp.mli",
"chars": 4044,
"preview": "type error = [ `Timeout | `Refused]\ntype write_error = [ error | Mirage_flow.write_error ]\n\nval pp_error : error Fmt.t\nv"
},
{
"path": "src/core/udp.ml",
"chars": 503,
"preview": "module type S = sig\n type error\n val pp_error: error Fmt.t\n type ipaddr\n type t\n val disconnect : t -> unit Lwt.t\n "
},
{
"path": "src/core/udp.mli",
"chars": 1745,
"preview": "(** User datagram protocol layer: connectionless message-oriented\n communication. *)\nmodule type S = sig\n\n type erro"
},
{
"path": "src/icmp/dune",
"chars": 164,
"preview": "(library\n (name tcpip_icmpv4)\n (public_name tcpip.icmpv4)\n (instrumentation\n (backend bisect_ppx))\n (libraries logs tcp"
},
{
"path": "src/icmp/icmpv4.ml",
"chars": 2546,
"preview": "module type S = sig\n type t\n val disconnect : t -> unit Lwt.t\n type ipaddr = Ipaddr.V4.t\n type error\n val pp_error:"
},
{
"path": "src/icmp/icmpv4.mli",
"chars": 1162,
"preview": "(** {2 ICMP layer} *)\n\n(** Internet Control Message Protocol: error messages and operational\n information. *)\nmodule "
},
{
"path": "src/icmp/icmpv4_packet.ml",
"chars": 3560,
"preview": "open Icmpv4_wire\n\n(* second 4 bytes of the message have varying interpretations *)\ntype subheader =\n | Id_and_seq of Cs"
},
{
"path": "src/icmp/icmpv4_packet.mli",
"chars": 1288,
"preview": "type subheader =\n | Id_and_seq of Cstruct.uint16 * Cstruct.uint16\n | Next_hop_mtu of Cstruct.uint16\n | Pointer of Cst"
},
{
"path": "src/icmp/icmpv4_wire.ml",
"chars": 2809,
"preview": "type ty =\n | Echo_reply\n | Destination_unreachable\n | Source_quench\n | Redirect\n | Echo_request\n | Time_exceeded\n "
},
{
"path": "src/icmp/icmpv4_wire.mli",
"chars": 1078,
"preview": "type ty =\n | Echo_reply\n | Destination_unreachable\n | Source_quench\n | Redirect\n | Echo_request\n | Time_exceeded\n "
},
{
"path": "src/ipv4/dune",
"chars": 247,
"preview": "(library\n (name tcpip_ipv4)\n (public_name tcpip.ipv4)\n (instrumentation\n (backend bisect_ppx))\n (libraries logs ipaddr "
},
{
"path": "src/ipv4/fragments.ml",
"chars": 9428,
"preview": "(*\n * Copyright (c) 2018 Hannes Mehnert <hannes@mehnert.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/ipv4/fragments.mli",
"chars": 4927,
"preview": "(*\n * Copyright (c) 2018 Hannes Mehnert <hannes@mehnert.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/ipv4/ipv4_packet.ml",
"chars": 6047,
"preview": "type t = {\n src : Ipaddr.V4.t;\n dst : Ipaddr.V4.t;\n id : Cstruct.uint16;\n off : Cstruct.uint16;\n t"
},
{
"path": "src/ipv4/ipv4_packet.mli",
"chars": 1964,
"preview": "type t = {\n src : Ipaddr.V4.t;\n dst : Ipaddr.V4.t;\n id : Cstruct.uint16;\n off : Cstruct.uint16;\n t"
},
{
"path": "src/ipv4/ipv4_wire.ml",
"chars": 1398,
"preview": "let sizeof_ipv4 = 20\n\nlet hlen_version_off = 0\nlet tos_off = 1\nlet len_off = 2\nlet id_off = 4\nlet off_off = 6\nlet ttl_of"
},
{
"path": "src/ipv4/ipv4_wire.mli",
"chars": 794,
"preview": "val sizeof_ipv4 : int\n\nval get_hlen_version : Cstruct.t -> int\nval set_hlen_version : Cstruct.t -> int -> unit\n\nval get_"
},
{
"path": "src/ipv4/routing.ml",
"chars": 2101,
"preview": "(* RFC 1112: 01-00-5E-00-00-00 ORed with lower 23 bits of the ip address *)\nlet mac_of_multicast ip =\n let ipb = Ipaddr"
},
{
"path": "src/ipv4/static_ipv4.ml",
"chars": 7775,
"preview": "(*\n * Copyright (c) 2010-2011 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute "
},
{
"path": "src/ipv4/static_ipv4.mli",
"chars": 1357,
"preview": "(*\n * Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/ipv6/dune",
"chars": 289,
"preview": "(library\n (name tcpip_ipv6)\n (public_name tcpip.ipv6)\n (instrumentation\n (backend bisect_ppx))\n (libraries logs mirage-"
},
{
"path": "src/ipv6/ipv6.ml",
"chars": 6218,
"preview": "(*\n * Copyright (c) 2014 Nicolas Ojeda Bar <n.oje.bar@gmail.com>\n *\n * Permission to use, copy, modify, and distribute t"
},
{
"path": "src/ipv6/ipv6.mli",
"chars": 1106,
"preview": "(*\n * Copyright (c) 2014 Nicolas Ojeda Bar <n.oje.bar@gmail.com>\n *\n * Permission to use, copy, modify, and distribute t"
},
{
"path": "src/ipv6/ipv6_wire.ml",
"chars": 5489,
"preview": "let sizeof_ipv6 = 40\n\nlet int_to_protocol = function\n | 58 -> Some `ICMP\n | 6 -> Some `TCP\n | 17 -> Some `UDP\n | _"
},
{
"path": "src/ipv6/ndpv6.ml",
"chars": 45881,
"preview": "(*\n * Copyright (c) 2015 Nicolas Ojeda Bar <n.oje.bar@gmail.com>\n *\n * Permission to use, copy, modify, and distribute t"
},
{
"path": "src/ipv6/ndpv6.mli",
"chars": 3743,
"preview": "(*\n * Copyright (c) 2015 Nicolas Ojeda Bar <n.oje.bar@gmail.com>\n *\n * Permission to use, copy, modify, and distribute t"
},
{
"path": "src/stack-direct/dune",
"chars": 244,
"preview": "(library\n (name tcpip_stack_direct)\n (public_name tcpip.stack-direct)\n (instrumentation\n (backend bisect_ppx))\n (librar"
},
{
"path": "src/stack-direct/tcpip_stack_direct.ml",
"chars": 8528,
"preview": "(*\n * Copyright (c) 2011-2014 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute "
},
{
"path": "src/stack-direct/tcpip_stack_direct.mli",
"chars": 2424,
"preview": "(*\n * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/stack-unix/dune",
"chars": 1292,
"preview": "(library\n (name icmpv4_socket)\n (public_name tcpip.icmpv4-socket)\n (modules icmpv4_socket)\n (wrapped false)\n (instrument"
},
{
"path": "src/stack-unix/icmpv4_socket.ml",
"chars": 4290,
"preview": "open Lwt.Infix\n\ntype ipaddr = Ipaddr.V4.t\n\ntype t = {\n mutable listening_sockets : Lwt_unix.file_descr list\n}\n\ntype err"
},
{
"path": "src/stack-unix/icmpv4_socket.mli",
"chars": 483,
"preview": "include Icmpv4.S\n\nval connect : unit -> t Lwt.t\n\nval listen : t -> ipaddr -> (Cstruct.t -> unit Lwt.t) -> unit Lwt.t\n(**"
},
{
"path": "src/stack-unix/ipv4_socket.ml",
"chars": 1535,
"preview": "(*\n * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/stack-unix/ipv4v6_socket.ml",
"chars": 1632,
"preview": "(*\n * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/stack-unix/ipv6_socket.ml",
"chars": 1621,
"preview": "(*\n * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>\n * Copyright (c) 2014 Nicolas Ojeda Bar <n.oje.bar@gmail.co"
},
{
"path": "src/stack-unix/tcp_socket.ml",
"chars": 1971,
"preview": "open Lwt\n\ntype error = [ Tcpip.Tcp.error | `Exn of exn ]\ntype write_error = [ Tcpip.Tcp.write_error | `Exn of exn ]\n\nlet"
},
{
"path": "src/stack-unix/tcp_socket_options.ml",
"chars": 1167,
"preview": "(*\n * Copyright (c) 2017 Docker Inc\n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpo"
},
{
"path": "src/stack-unix/tcp_socket_options_stubs.c",
"chars": 3020,
"preview": "/*\n * Copyright (c) 2017 Docker Inc\n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpo"
},
{
"path": "src/stack-unix/tcpip_stack_socket.ml",
"chars": 1672,
"preview": "(*\n * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/stack-unix/tcpip_stack_socket.mli",
"chars": 1018,
"preview": "(*\n * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/stack-unix/tcpv4v6_socket.ml",
"chars": 8026,
"preview": "(*\n * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>\n * Copyright (c) 2014 Nicolas Ojeda Bar <n.oje.bar@gmail.co"
},
{
"path": "src/stack-unix/tcpv4v6_socket.mli",
"chars": 1224,
"preview": "(*\n * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>\n * Copyright (c) 2014 Nicolas Ojeda Bar <n.oje.bar@gmail.co"
},
{
"path": "src/stack-unix/udpv4v6_socket.ml",
"chars": 8977,
"preview": "(*\n * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>\n * Copyright (c) 2014 Nicolas Ojeda Bar <n.oje.bar@gmail.co"
},
{
"path": "src/tcp/ack.ml",
"chars": 3552,
"preview": "(*\n * Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/tcp/ack.mli",
"chars": 1075,
"preview": "(*\n * Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/tcp/dune",
"chars": 248,
"preview": "(library\n (name tcp)\n (public_name tcpip.tcp)\n (instrumentation\n (backend bisect_ppx))\n (libraries logs ipaddr cstruct "
},
{
"path": "src/tcp/flow.ml",
"chars": 30317,
"preview": "(*\n * Copyright (c) 2010-2012 Anil Madhavapeddy <anil@recoil.org>\n * Copyright (c) 2012 Balraj Singh <bs375@cl.cam.ac.uk"
},
{
"path": "src/tcp/flow.mli",
"chars": 1017,
"preview": "(*\n * Copyright (c) 2011-2014 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute "
},
{
"path": "src/tcp/keepalive.ml",
"chars": 2736,
"preview": "(*\n * Copyright (c) 2017 Docker Inc\n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpo"
},
{
"path": "src/tcp/keepalive.mli",
"chars": 2345,
"preview": "(*\n * Copyright (c) 2017 Docker Inc\n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpo"
},
{
"path": "src/tcp/options.ml",
"chars": 6971,
"preview": "(*\n * Copyright (c) 2011 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/tcp/options.mli",
"chars": 1436,
"preview": "(*\n * Copyright (c) 2011 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/tcp/segment.ml",
"chars": 16889,
"preview": "(*\n * Copyright (c) 2010-2011 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute "
},
{
"path": "src/tcp/segment.mli",
"chars": 2748,
"preview": "(*\n * Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/tcp/sequence.ml",
"chars": 1556,
"preview": "(*\n * Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/tcp/sequence.mli",
"chars": 1345,
"preview": "(*\n * Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/tcp/state.ml",
"chars": 5936,
"preview": "(*\n * Copyright (c) 2012 Balraj Singh <bs375@cl.cam.ac.uk>\n *\n * Permission to use, copy, modify, and distribute this so"
},
{
"path": "src/tcp/state.mli",
"chars": 1761,
"preview": "(*\n * Copyright (c) 2012 Balraj Singh <bs375@cl.cam.ac.uk>\n *\n * Permission to use, copy, modify, and distribute this so"
},
{
"path": "src/tcp/stats.ml",
"chars": 3488,
"preview": "(*\n * Copyright (c) 2015 Thomas Gazagnaire <thomas@gazagnaire.org>\n *\n * Permission to use, copy, modify, and distribute"
},
{
"path": "src/tcp/stats.mli",
"chars": 1840,
"preview": "(*\n * Copyright (c) 2015 Thomas Gazagnaire <thomas@gazagnaire.org>\n *\n * Permission to use, copy, modify, and distribute"
},
{
"path": "src/tcp/tcp_packet.ml",
"chars": 5227,
"preview": "type t = {\n urg : bool;\n ack : bool;\n psh : bool;\n rst : bool;\n syn : bool;\n fin : bool;\n window : Cstruct.uint16"
},
{
"path": "src/tcp/tcp_packet.mli",
"chars": 1740,
"preview": "type t = {\n urg : bool;\n ack : bool;\n psh : bool;\n rst : bool;\n syn : bool;\n fin : bool;\n window : Cstruct.uint16"
},
{
"path": "src/tcp/tcp_wire.ml",
"chars": 2896,
"preview": "let sizeof_tcp = 20\n\nlet src_port_off = 0\nlet dst_port_off = 2\nlet sequence_off = 4\nlet ack_off = 8\nlet dataoff_off = 12"
},
{
"path": "src/tcp/tcp_wire.mli",
"chars": 1142,
"preview": "val sizeof_tcp : int\n\nval get_src_port : Cstruct.t -> int\nval set_src_port : Cstruct.t -> int -> unit\n\nval get_dst_port "
},
{
"path": "src/tcp/tcptimer.ml",
"chars": 2121,
"preview": "(*\n * Copyright (c) 2012 Balraj Singh <bs375@cl.cam.ac.uk>\n *\n * Permission to use, copy, modify, and distribute this so"
},
{
"path": "src/tcp/tcptimer.mli",
"chars": 1036,
"preview": "(*\n * Copyright (c) 2012 Balraj Singh <bs375@cl.cam.ac.uk>\n *\n * Permission to use, copy, modify, and distribute this so"
},
{
"path": "src/tcp/user_buffer.ml",
"chars": 10398,
"preview": "(*\n * Copyright (c) 2010 http://github.com/barko 00336ea19fcb53de187740c490f764f4\n * Copyright (c) 2011 Anil Madhavapedd"
},
{
"path": "src/tcp/user_buffer.mli",
"chars": 1706,
"preview": "(*\n * Copyright (c) 2010 http://github.com/barko 00336ea19fcb53de187740c490f764f4\n * Copyright (c) 2011 Anil Madhavapedd"
},
{
"path": "src/tcp/window.ml",
"chars": 8864,
"preview": "(*\n * Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/tcp/window.mli",
"chars": 2271,
"preview": "(*\n * Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/tcp/wire.ml",
"chars": 3167,
"preview": "(*\n * Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/tcp/wire.mli",
"chars": 1820,
"preview": "(*\n * Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/tcpip_checksum/checksum_stubs.c",
"chars": 8086,
"preview": "/*\n * Copyright (c) 2010-2011 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute "
},
{
"path": "src/tcpip_checksum/dune",
"chars": 246,
"preview": "(library\n (name tcpip_checksum)\n (public_name tcpip.checksum)\n (modules tcpip_checksum)\n (instrumentation\n (backend bis"
},
{
"path": "src/tcpip_checksum/tcpip_checksum.ml",
"chars": 1028,
"preview": "(*\n * Copyright (c) 2010-2011 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute "
},
{
"path": "src/tcpip_checksum/tcpip_checksum.mli",
"chars": 967,
"preview": "(*\n * Copyright (c) 2010-2011 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute "
},
{
"path": "src/udp/dune",
"chars": 182,
"preview": "(library\n (name tcpip_udpv4)\n (public_name tcpip.udp)\n (instrumentation\n (backend bisect_ppx))\n (libraries mirage-crypt"
},
{
"path": "src/udp/udp.ml",
"chars": 3702,
"preview": "(*\n * Copyright (c) 2010-2014 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute "
},
{
"path": "src/udp/udp.mli",
"chars": 918,
"preview": "(*\n * Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>\n *\n * Permission to use, copy, modify, and distribute this "
},
{
"path": "src/udp/udp_packet.ml",
"chars": 3053,
"preview": "type t = {\n src_port : Cstruct.uint16;\n dst_port : Cstruct.uint16;\n}\n\nlet equal {src_port; dst_port} q =\n src_port = "
},
{
"path": "src/udp/udp_packet.mli",
"chars": 1464,
"preview": "type t = {\n src_port : Cstruct.uint16;\n dst_port : Cstruct.uint16;\n}\n\nval pp : Format.formatter -> t -> unit\nval equal"
},
{
"path": "src/udp/udp_wire.ml",
"chars": 654,
"preview": "let sizeof_udp = 8\n\nlet src_port_offset = 0\nlet dst_port_offset = 2\nlet length_offset = 4\nlet checksum_offset = 6\n\nlet g"
},
{
"path": "src/udp/udp_wire.mli",
"chars": 341,
"preview": "val sizeof_udp : int\n\nval get_src_port : Cstruct.t -> int\nval set_src_port : Cstruct.t -> int -> unit\n\nval get_dst_port "
},
{
"path": "tcpip.opam",
"chars": 1967,
"preview": "opam-version: \"2.0\"\nmaintainer: \"anil@recoil.org\"\nhomepage: \"https://github.com/mirage/mirage-tcpip\"\ndev-repo: "
},
{
"path": "test/common.ml",
"chars": 819,
"preview": "open Lwt.Infix\n\nlet failf fmt = Fmt.kstr (fun s -> Alcotest.fail s) fmt\n\nlet ( let* ) = Result.bind\n\nlet or_error name f"
},
{
"path": "test/dune",
"chars": 444,
"preview": "(test\n (name test)\n (libraries alcotest mirage-crypto-rng mirage-crypto-rng.unix lwt.unix logs logs.fmt\n mirage-flow m"
},
{
"path": "test/low_level.ml",
"chars": 4942,
"preview": "open Lwt.Infix\n\n(*\n * Connects two stacks to the same backend.\n * One is a complete v4 stack (the system under test, ref"
},
{
"path": "test/mock-clock/dune",
"chars": 195,
"preview": "(test\n (name test_tcp_window)\n (libraries alcotest mirage-crypto-rng mirage-crypto-rng.unix lwt.unix logs logs.fmt\n mi"
},
{
"path": "test/mock-clock/test_tcp_window.ml",
"chars": 5633,
"preview": "let default_window () =\n Tcp.Window.t ~tx_wnd_scale:2 ~rx_wnd_scale:2 ~rx_wnd:65535 ~tx_wnd:65535 ~rx_isn:Tcp.Sequence."
},
{
"path": "test/static_arp.ml",
"chars": 1306,
"preview": "open Lwt.Infix\n\nmodule Make(E : Ethernet.S) = struct\n module A = Arp.Make(E)\n (* generally repurpose A, but substitute"
},
{
"path": "test/test.ml",
"chars": 2476,
"preview": "(*\n * Copyright (c) 2013 Thomas Gazagnaire <thomas@gazagnaire.org>\n *\n * Permission to use, copy, modify, and distribute"
},
{
"path": "test/test_checksums.ml",
"chars": 4205,
"preview": "let unwrap_ipv4 buf = Ipv4_packet.Unmarshal.of_cstruct buf |> Result.get_ok\nlet verify_ipv4_udp = Ipv4_packet.Unmarshal."
},
{
"path": "test/test_connect.ml",
"chars": 4768,
"preview": "(*\n * Copyright (c) 2015 Magnus Skjegstad <magnus@skjegstad.com>\n *\n * Permission to use, copy, modify, and distribute t"
},
{
"path": "test/test_connect_ipv6.ml",
"chars": 4885,
"preview": "(*\n * Copyright (c) 2015 Magnus Skjegstad <magnus@skjegstad.com>\n *\n * Permission to use, copy, modify, and distribute t"
},
{
"path": "test/test_deadlock.ml",
"chars": 4985,
"preview": "open Lwt.Infix\n\nlet mtu = 4000\n\nlet server_log = Logs.Src.create \"test_deadlock_server\" ~doc:\"tcp deadlock tests: server"
},
{
"path": "test/test_icmpv4.ml",
"chars": 9049,
"preview": "open Common\n\nlet src = Logs.Src.create \"test_icmpv4\" ~doc:\"ICMP tests\"\nmodule Log = (val Logs.src_log src : Logs.LOG)\n\nm"
},
{
"path": "test/test_iperf.ml",
"chars": 10790,
"preview": "(*\n * Copyright (c) 2011 Richard Mortier <mort@cantab.net>\n * Copyright (c) 2012 Balraj Singh <balraj.singh@cl.cam.ac.uk"
},
{
"path": "test/test_iperf_ipv6.ml",
"chars": 11033,
"preview": "(*\n * Copyright (c) 2011 Richard Mortier <mort@cantab.net>\n * Copyright (c) 2012 Balraj Singh <balraj.singh@cl.cam.ac.uk"
},
{
"path": "test/test_ipv4.ml",
"chars": 14813,
"preview": "open Common\n\nlet test_unmarshal_with_options () =\n let datagram = Cstruct.create 40 in\n Cstruct.blit_from_string (\"\\x4"
},
{
"path": "test/test_ipv6.ml",
"chars": 8465,
"preview": "open Common\nmodule B = Vnetif_backends.Basic\nmodule V = Vnetif.Make(B)\nmodule E = Ethernet.Make(V)\n\nmodule Ipv6 = Ipv6.M"
},
{
"path": "test/test_keepalive.ml",
"chars": 5865,
"preview": "(* Test the functional part *)\n\n(* Linux default *)\nlet default = Tcpip.Tcp.Keepalive.({\n after = Duration.of_sec 7200;"
},
{
"path": "test/test_mtus.ml",
"chars": 4804,
"preview": "open Lwt.Infix\n\nlet server_cidr = Ipaddr.V4.Prefix.of_string_exn \"192.168.1.254/24\"\nlet client_cidr = Ipaddr.V4.Prefix.o"
},
{
"path": "test/test_rfc5961.ml",
"chars": 11711,
"preview": "(*\n * Copyright (c) 2016 Pablo Polvorin <pablo.polvorin@gmail.com>\n *\n * Permission to use, copy, modify, and distribute"
},
{
"path": "test/test_simulatenous_close.ml",
"chars": 4532,
"preview": "open Common\n\nopen Low_level\nopen Lwt.Infix\n\nlet close_ack_scenario =\n let fsm ip state ~src ~dst data =\n match state"
},
{
"path": "test/test_socket.ml",
"chars": 8435,
"preview": "open Lwt.Infix\n\nlet or_fail_str ~str f args =\n f args >>= function\n | `Ok p -> Lwt.return p\n | `Error _ -> Alcotest.f"
},
{
"path": "test/test_tcp_options.ml",
"chars": 11113,
"preview": "open Common\n\nlet check = Alcotest.(check @@ result (list options) string)\n\nlet errors ?(check_msg = false) exp = functio"
},
{
"path": "test/test_udp.ml",
"chars": 3367,
"preview": "open Common\n\nmodule B = Basic_backend.Make\nmodule V = Vnetif.Make(B)\nmodule E = Ethernet.Make(V)\nmodule Static_arp = Sta"
},
{
"path": "test/vnetif_backends.ml",
"chars": 6092,
"preview": "(*\n * Copyright (c) 2015-16 Magnus Skjegstad <magnus@skjegstad.com>\n *\n * Permission to use, copy, modify, and distribut"
},
{
"path": "test/vnetif_common.ml",
"chars": 5275,
"preview": "(*\n * Copyright (c) 2015 Magnus Skjegstad <magnus@skjegstad.com>\n *\n * Permission to use, copy, modify, and distribute t"
}
]
About this extraction
This page contains the full source code of the mirage/mirage-tcpip GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 126 files (505.8 KB), approximately 150.9k tokens, and a symbol index with 9 extracted functions, classes, methods, constants, and types. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.