mirror of
https://github.com/mirage/qubes-mirage-firewall.git
synced 2025-08-05 05:14:28 -04:00
Compare commits
No commits in common. "main" and "v0.7" have entirely different histories.
50 changed files with 1647 additions and 2306 deletions
32
.github/workflows/docker.yml
vendored
32
.github/workflows/docker.yml
vendored
|
|
@ -1,32 +0,0 @@
|
||||||
name: Main workflow
|
|
||||||
|
|
||||||
on:
|
|
||||||
pull_request:
|
|
||||||
push:
|
|
||||||
schedule:
|
|
||||||
# Prime the caches every Monday
|
|
||||||
- cron: 0 1 * * MON
|
|
||||||
|
|
||||||
jobs:
|
|
||||||
build:
|
|
||||||
strategy:
|
|
||||||
fail-fast: false
|
|
||||||
matrix:
|
|
||||||
os:
|
|
||||||
- ubuntu-latest
|
|
||||||
|
|
||||||
runs-on: ${{ matrix.os }}
|
|
||||||
|
|
||||||
steps:
|
|
||||||
- name: Checkout code
|
|
||||||
uses: actions/checkout@v4
|
|
||||||
|
|
||||||
- run: ./build-with.sh docker
|
|
||||||
|
|
||||||
- run: sh -exc 'if [ "$(sha256sum dist/qubes-firewall.xen)" = "$(cat qubes-firewall.sha256)" ]; then echo "SHA256 MATCHES"; else exit 42; fi'
|
|
||||||
|
|
||||||
- name: Upload Artifact
|
|
||||||
uses: actions/upload-artifact@v4
|
|
||||||
with:
|
|
||||||
name: qubes-firewall.xen
|
|
||||||
path: qubes-firewall.xen
|
|
||||||
42
.github/workflows/format.yml
vendored
42
.github/workflows/format.yml
vendored
|
|
@ -1,42 +0,0 @@
|
||||||
name: ocamlformat
|
|
||||||
|
|
||||||
on: [push]
|
|
||||||
|
|
||||||
jobs:
|
|
||||||
format:
|
|
||||||
name: ocamlformat
|
|
||||||
|
|
||||||
strategy:
|
|
||||||
fail-fast: false
|
|
||||||
matrix:
|
|
||||||
ocaml-version: ["4.14.2"]
|
|
||||||
operating-system: [ubuntu-latest]
|
|
||||||
|
|
||||||
runs-on: ${{ matrix.operating-system }}
|
|
||||||
|
|
||||||
steps:
|
|
||||||
- name: Checkout code
|
|
||||||
uses: actions/checkout@v4
|
|
||||||
|
|
||||||
- name: Use OCaml ${{ matrix.ocaml-version }}
|
|
||||||
uses: ocaml/setup-ocaml@v3
|
|
||||||
with:
|
|
||||||
ocaml-compiler: ${{ matrix.ocaml-version }}
|
|
||||||
|
|
||||||
- name: Install ocamlformat
|
|
||||||
run: grep ^version .ocamlformat | cut -d '=' -f 2 | xargs -I V opam install ocamlformat=V
|
|
||||||
|
|
||||||
- name: Format code
|
|
||||||
run: git ls-files '*.ml' '*.mli' | xargs opam exec -- ocamlformat --inplace
|
|
||||||
|
|
||||||
- name: Check for modified files
|
|
||||||
id: git-check
|
|
||||||
run: echo "modified=$(if git diff-index --quiet HEAD --; then echo "false"; else echo "true"; fi)" >> $GITHUB_OUTPUT
|
|
||||||
|
|
||||||
- name: Commit and push changes
|
|
||||||
if: steps.git-check.outputs.modified == 'true'
|
|
||||||
run: |
|
|
||||||
git config --global user.name "Automated ocamlformat GitHub action, developed by robur.coop"
|
|
||||||
git config --global user.email "autoformat@robur.coop"
|
|
||||||
git commit -m "formatted code" .
|
|
||||||
git push
|
|
||||||
32
.github/workflows/podman.yml
vendored
32
.github/workflows/podman.yml
vendored
|
|
@ -1,32 +0,0 @@
|
||||||
name: Main workflow
|
|
||||||
|
|
||||||
on:
|
|
||||||
pull_request:
|
|
||||||
push:
|
|
||||||
schedule:
|
|
||||||
# Prime the caches every Monday
|
|
||||||
- cron: 0 1 * * MON
|
|
||||||
|
|
||||||
jobs:
|
|
||||||
build:
|
|
||||||
strategy:
|
|
||||||
fail-fast: false
|
|
||||||
matrix:
|
|
||||||
os:
|
|
||||||
- ubuntu-latest
|
|
||||||
|
|
||||||
runs-on: ${{ matrix.os }}
|
|
||||||
|
|
||||||
steps:
|
|
||||||
- name: Checkout code
|
|
||||||
uses: actions/checkout@v4
|
|
||||||
|
|
||||||
- run: ./build-with.sh podman
|
|
||||||
|
|
||||||
- run: sh -exc 'if [ "$(sha256sum dist/qubes-firewall.xen)" = "$(cat qubes-firewall.sha256)" ]; then echo "SHA256 MATCHES"; else exit 42; fi'
|
|
||||||
|
|
||||||
- name: Upload Artifact
|
|
||||||
uses: actions/upload-artifact@v4
|
|
||||||
with:
|
|
||||||
name: qubes-firewall.xen
|
|
||||||
path: qubes-firewall.xen
|
|
||||||
|
|
@ -1,3 +0,0 @@
|
||||||
version = 0.27.0
|
|
||||||
profile = conventional
|
|
||||||
parse-docstrings = true
|
|
||||||
10
.travis.yml
Normal file
10
.travis.yml
Normal file
|
|
@ -0,0 +1,10 @@
|
||||||
|
language: c
|
||||||
|
script:
|
||||||
|
- echo 'ADD . /home/opam/qubes-mirage-firewall' >> Dockerfile
|
||||||
|
- echo 'RUN sudo chown -R opam /home/opam/qubes-mirage-firewall' >> Dockerfile
|
||||||
|
- docker build -t qubes-mirage-firewall .
|
||||||
|
- docker run --name build -i qubes-mirage-firewall
|
||||||
|
- docker cp build:/home/opam/qubes-mirage-firewall/qubes_firewall.xen .
|
||||||
|
- sha256sum qubes_firewall.xen
|
||||||
|
sudo: required
|
||||||
|
dist: trusty
|
||||||
116
CHANGES.md
116
CHANGES.md
|
|
@ -1,119 +1,3 @@
|
||||||
### 0.9.4 (2025-02-10)
|
|
||||||
|
|
||||||
- Fix an issue when qubes-mirage-firewall is used a a mullvad AppVM client. If
|
|
||||||
our netvm does not reply to our ARP requests we can not construct the ethernet
|
|
||||||
header. However in Linux VMs, Qubes adds a default netvm address associated to
|
|
||||||
`fe:ff:ff:ff:ff:ff`, so if ARP fails, we fall back on that address.
|
|
||||||
(#213, @palainp, reported in the Qubes forum #212, reviewed by @hannesm)
|
|
||||||
|
|
||||||
### 0.9.3 (2025-01-04)
|
|
||||||
|
|
||||||
- Fix an issue when qubes-mirage-firewall is used along with *BSD sys-net
|
|
||||||
(#209, @palainp, reported in the Qubes forum #208, reviewed by @dinosaure)
|
|
||||||
|
|
||||||
### 0.9.2 (2024-10-16)
|
|
||||||
|
|
||||||
- Code refactoring and improvements (#197, @dinosaure)
|
|
||||||
- Build tooling updates: opam 2.2.1, solo5 0.9, mirage 4.8.1 (#199, #201, #202,
|
|
||||||
#203, @hannesm)
|
|
||||||
|
|
||||||
### 0.9.1 (2024-05-10)
|
|
||||||
|
|
||||||
- Drop astring dependency, update mirage-net-xen, and OCaml 4.14.2 -- the
|
|
||||||
latest LTS release (#193, @hannesm)
|
|
||||||
- Allow the firewall to use domains requests in rules (#193, @palainp,
|
|
||||||
reported in the Qubes forum, fix confirmed by @neoniobium)
|
|
||||||
|
|
||||||
### 0.9.0 (2024-04-24)
|
|
||||||
|
|
||||||
- Fix an incorrect free memory estimation (fix in mirage/ocaml-solo5#135
|
|
||||||
@palainp)
|
|
||||||
- Update to mirage 4.5.0, allowing openBSD to be used as netvm (#146 reported
|
|
||||||
by @Szewcson), and recover from a netvm change (#156 reported by @xaki-23)
|
|
||||||
(#178 @palainp)
|
|
||||||
|
|
||||||
### 0.8.6 (2023-11-08)
|
|
||||||
|
|
||||||
- Fix Docker build issue with newest SELinux policies (#183 @palainp, reported
|
|
||||||
by @Szewcson)
|
|
||||||
- Update build script (change to debian repositories, update debian image, update
|
|
||||||
opam-repository commit, set commit for opam-overlay and mirage-overlay) (#184
|
|
||||||
@palainp, reported by @ben-grande)
|
|
||||||
- Update disk usage value during local compilation (#186 @palainp, reported by
|
|
||||||
@ben-grande)
|
|
||||||
|
|
||||||
### 0.8.5 (2023-07-05)
|
|
||||||
|
|
||||||
- Remove memreport to Xen to avoid Qubes trying to get back some memory
|
|
||||||
(#176 @palainp)
|
|
||||||
- Use bookworm and snapshot.notset.fr debian packages for reproducibility
|
|
||||||
(#175 @palainp)
|
|
||||||
|
|
||||||
### 0.8.4 (2022-12-07)
|
|
||||||
|
|
||||||
- Fix remote denial of service due to excessive console output (#166 @burghardt,
|
|
||||||
fix in solo5/solo5#538 by @palainp)
|
|
||||||
- Use Ubuntu container for build, now GitHub action, ./build-with-docker.sh and
|
|
||||||
builds.robur.coop are synchronized (and result in the same artifact)
|
|
||||||
(#164 @hannesm)
|
|
||||||
|
|
||||||
### 0.8.3 (2022-11-11)
|
|
||||||
|
|
||||||
- Fix "DNS issues", a firewall ruleset with a domain name lead to 100% CPU usage
|
|
||||||
(reported by fiftyfourthparallel on
|
|
||||||
https://forum.qubes-os.org/t/mirage-firewall-0-8-2-broken-new-users-should-install-0-8-1/14566,
|
|
||||||
re-reported by @palainp in #158, fixed by @hannesm in mirage/mirage-nat#48
|
|
||||||
(release 3.0.1)) - underlying issue was a wrong definition of `is_port_free`
|
|
||||||
(since 3.0.0, used since mirage-qubes-firewall 0.8.2).
|
|
||||||
- Fix "crash on downstream vm start", after more than 64 client VMs have been
|
|
||||||
connected and disconnected with the qubes-mirage-firewall (reported by @xaki23
|
|
||||||
in #155, fixed by @hannesm in #161) - underlying issue was a leak of xenstore
|
|
||||||
watchers and a hard limit in xen on the amount of watchers
|
|
||||||
- Fix "detach netvm fails" (reported by @rootnoob in #157, fixed by @palainp
|
|
||||||
in mirage/mirage-net-xen#105 (release 2.1.2)) - underlying issue was that the
|
|
||||||
network interface state was never set to closed, but directly removed
|
|
||||||
- Fix potential DoS in handling DNS replies (#162 @hannesm)
|
|
||||||
- Avoid potential forever loop in My_nat.free_udp_port (#159 @hannesm)
|
|
||||||
- Assorted code removals (#161 @hannesm)
|
|
||||||
- Update to dns 6.4.0 changes (#154, @hannesm)
|
|
||||||
|
|
||||||
### 0.8.2 (2022-10-12)
|
|
||||||
|
|
||||||
- Advise to use 32 MB memory, which is sufficient (#150, @palainp)
|
|
||||||
- Improve documentation (#150, @palainp)
|
|
||||||
- Remove unneeded memory management code and log messages (#150, @palainp)
|
|
||||||
- Use mirage-nat 3.0.0, remove global mutable state (#151, @hannesm)
|
|
||||||
|
|
||||||
### 0.8.1 (2022-09-14)
|
|
||||||
|
|
||||||
- support qrexec protocol version 3 (@reynir @palainp in mirage-qubes 0.9.3)
|
|
||||||
- remove special DNS rule (which used to be required for Qubes 3, issue #63, fix #142, @hannesm)
|
|
||||||
- use DNS servers from QubesDB instead of hardcoded ones for evaluation of the DNS rule (#142 @hannesm)
|
|
||||||
- remove the GUI code (not needed in Qubes 4.1 anymore, issue #62, fix #144, @palainp)
|
|
||||||
- trigger GC slightly earlier (at < 50% free space, issue #143, fix #147, @palainp)
|
|
||||||
|
|
||||||
### 0.8.0
|
|
||||||
|
|
||||||
The major change is to use PVH instead of PV. The effort was in solo5 (https://github.com/solo5/solo5) which since 0.6.6 supports Xen and PVH (developed by @mato, with some fixes (multiboot, mem size computed uniformly, not skipping first token of command line arguments) by @marmarek, @xaki23, @palainp, and @hannesm).
|
|
||||||
|
|
||||||
Another user-visible change is that the DNS resolver is read from QubesDB /qubes-primary-dns instead of using a hardcoded IP address (@palainp and @hannesm).
|
|
||||||
|
|
||||||
Also, the qrexec version negotiation has been implemented (in mirage-qubes by @reynir).
|
|
||||||
|
|
||||||
Thanks to @palainp and @winux138 keeping track of memory allocation has been improved, and also memory can be freed now.
|
|
||||||
|
|
||||||
This release uses the latest mirage release (4.2.1). It can be built with a Fedora 35 container. It uses OCaml 4.14.0.
|
|
||||||
|
|
||||||
Thanks to @talex5 for lots of code cleanups, reviews, and merges. Also thanks to @xaki23 for early and detailed feedback. Testing was done by @Tommytran732 and @Szewcson. Thanks to @burghardt for documentation improvements.
|
|
||||||
|
|
||||||
### 0.7.1
|
|
||||||
|
|
||||||
Bugfixes:
|
|
||||||
|
|
||||||
- More robust parsing of IP address in Xenstore, which may contain both IPv4 and IPv6 addresses (@linse, #103, reported by @grote)
|
|
||||||
|
|
||||||
- Avoid stack overflow with many connections in the NAT table (@linse and @hannesm, reported by @talex5 in #105, fixed by mirage-nat 2.2.2 release)
|
|
||||||
|
|
||||||
### 0.7
|
### 0.7
|
||||||
|
|
||||||
This version adapts qubes-mirage-firewall with
|
This version adapts qubes-mirage-firewall with
|
||||||
|
|
|
||||||
41
Dockerfile
41
Dockerfile
|
|
@ -1,35 +1,18 @@
|
||||||
# Pin the base image to a specific hash for maximum reproducibility.
|
# Pin the base image to a specific hash for maximum reproducibility.
|
||||||
# It will probably still work on newer images, though, unless an update
|
# It will probably still work on newer images, though, unless Debian
|
||||||
# changes some compiler optimisations (unlikely).
|
# changes some compiler optimisations (unlikely).
|
||||||
# bookworm-slim taken from https://hub.docker.com/_/debian/tags?page=1&name=bookworm-slim
|
#FROM ocurrent/opam:alpine-3.10-ocaml-4.10
|
||||||
FROM debian@sha256:3d5df92588469a4c503adbead0e4129ef3f88e223954011c2169073897547cac
|
FROM ocurrent/opam@sha256:d30098ff92b5ee10cf7c11c17f2351705e5226a6b05aa8b9b7280b3d87af9cde
|
||||||
# install remove default packages repository
|
|
||||||
RUN rm /etc/apt/sources.list.d/debian.sources
|
|
||||||
# and set the package source to a specific release too
|
|
||||||
# taken from https://snapshot.debian.org/archive/debian
|
|
||||||
RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian/20240419T024211Z bookworm main\n" > /etc/apt/sources.list
|
|
||||||
# taken from https://snapshot.debian.org/archive/debian-security/
|
|
||||||
RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian-security/20240419T111010Z bookworm-security main\n" >> /etc/apt/sources.list
|
|
||||||
|
|
||||||
RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev
|
|
||||||
RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.3.0/opam-2.3.0-i686-linux && chmod 755 /usr/bin/opam
|
|
||||||
# taken from https://raw.githubusercontent.com/ocaml/opam/master/shell/install.sh
|
|
||||||
RUN test `sha512sum /usr/bin/opam | cut -d' ' -f1` = \
|
|
||||||
"4c0e8771889a36bad4d5f964e2e662d5b611e6f112777d3d4eea3eea919d109cd17826beba38e6cfa1ad9553a0a989d9268f911ea5485968da04b1e08efc7de2" || exit
|
|
||||||
|
|
||||||
ENV OPAMROOT=/tmp
|
|
||||||
ENV OPAMCONFIRMLEVEL=unsafe-yes
|
|
||||||
# Pin last known-good version for reproducible builds.
|
# Pin last known-good version for reproducible builds.
|
||||||
# Remove this line (and the base image pin above) if you want to test with the
|
# Remove this line (and the base image pin above) if you want to test with the
|
||||||
# latest versions.
|
# latest versions.
|
||||||
# taken from https://github.com/ocaml/opam-repository
|
RUN cd ~/opam-repository && git fetch origin master && git reset --hard 4dd2620bcc821418bae53669a6c6163964c090a2 && opam update
|
||||||
RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#8f63148a9025a7b775a069a6c0b0385c22ad51d3
|
|
||||||
RUN opam switch create myswitch 4.14.2
|
RUN opam depext -i -y mirage.3.7.7 lwt.5.3.0
|
||||||
RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5
|
RUN mkdir /home/opam/qubes-mirage-firewall
|
||||||
RUN mkdir /tmp/orb-build
|
ADD config.ml /home/opam/qubes-mirage-firewall/config.ml
|
||||||
ADD config.ml /tmp/orb-build/config.ml
|
WORKDIR /home/opam/qubes-mirage-firewall
|
||||||
WORKDIR /tmp/orb-build
|
RUN opam config exec -- mirage configure -t xen && make depend
|
||||||
CMD opam exec -- sh -exc 'mirage configure -t xen --extra-repos=\
|
CMD opam config exec -- mirage configure -t xen && \
|
||||||
opam-overlays:https://github.com/dune-universe/opam-overlays.git#f2bec38beca4aea9e481f2fd3ee319c519124649,\
|
opam config exec -- make tar
|
||||||
mirage-overlays:https://github.com/dune-universe/mirage-opam-overlays.git#797cb363df3ff763c43c8fbec5cd44de2878757e \
|
|
||||||
&& make depend && make unikernel'
|
|
||||||
|
|
|
||||||
23
LICENSE.md
23
LICENSE.md
|
|
@ -1,23 +0,0 @@
|
||||||
Copyright (X) 2015-2024, the Qubes Mirage Firewall authors
|
|
||||||
All rights reserved.
|
|
||||||
|
|
||||||
Redistribution and use in source and binary forms, with or without modification,
|
|
||||||
are permitted provided that the following conditions are met:
|
|
||||||
|
|
||||||
* Redistributions of source code must retain the above copyright notice, this
|
|
||||||
list of conditions and the following disclaimer.
|
|
||||||
|
|
||||||
* Redistributions in binary form must reproduce the above copyright notice, this
|
|
||||||
list of conditions and the following disclaimer in the documentation and/or
|
|
||||||
other materials provided with the distribution.
|
|
||||||
|
|
||||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
|
|
||||||
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
|
||||||
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
|
||||||
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
|
|
||||||
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
|
|
||||||
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
|
||||||
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
|
|
||||||
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
||||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
|
||||||
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
|
|
@ -1,7 +1,8 @@
|
||||||
MIRAGE_KERNEL_NAME = dist/qubes-firewall.xen
|
MIRAGE_KERNEL_NAME = qubes_firewall.xen
|
||||||
OCAML_VERSION ?= 4.14.2
|
OCAML_VERSION ?= 4.10.0
|
||||||
SOURCE_BUILD_DEP := firewall-build-dep
|
SOURCE_BUILD_DEP := firewall-build-dep
|
||||||
|
|
||||||
firewall-build-dep:
|
firewall-build-dep:
|
||||||
opam install -y mirage
|
opam install -y depext
|
||||||
|
opam depext -i -y mirage.3.7.7 lwt.5.3.0
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,10 @@
|
||||||
unikernel: build
|
tar: build
|
||||||
cp dist/qubes-firewall.xen dist/qubes-firewall.xen.debug
|
rm -rf _build/mirage-firewall
|
||||||
strip dist/qubes-firewall.xen
|
mkdir _build/mirage-firewall
|
||||||
cp dist/qubes-firewall.xen .
|
cp qubes_firewall.xen _build/mirage-firewall/vmlinuz
|
||||||
sha256sum qubes-firewall.xen
|
touch _build/mirage-firewall/modules.img
|
||||||
|
cat /dev/null | gzip -n > _build/mirage-firewall/initramfs
|
||||||
|
tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall
|
||||||
|
|
||||||
fetchmotron: qubes_firewall.xen
|
fetchmotron: qubes_firewall.xen
|
||||||
test-mirage qubes_firewall.xen mirage-fw-test &
|
test-mirage qubes_firewall.xen mirage-fw-test &
|
||||||
|
|
|
||||||
172
README.md
172
README.md
|
|
@ -3,6 +3,8 @@
|
||||||
A unikernel that can run as a QubesOS ProxyVM, replacing `sys-firewall`.
|
A unikernel that can run as a QubesOS ProxyVM, replacing `sys-firewall`.
|
||||||
It uses the [mirage-qubes][] library to implement the Qubes protocols.
|
It uses the [mirage-qubes][] library to implement the Qubes protocols.
|
||||||
|
|
||||||
|
Note: This firewall *ignores the rules set in the Qubes GUI*. See `rules.ml` for the actual policy.
|
||||||
|
|
||||||
See [A Unikernel Firewall for QubesOS][] for more details.
|
See [A Unikernel Firewall for QubesOS][] for more details.
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -13,86 +15,65 @@ See the [Deploy](#deploy) section below for installation instructions.
|
||||||
|
|
||||||
## Build from source
|
## Build from source
|
||||||
|
|
||||||
Note: The most reliable way to build is using Docker or Podman.
|
|
||||||
Fedora 38 works well for this, Debian 12 also works, but you'll need to follow the instructions at [docker.com][debian-docker] to get Docker
|
|
||||||
(don't use Debian's version).
|
|
||||||
|
|
||||||
Create a new Fedora-38 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 8192 MiB. Open a terminal.
|
Create a new Fedora-30 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 4096 MiB. Open a terminal.
|
||||||
|
|
||||||
Clone this Git repository and run the `build-with.sh` script with either `docker` or `podman` as argument (Note: The `chcon` call is mandatory on Fedora with new SELinux policies which do not allow to standardly keep the docker images in homedir):
|
Clone this Git repository and run the `build-with-docker.sh` script:
|
||||||
|
|
||||||
mkdir /home/user/docker
|
mkdir /home/user/docker
|
||||||
sudo ln -s /home/user/docker /var/lib/docker
|
sudo ln -s /home/user/docker /var/lib/docker
|
||||||
sudo chcon -Rt container_file_t /home/user/docker
|
|
||||||
sudo dnf install docker
|
sudo dnf install docker
|
||||||
sudo systemctl start docker
|
sudo systemctl start docker
|
||||||
git clone https://github.com/mirage/qubes-mirage-firewall.git
|
git clone https://github.com/mirage/qubes-mirage-firewall.git
|
||||||
cd qubes-mirage-firewall
|
cd qubes-mirage-firewall
|
||||||
sudo ./build-with.sh docker
|
sudo ./build-with-docker.sh
|
||||||
|
|
||||||
Or
|
This took about 10 minutes on my laptop (it will be much quicker if you run it again).
|
||||||
|
The symlink step at the start isn't needed if your build VM is standalone.
|
||||||
sudo systemctl start podman
|
It gives Docker more disk space and avoids losing the Docker image cache when you reboot the Qube.
|
||||||
git clone https://github.com/mirage/qubes-mirage-firewall.git
|
|
||||||
cd qubes-mirage-firewall
|
|
||||||
./build-with.sh podman
|
|
||||||
|
|
||||||
This took about 15 minutes on my laptop (it will be much quicker if you run it again).
|
|
||||||
The symlink step at the start isn't needed if your build VM is standalone. It gives Docker more disk space and avoids losing the Docker image cache when you reboot the Qube.
|
|
||||||
It's not needed with Podman as the containers lives in your home directory by default.
|
|
||||||
|
|
||||||
Note: the object files are stored in the `_build` directory to speed up incremental builds.
|
Note: the object files are stored in the `_build` directory to speed up incremental builds.
|
||||||
If you change the dependencies, you will need to delete this directory before rebuilding.
|
If you change the dependencies, you will need to delete this directory before rebuilding.
|
||||||
|
|
||||||
It's OK to install the Docker or Podman package in a template VM if you want it to remain
|
If you want to build on Debian, follow the instructions at [docker.com][debian-docker] to get Docker and then run `sudo ./build-with-docker.sh` as above.
|
||||||
|
|
||||||
|
It's OK to install the Docker package in a template VM if you want it to remain
|
||||||
after a reboot, but the build of the firewall itself should be done in a regular AppVM.
|
after a reboot, but the build of the firewall itself should be done in a regular AppVM.
|
||||||
|
|
||||||
You can also build without that script, as for any normal Mirage unikernel;
|
You can also build without Docker, as for any normal Mirage unikernel;
|
||||||
see [the Mirage installation instructions](https://mirageos.org/wiki/install) for details.
|
see [the Mirage installation instructions](https://mirage.io/wiki/install) for details.
|
||||||
|
|
||||||
The build script fixes the versions of the libraries it uses, ensuring that you will get
|
The Docker build fixes the versions of the libraries it uses, ensuring that you will get
|
||||||
exactly the same binary that is in the release. If you build without it, it will build
|
exactly the same binary that is in the release. If you build without Docker, it will build
|
||||||
against the latest versions instead (and the hash will therefore probably not match).
|
against the latest versions instead (and the hash will therefore probably not match).
|
||||||
However, it should still work fine.
|
However, it should still work fine.
|
||||||
|
|
||||||
## Deploy
|
## Deploy
|
||||||
|
|
||||||
### Manual deployment
|
If you want to deploy manually, unpack `mirage-firewall.tar.bz2` in dom0, inside `/var/lib/qubes/vm-kernels/`. e.g. (if `dev` is the AppVM where you built it):
|
||||||
If you want to deploy manually, you just need to download `qubes-firewall.xen` and
|
|
||||||
`qubes-firewall.sha256` in domU and check that the `.xen` file has a corresponding
|
|
||||||
hashsum. `qubes-firewall.xen` is the unikernel itself and should be copied to
|
|
||||||
`vmlinuz` in the `/var/lib/qubes/vm-kernels/mirage-firewall` directory in dom0, e.g.
|
|
||||||
(if `dev` is the AppVM where you built it):
|
|
||||||
|
|
||||||
[tal@dom0 ~]$ mkdir -p /var/lib/qubes/vm-kernels/mirage-firewall/
|
[tal@dom0 ~]$ cd /var/lib/qubes/vm-kernels/
|
||||||
[tal@dom0 ~]$ cd /var/lib/qubes/vm-kernels/mirage-firewall/
|
[tal@dom0 vm-kernels]$ qvm-run -p dev 'cat qubes-mirage-firewall/mirage-firewall.tar.bz2' | tar xjf -
|
||||||
[tal@dom0 mirage-firewall]$ qvm-run -p dev 'cat mirage-firewall/qubes-firewall.xen' > vmlinuz
|
|
||||||
|
|
||||||
Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-firewall` kernel you added above
|
The tarball contains `vmlinuz`, which is the unikernel itself, plus a couple of dummy files that Qubes requires.
|
||||||
|
|
||||||
|
Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-firewall` kernel you added above:
|
||||||
|
|
||||||
```
|
```
|
||||||
qvm-create \
|
qvm-create \
|
||||||
--property kernel=mirage-firewall \
|
--property kernel=mirage-firewall \
|
||||||
--property kernelopts='' \
|
--property kernelopts=None \
|
||||||
--property memory=32 \
|
--property memory=32 \
|
||||||
--property maxmem=32 \
|
--property maxmem=32 \
|
||||||
--property netvm=sys-net \
|
--property netvm=sys-net \
|
||||||
--property provides_network=True \
|
--property provides_network=True \
|
||||||
--property vcpus=1 \
|
--property vcpus=1 \
|
||||||
--property virt_mode=pvh \
|
--property virt_mode=pv \
|
||||||
--label=green \
|
--label=green \
|
||||||
--class StandaloneVM \
|
--class StandaloneVM \
|
||||||
mirage-firewall
|
mirage-firewall
|
||||||
|
|
||||||
qvm-features mirage-firewall qubes-firewall 1
|
|
||||||
qvm-features mirage-firewall no-default-kernelopts 1
|
|
||||||
```
|
```
|
||||||
|
|
||||||
### Deployment using saltstack
|
|
||||||
If you're familiar how to run salt states in Qubes, you can also use the script `SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls` to automatically deploy the latest version of mirage firewall in your Qubes OS. An introduction can be found [here](https://forum.qubes-os.org/t/qubes-salt-beginners-guide/20126) and [here](https://www.qubes-os.org/doc/salt/). Following the instructions from the former link, you can run the script in dom0 with the command `sudo qubesctl --show-output state.apply SaltScriptToDownloadAndInstallMirageFirewallInQubes saltenv=user`. The script checks the checksum from the integration server and compares with the latest version provided in the github releases. It might be necessary to adjust the VM templates in the script which are used for downloading of the mirage unikernel, if your default templates do not have the tools `curl` and `tar` installed by default. Also don't forget to change the VMs in which the uni kernel should be used or adjust the "Qubes Global Settings".
|
|
||||||
|
|
||||||
## Upgrading
|
|
||||||
|
|
||||||
To upgrade from an earlier release, just overwrite `/var/lib/qubes/vm-kernels/mirage-firewall/vmlinuz` with the new version and restart the firewall VM.
|
To upgrade from an earlier release, just overwrite `/var/lib/qubes/vm-kernels/mirage-firewall/vmlinuz` with the new version and restart the firewall VM.
|
||||||
|
|
||||||
### Configure AppVMs to use it
|
### Configure AppVMs to use it
|
||||||
|
|
@ -116,17 +97,6 @@ https://www.qubes-os.org/doc/software-update-dom0/ says:
|
||||||
> there are no significant security implications in this choice. By default,
|
> there are no significant security implications in this choice. By default,
|
||||||
> this role is assigned to the firewallvm.
|
> this role is assigned to the firewallvm.
|
||||||
|
|
||||||
### Configure firewall with OpenBSD-like netvm
|
|
||||||
|
|
||||||
OpenBSD is currently unable to be used as netvm, so if you want to use a BSD as your sys-net VM, you'll need to set its netvm to qubes-mirage-firewall (see https://github.com/mirage/qubes-mirage-firewall/issues/146 for more information).
|
|
||||||
That means you'll have `AppVMs -> qubes-mirage-firewall <- OpenBSD` with the arrow standing for the netvm property setting.
|
|
||||||
|
|
||||||
In that case you'll have to tell qubes-mirage-firewall which AppVM client should be used as uplink:
|
|
||||||
```
|
|
||||||
qvm-prefs --set mirage-firewall -- kernelopts '--ipv4=X.X.X.X --ipv4-gw=Y.Y.Y.Y'
|
|
||||||
```
|
|
||||||
with `X.X.X.X` the IP address for mirage-firewall and `Y.Y.Y.Y` the IP address of your OpenBSD HVM.
|
|
||||||
|
|
||||||
### Components
|
### Components
|
||||||
|
|
||||||
This diagram show the main components (each box corresponds to a source `.ml` file with the same name):
|
This diagram show the main components (each box corresponds to a source `.ml` file with the same name):
|
||||||
|
|
@ -136,7 +106,7 @@ This diagram show the main components (each box corresponds to a source `.ml` fi
|
||||||
</p>
|
</p>
|
||||||
|
|
||||||
Ethernet frames arrives from client qubes (such as `work` or `personal`) or from `sys-net`.
|
Ethernet frames arrives from client qubes (such as `work` or `personal`) or from `sys-net`.
|
||||||
Internet (IP) packets are sent to `firewall`, which consults the NAT table and the rules from QubesDB to decide what to do with the packet.
|
Internet (IP) packets are sent to `firewall`, which consults `rules` to decide what to do with the packet.
|
||||||
If it should be sent on, it uses `router` to send it to the chosen destination.
|
If it should be sent on, it uses `router` to send it to the chosen destination.
|
||||||
`client_net` watches the XenStore database provided by dom0
|
`client_net` watches the XenStore database provided by dom0
|
||||||
to find out when clients need to be added or removed.
|
to find out when clients need to be added or removed.
|
||||||
|
|
@ -152,54 +122,55 @@ The boot process:
|
||||||
|
|
||||||
### Easy deployment for developers
|
### Easy deployment for developers
|
||||||
|
|
||||||
For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes-firewall.xen`) from your development AppVM.
|
For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes_firewall.xen`) from your development AppVM.
|
||||||
This takes a little more setting up the first time, but will be much quicker after that. e.g.
|
This takes a little more setting up the first time, but will be much quicker after that. e.g.
|
||||||
|
|
||||||
[user@dev ~]$ test-mirage dist/qubes-firewall.xen mirage-firewall
|
$ test-mirage qubes_firewall.xen mirage-firewall
|
||||||
Waiting for 'Ready'... OK
|
Waiting for 'Ready'... OK
|
||||||
Uploading 'dist/qubes-firewall.xen' (7454880 bytes) to "mirage-test"
|
Uploading 'qubes_firewall.xen' (5901080 bytes) to "mirage-firewall"
|
||||||
Waiting for 'Booting'... OK
|
Waiting for 'Booting'... OK
|
||||||
Connecting to mirage-test console...
|
--> Loading the VM (type = ProxyVM)...
|
||||||
Solo5: Xen console: port 0x2, ring @0x00000000FEFFF000
|
--> Starting Qubes DB...
|
||||||
| ___|
|
--> Setting Qubes DB info for the VM...
|
||||||
__| _ \ | _ \ __ \
|
--> Updating firewall rules...
|
||||||
\__ \ ( | | ( | ) |
|
--> Starting the VM...
|
||||||
____/\___/ _|\___/____/
|
--> Starting the qrexec daemon...
|
||||||
Solo5: Bindings version v0.7.3
|
Waiting for VM's qrexec agent.connected
|
||||||
Solo5: Memory map: 32 MB addressable:
|
--> Starting Qubes GUId...
|
||||||
Solo5: reserved @ (0x0 - 0xfffff)
|
Connecting to VM's GUI agent: .connected
|
||||||
Solo5: text @ (0x100000 - 0x319fff)
|
--> Sending monitor layout...
|
||||||
Solo5: rodata @ (0x31a000 - 0x384fff)
|
--> Waiting for qubes-session...
|
||||||
Solo5: data @ (0x385000 - 0x53ffff)
|
Connecting to mirage-firewall console...
|
||||||
Solo5: heap >= 0x540000 < stack < 0x2000000
|
MirageOS booting...
|
||||||
2022-08-13 14:55:38 -00:00: INF [qubes.rexec] waiting for client...
|
Initialising timer interface
|
||||||
2022-08-13 14:55:38 -00:00: INF [qubes.db] connecting to server...
|
Initialising console ... done.
|
||||||
2022-08-13 14:55:38 -00:00: INF [qubes.db] connected
|
gnttab_stubs.c: initialised mini-os gntmap
|
||||||
2022-08-13 14:55:38 -00:00: INF [qubes.db] got update: "/mapped-ip/10.137.0.20/visible-ip" = "10.137.0.20"
|
2017-03-18 11:32:37 -00:00: INF [qubes.rexec] waiting for client...
|
||||||
2022-08-13 14:55:38 -00:00: INF [qubes.db] got update: "/mapped-ip/10.137.0.20/visible-gateway" = "10.137.0.23"
|
2017-03-18 11:32:37 -00:00: INF [qubes.gui] waiting for client...
|
||||||
2022-08-13 14:55:38 -00:00: INF [qubes.rexec] client connected, using protocol version 3
|
2017-03-18 11:32:37 -00:00: INF [qubes.db] connecting to server...
|
||||||
2022-08-13 14:55:38 -00:00: INF [unikernel] QubesDB and qrexec agents connected in 0.041 s
|
2017-03-18 11:32:37 -00:00: INF [qubes.db] connected
|
||||||
2022-08-13 14:55:38 -00:00: INF [dao] Got network configuration from QubesDB:
|
2017-03-18 11:32:37 -00:00: INF [qubes.rexec] client connected, using protocol version 2
|
||||||
NetVM IP on uplink network: 10.137.0.4
|
2017-03-18 11:32:37 -00:00: INF [qubes.db] got update: "/qubes-keyboard" = "xkb_keymap {\n\txkb_keycodes { include \"evdev+aliases(qwerty)\"\t};\n\txkb_types { include \"complete\"\t};\n\txkb_compat { include \"complete\"\t};\n\txkb_symbols { include \"pc+gb+inet(evdev)\"\t};\n\txkb_geometry { include \"pc(pc105)\"\t};\n};"
|
||||||
Our IP on uplink network: 10.137.0.23
|
2017-03-18 11:32:37 -00:00: INF [qubes.gui] client connected (screen size: 6720x2160)
|
||||||
Our IP on client networks: 10.137.0.23
|
2017-03-18 11:32:37 -00:00: INF [unikernel] Qubes agents connected in 0.095 s (CPU time used since boot: 0.008 s)
|
||||||
DNS resolver: 10.139.1.1
|
2017-03-18 11:32:37 -00:00: INF [net-xen:frontend] connect 0
|
||||||
DNS secondary resolver: 10.139.1.2
|
2017-03-18 11:32:37 -00:00: INF [memory_pressure] Writing meminfo: free 6584 / 17504 kB (37.61 %)
|
||||||
2022-08-13 14:55:38 -00:00: INF [net-xen frontend] connect 0
|
Note: cannot write Xen 'control' directory
|
||||||
2022-08-13 14:55:38 -00:00: INF [net-xen frontend] create: id=0 domid=1
|
2017-03-18 11:32:37 -00:00: INF [net-xen:frontend] create: id=0 domid=1
|
||||||
2022-08-13 14:55:38 -00:00: INF [net-xen frontend] sg:true gso_tcpv4:true rx_copy:true rx_flip:false smart_poll:false
|
2017-03-18 11:32:37 -00:00: INF [net-xen:frontend] sg:true gso_tcpv4:true rx_copy:true rx_flip:false smart_poll:false
|
||||||
2022-08-13 14:55:38 -00:00: INF [net-xen frontend] MAC: 00:16:3e:5e:6c:00
|
2017-03-18 11:32:37 -00:00: INF [net-xen:frontend] MAC: 00:16:3e:5e:6c:11
|
||||||
2022-08-13 14:55:38 -00:00: INF [ethernet] Connected Ethernet interface 00:16:3e:5e:6c:00
|
2017-03-18 11:32:37 -00:00: WRN [command] << Unknown command "QUBESRPC qubes.SetMonitorLayout dom0"
|
||||||
2022-08-13 14:55:38 -00:00: INF [ARP] Sending gratuitous ARP for 10.137.0.23 (00:16:3e:5e:6c:00)
|
2017-03-18 11:32:38 -00:00: INF [ethif] Connected Ethernet interface 00:16:3e:5e:6c:11
|
||||||
2022-08-13 14:55:38 -00:00: INF [ARP] Sending gratuitous ARP for 10.137.0.23 (00:16:3e:5e:6c:00)
|
2017-03-18 11:32:38 -00:00: INF [arpv4] Connected arpv4 device on 00:16:3e:5e:6c:11
|
||||||
2022-08-13 14:55:38 -00:00: INF [udp] UDP layer connected on 10.137.0.23
|
2017-03-18 11:32:38 -00:00: INF [dao] Watching backend/vif
|
||||||
2022-08-13 14:55:38 -00:00: INF [dao] Watching backend/vif
|
2017-03-18 11:32:38 -00:00: INF [qubes.db] got update: "/qubes-netvm-domid" = "1"
|
||||||
2022-08-13 14:55:38 -00:00: INF [memory_pressure] Writing meminfo: free 20MiB / 27MiB (72.68 %)
|
|
||||||
|
|
||||||
# Testing if the firewall works
|
# Testing if the firewall works
|
||||||
|
|
||||||
A unikernel which tests the firewall is available in the `test/` subdirectory.
|
Build the test unikernel in the test directory.
|
||||||
To use it, run `test.sh` and follow the instructions to set up the test environment.
|
Install it to a vm which has the firewall as netvm.
|
||||||
|
Set the rules for the testvm to "textfile".
|
||||||
|
Run the test unikernel.
|
||||||
|
|
||||||
# Security advisories
|
# Security advisories
|
||||||
|
|
||||||
|
|
@ -207,7 +178,16 @@ See [issues tagged "security"](https://github.com/mirage/qubes-mirage-firewall/i
|
||||||
|
|
||||||
# LICENSE
|
# LICENSE
|
||||||
|
|
||||||
See [LICENSE.md](https://github.com/mirage/qubes-mirage-firewall/blob/main/LICENSE.md)
|
Copyright (c) 2019, Thomas Leonard
|
||||||
|
All rights reserved.
|
||||||
|
|
||||||
|
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
|
||||||
|
|
||||||
|
1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
|
||||||
|
|
||||||
|
2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
|
||||||
|
|
||||||
|
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||||
|
|
||||||
[test-mirage]: https://github.com/talex5/qubes-test-mirage
|
[test-mirage]: https://github.com/talex5/qubes-test-mirage
|
||||||
[mirage-qubes]: https://github.com/mirage/mirage-qubes
|
[mirage-qubes]: https://github.com/mirage/mirage-qubes
|
||||||
|
|
|
||||||
|
|
@ -1,104 +0,0 @@
|
||||||
# How to install the superlight mirage-firewall for Qubes OS by using saltstack
|
|
||||||
# Tested on Qubes v4.1 and mirage v0.8.5
|
|
||||||
# After the install, you have to switch your AppVMs to use the mirage firewall vm created by this script e.g. by using "Qubes Global Settings"
|
|
||||||
# inspired by: https://github.com/one7two99/my-qubes/tree/master/mirage-firewall
|
|
||||||
|
|
||||||
# default template + dispvm template are used. Possible optimization is to use min-dvms
|
|
||||||
{% set DownloadVMTemplate = salt['cmd.shell']("qubes-prefs default_template") %}
|
|
||||||
{% set DispVM = salt['cmd.shell']("qubes-prefs default_dispvm") %}
|
|
||||||
|
|
||||||
{% set DownloadVM = "DownloadVmMirage" %}
|
|
||||||
{% set MirageFW = "sys-mirage-fw" %}
|
|
||||||
{% set GithubUrl = "https://github.com/mirage/qubes-mirage-firewall" %}
|
|
||||||
{% set Kernel = "qubes-firewall.xen" %}
|
|
||||||
{% set Shasum = "qubes-firewall-release.sha256" %}
|
|
||||||
{% set MirageInstallDir = "/var/lib/qubes/vm-kernels/mirage-firewall" %}
|
|
||||||
|
|
||||||
#download and install the latest version
|
|
||||||
{% set Release = salt['cmd.shell']("qvm-run --dispvm " ~ DispVM ~ " --pass-io \"curl --silent --location -o /dev/null -w %{url_effective} " ~ GithubUrl ~ "/releases/latest | rev | cut -d \"/\" -f 1 | rev\"") %}
|
|
||||||
|
|
||||||
{% if Release != salt['cmd.shell']("test -e " ~ MirageInstallDir ~ "/version.txt" ~ " || mkdir " ~ MirageInstallDir ~ " ; touch " ~ MirageInstallDir ~ "/version.txt" ~ " ; cat " ~ MirageInstallDir ~ "/version.txt") %}
|
|
||||||
|
|
||||||
create-downloader-VM:
|
|
||||||
qvm.vm:
|
|
||||||
- name: {{ DownloadVM }}
|
|
||||||
- present:
|
|
||||||
- template: {{ DownloadVMTemplate }}
|
|
||||||
- label: red
|
|
||||||
- prefs:
|
|
||||||
- template: {{ DownloadVMTemplate }}
|
|
||||||
- include-in-backups: false
|
|
||||||
|
|
||||||
{% set DownloadBinary = GithubUrl ~ "/releases/download/" ~ Release ~ "/" ~ Kernel %}
|
|
||||||
{% set DownloadShasum = GithubUrl ~ "/releases/download/" ~ Release ~ "/" ~ Shasum %}
|
|
||||||
|
|
||||||
download-and-unpack-in-DownloadVM4mirage:
|
|
||||||
cmd.run:
|
|
||||||
- names:
|
|
||||||
- qvm-run --pass-io {{ DownloadVM }} {{ "curl -L -O " ~ DownloadBinary }}
|
|
||||||
- qvm-run --pass-io {{ DownloadVM }} {{ "curl -L -O " ~ DownloadShasum }}
|
|
||||||
- require:
|
|
||||||
- create-downloader-VM
|
|
||||||
|
|
||||||
|
|
||||||
check-checksum-in-DownloadVM:
|
|
||||||
cmd.run:
|
|
||||||
- names:
|
|
||||||
- qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of release on github:\\\";cat " ~ Shasum ~ " | cut -d\' \' -f1\"" }}
|
|
||||||
- qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of downloaded local file:\\\";sha256sum " ~ Kernel ~ " | cut -d\' \' -f1\"" }}
|
|
||||||
- qvm-run --pass-io {{ DownloadVM }} {{ "\"diff <(cat " ~ Shasum ~ " | cut -d\' \' -f1) <(sha256sum " ~ Kernel ~ " | cut -d\' \' -f1) && echo \\\"Checksums DO match.\\\" || (echo \\\"Checksums do NOT match.\\\";exit 101)\"" }}
|
|
||||||
- require:
|
|
||||||
- download-and-unpack-in-DownloadVM4mirage
|
|
||||||
|
|
||||||
copy-mirage-kernel-to-dom0:
|
|
||||||
cmd.run:
|
|
||||||
- name: mkdir -p {{ MirageInstallDir }}; qvm-run --pass-io --no-gui {{ DownloadVM }} {{ "cat " ~ Kernel }} > {{ MirageInstallDir ~ "/vmlinuz" }}
|
|
||||||
- require:
|
|
||||||
- download-and-unpack-in-DownloadVM4mirage
|
|
||||||
- check-checksum-in-DownloadVM
|
|
||||||
|
|
||||||
update-version:
|
|
||||||
cmd.run:
|
|
||||||
- names:
|
|
||||||
- echo {{ Release }} > {{ MirageInstallDir ~ "/version.txt" }}
|
|
||||||
- require:
|
|
||||||
- copy-mirage-kernel-to-dom0
|
|
||||||
|
|
||||||
create-sys-mirage-fw:
|
|
||||||
qvm.vm:
|
|
||||||
- name: {{ MirageFW }}
|
|
||||||
- present:
|
|
||||||
- class: StandaloneVM
|
|
||||||
- label: black
|
|
||||||
- prefs:
|
|
||||||
- kernel: mirage-firewall
|
|
||||||
- kernelopts:
|
|
||||||
- include-in-backups: False
|
|
||||||
- memory: 32
|
|
||||||
- maxmem: 32
|
|
||||||
- netvm: sys-net
|
|
||||||
- provides-network: True
|
|
||||||
- vcpus: 1
|
|
||||||
- virt-mode: pvh
|
|
||||||
- features:
|
|
||||||
- enable:
|
|
||||||
- qubes-firewall
|
|
||||||
- no-default-kernelopts
|
|
||||||
- require:
|
|
||||||
- copy-mirage-kernel-to-dom0
|
|
||||||
|
|
||||||
|
|
||||||
cleanup-in-DownloadVM:
|
|
||||||
cmd.run:
|
|
||||||
- names:
|
|
||||||
- qvm-run -a --pass-io --no-gui {{ DownloadVM }} "{{ "rm " ~ Kernel ~ " " ~ Shasum }}"
|
|
||||||
- require:
|
|
||||||
- update-version
|
|
||||||
|
|
||||||
remove-DownloadVM4mirage:
|
|
||||||
qvm.absent:
|
|
||||||
- name: {{ DownloadVM }}
|
|
||||||
- require:
|
|
||||||
- cleanup-in-DownloadVM
|
|
||||||
|
|
||||||
{% endif %}
|
|
||||||
2
_tags
Normal file
2
_tags
Normal file
|
|
@ -0,0 +1,2 @@
|
||||||
|
not <main.*>: warn(A-4), strict_sequence
|
||||||
|
<qubes_protocol.*>: package(cstruct.syntax)
|
||||||
9
build-with-docker.sh
Executable file
9
build-with-docker.sh
Executable file
|
|
@ -0,0 +1,9 @@
|
||||||
|
#!/bin/sh
|
||||||
|
set -eu
|
||||||
|
echo Building Docker image with dependencies..
|
||||||
|
docker build -t qubes-mirage-firewall .
|
||||||
|
echo Building Firewall...
|
||||||
|
docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall
|
||||||
|
echo "SHA2 of build: $(sha256sum qubes_firewall.xen)"
|
||||||
|
echo "SHA2 last known: 4f4456b5fe7c8ae1ba2f6934cf89749cf6aae9a90cce899cf744c89d311467a3"
|
||||||
|
echo "(hashes should match for released versions)"
|
||||||
|
|
@ -1,25 +0,0 @@
|
||||||
#!/bin/sh
|
|
||||||
set -eu
|
|
||||||
|
|
||||||
if [[ $# -ne 1 ]] ; then
|
|
||||||
echo "Usage: build-with.sh { docker | podman }"
|
|
||||||
exit 1
|
|
||||||
fi
|
|
||||||
|
|
||||||
builder=$1
|
|
||||||
case $builder in
|
|
||||||
docker|podman)
|
|
||||||
;;
|
|
||||||
*)
|
|
||||||
echo "You should use either docker or podman for building"
|
|
||||||
exit 2
|
|
||||||
esac
|
|
||||||
|
|
||||||
echo Building $builder image with dependencies..
|
|
||||||
$builder build -t qubes-mirage-firewall .
|
|
||||||
echo Building Firewall...
|
|
||||||
$builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall
|
|
||||||
echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen | cut -d' ' -f1)"
|
|
||||||
echo "SHA2 current head: $(cat qubes-firewall.sha256 | cut -d' ' -f1)"
|
|
||||||
echo "SHA2 last release: $(cat qubes-firewall-release.sha256 | cut -d' ' -f1)"
|
|
||||||
echo "(hashes should match for head versions)"
|
|
||||||
|
|
@ -4,7 +4,9 @@
|
||||||
type t = (unit -> unit) list ref
|
type t = (unit -> unit) list ref
|
||||||
|
|
||||||
let create () = ref []
|
let create () = ref []
|
||||||
let on_cleanup t fn = t := fn :: !t
|
|
||||||
|
let on_cleanup t fn =
|
||||||
|
t := fn :: !t
|
||||||
|
|
||||||
let cleanup t =
|
let cleanup t =
|
||||||
let tasks = !t in
|
let tasks = !t in
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,8 @@
|
||||||
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
See the README file for details. *)
|
See the README file for details. *)
|
||||||
|
|
||||||
(** Register actions to take when a resource is finished. Like [Lwt_switch], but
|
(** Register actions to take when a resource is finished.
|
||||||
synchronous. *)
|
Like [Lwt_switch], but synchronous. *)
|
||||||
|
|
||||||
type t
|
type t
|
||||||
|
|
||||||
|
|
|
||||||
138
client_eth.ml
138
client_eth.ml
|
|
@ -4,117 +4,109 @@
|
||||||
open Fw_utils
|
open Fw_utils
|
||||||
open Lwt.Infix
|
open Lwt.Infix
|
||||||
|
|
||||||
let src =
|
let src = Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients"
|
||||||
Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients"
|
|
||||||
|
|
||||||
module Log = (val Logs.src_log src : Logs.LOG)
|
module Log = (val Logs.src_log src : Logs.LOG)
|
||||||
|
|
||||||
type t = {
|
type t = {
|
||||||
mutable iface_of_ip : client_link Ipaddr.V4.Map.t;
|
mutable iface_of_ip : client_link IpMap.t;
|
||||||
changed : unit Lwt_condition.t; (* Fires when [iface_of_ip] changes. *)
|
changed : unit Lwt_condition.t; (* Fires when [iface_of_ip] changes. *)
|
||||||
my_ip : Ipaddr.V4.t;
|
client_gw : Ipaddr.V4.t; (* The IP that clients are given as their default gateway. *)
|
||||||
(* The IP that clients are given as their default gateway. *)
|
|
||||||
}
|
}
|
||||||
|
|
||||||
type host = [ `Client of client_link | `Firewall | `External of Ipaddr.t ]
|
type host =
|
||||||
|
[ `Client of client_link
|
||||||
|
| `Firewall
|
||||||
|
| `External of Ipaddr.t ]
|
||||||
|
|
||||||
let create config =
|
let create ~client_gw =
|
||||||
let changed = Lwt_condition.create () in
|
let changed = Lwt_condition.create () in
|
||||||
let my_ip = config.Dao.our_ip in
|
{ iface_of_ip = IpMap.empty; client_gw; changed }
|
||||||
Lwt.return { iface_of_ip = Ipaddr.V4.Map.empty; my_ip; changed }
|
|
||||||
|
|
||||||
let client_gw t = t.my_ip
|
let client_gw t = t.client_gw
|
||||||
|
|
||||||
let add_client t iface =
|
let add_client t iface =
|
||||||
let ip = iface#other_ip in
|
let ip = iface#other_ip in
|
||||||
let rec aux () =
|
let rec aux () =
|
||||||
match Ipaddr.V4.Map.find_opt ip t.iface_of_ip with
|
match IpMap.find ip t.iface_of_ip with
|
||||||
| Some old ->
|
| Some old ->
|
||||||
(* Wait for old client to disappear before adding one with the same IP address.
|
(* Wait for old client to disappear before adding one with the same IP address.
|
||||||
Otherwise, its [remove_client] call will remove the new client instead. *)
|
Otherwise, its [remove_client] call will remove the new client instead. *)
|
||||||
Log.info (fun f ->
|
Log.info (fun f -> f ~header:iface#log_header "Waiting for old client %s to go away before accepting new one" old#log_header);
|
||||||
f ~header:iface#log_header
|
Lwt_condition.wait t.changed >>= aux
|
||||||
"Waiting for old client %s to go away before accepting new one"
|
|
||||||
old#log_header);
|
|
||||||
Lwt_condition.wait t.changed >>= aux
|
|
||||||
| None ->
|
| None ->
|
||||||
t.iface_of_ip <- t.iface_of_ip |> Ipaddr.V4.Map.add ip iface;
|
t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface;
|
||||||
Lwt_condition.broadcast t.changed ();
|
Lwt_condition.broadcast t.changed ();
|
||||||
Lwt.return_unit
|
Lwt.return_unit
|
||||||
in
|
in
|
||||||
aux ()
|
aux ()
|
||||||
|
|
||||||
let remove_client t iface =
|
let remove_client t iface =
|
||||||
let ip = iface#other_ip in
|
let ip = iface#other_ip in
|
||||||
assert (Ipaddr.V4.Map.mem ip t.iface_of_ip);
|
assert (IpMap.mem ip t.iface_of_ip);
|
||||||
t.iface_of_ip <- t.iface_of_ip |> Ipaddr.V4.Map.remove ip;
|
t.iface_of_ip <- t.iface_of_ip |> IpMap.remove ip;
|
||||||
Lwt_condition.broadcast t.changed ()
|
Lwt_condition.broadcast t.changed ()
|
||||||
|
|
||||||
let lookup t ip = Ipaddr.V4.Map.find_opt ip t.iface_of_ip
|
let lookup t ip = IpMap.find ip t.iface_of_ip
|
||||||
|
|
||||||
let classify t ip =
|
let classify t ip =
|
||||||
match ip with
|
match ip with
|
||||||
| Ipaddr.V6 _ -> `External ip
|
| Ipaddr.V6 _ -> `External ip
|
||||||
| Ipaddr.V4 ip4 -> (
|
| Ipaddr.V4 ip4 ->
|
||||||
if ip4 = t.my_ip then `Firewall
|
if ip4 = t.client_gw then `Firewall
|
||||||
else
|
else match lookup t ip4 with
|
||||||
match lookup t ip4 with
|
| Some client_link -> `Client client_link
|
||||||
| Some client_link -> `Client client_link
|
| None -> `External ip
|
||||||
| None -> `External ip)
|
|
||||||
|
|
||||||
let resolve t : host -> Ipaddr.t = function
|
let resolve t : host -> Ipaddr.t = function
|
||||||
| `Client client_link -> Ipaddr.V4 client_link#other_ip
|
| `Client client_link -> Ipaddr.V4 client_link#other_ip
|
||||||
| `Firewall -> Ipaddr.V4 t.my_ip
|
| `Firewall -> Ipaddr.V4 t.client_gw
|
||||||
| `External addr -> addr
|
| `External addr -> addr
|
||||||
|
|
||||||
module ARP = struct
|
module ARP = struct
|
||||||
type arp = { net : t; client_link : client_link }
|
type arp = {
|
||||||
|
net : t;
|
||||||
|
client_link : client_link;
|
||||||
|
}
|
||||||
|
|
||||||
let lookup t ip =
|
let lookup t ip =
|
||||||
if ip = t.net.my_ip then Some t.client_link#my_mac
|
if ip = t.net.client_gw then Some t.client_link#my_mac
|
||||||
else if (Ipaddr.V4.to_octets ip).[3] = '\x01' then (
|
else if (Ipaddr.V4.to_octets ip).[3] = '\x01' then (
|
||||||
Log.info (fun f ->
|
Log.info (fun f -> f ~header:t.client_link#log_header
|
||||||
f ~header:t.client_link#log_header
|
"Request for %a is invalid, but pretending it's me (see Qubes issue #5022)" Ipaddr.V4.pp ip);
|
||||||
"Request for %a is invalid, but pretending it's me (see Qubes \
|
Some t.client_link#my_mac
|
||||||
issue #5022)"
|
) else None
|
||||||
Ipaddr.V4.pp ip);
|
|
||||||
Some t.client_link#my_mac)
|
|
||||||
else None
|
|
||||||
(* We're now treating client networks as point-to-point links,
|
(* We're now treating client networks as point-to-point links,
|
||||||
so we no longer respond on behalf of other clients. *)
|
so we no longer respond on behalf of other clients. *)
|
||||||
(*
|
(*
|
||||||
else match Ipaddr.V4.Map.find_opt ip t.net.iface_of_ip with
|
else match IpMap.find ip t.net.iface_of_ip with
|
||||||
| Some client_iface -> Some client_iface#other_mac
|
| Some client_iface -> Some client_iface#other_mac
|
||||||
| None -> None
|
| None -> None
|
||||||
*)
|
*)
|
||||||
|
|
||||||
let create ~net client_link = { net; client_link }
|
let create ~net client_link = {net; client_link}
|
||||||
|
|
||||||
let input_query t arp =
|
let input_query t arp =
|
||||||
let req_ipv4 = arp.Arp_packet.target_ip in
|
let req_ipv4 = arp.Arp_packet.target_ip in
|
||||||
let pf (f : ?header:string -> ?tags:_ -> _) fmt =
|
let pf (f : ?header:string -> ?tags:_ -> _) fmt =
|
||||||
f ~header:t.client_link#log_header ("who-has %a? " ^^ fmt) Ipaddr.V4.pp
|
f ~header:t.client_link#log_header ("who-has %a? " ^^ fmt) Ipaddr.V4.pp req_ipv4
|
||||||
req_ipv4
|
|
||||||
in
|
in
|
||||||
if req_ipv4 = t.client_link#other_ip then (
|
if req_ipv4 = t.client_link#other_ip then (
|
||||||
Log.info (fun f -> pf f "ignoring request for client's own IP");
|
Log.info (fun f -> pf f "ignoring request for client's own IP");
|
||||||
None)
|
None
|
||||||
else
|
) else match lookup t req_ipv4 with
|
||||||
match lookup t req_ipv4 with
|
|
||||||
| None ->
|
| None ->
|
||||||
Log.info (fun f -> pf f "unknown address; not responding");
|
Log.info (fun f -> pf f "unknown address; not responding");
|
||||||
None
|
None
|
||||||
| Some req_mac ->
|
| Some req_mac ->
|
||||||
Log.info (fun f -> pf f "responding with %a" Macaddr.pp req_mac);
|
Log.info (fun f -> pf f "responding with %a" Macaddr.pp req_mac);
|
||||||
Some
|
Some { Arp_packet.
|
||||||
{
|
operation = Arp_packet.Reply;
|
||||||
Arp_packet.operation = Arp_packet.Reply;
|
(* The Target Hardware Address and IP are copied from the request *)
|
||||||
(* The Target Hardware Address and IP are copied from the request *)
|
target_ip = arp.Arp_packet.source_ip;
|
||||||
target_ip = arp.Arp_packet.source_ip;
|
target_mac = arp.Arp_packet.source_mac;
|
||||||
target_mac = arp.Arp_packet.source_mac;
|
source_ip = req_ipv4;
|
||||||
source_ip = req_ipv4;
|
source_mac = req_mac;
|
||||||
source_mac = req_mac;
|
}
|
||||||
}
|
|
||||||
|
|
||||||
let input_gratuitous t arp =
|
let input_gratuitous t arp =
|
||||||
let source_ip = arp.Arp_packet.source_ip in
|
let source_ip = arp.Arp_packet.source_ip in
|
||||||
|
|
@ -122,28 +114,18 @@ module ARP = struct
|
||||||
let header = t.client_link#log_header in
|
let header = t.client_link#log_header in
|
||||||
match lookup t source_ip with
|
match lookup t source_ip with
|
||||||
| Some real_mac when Macaddr.compare source_mac real_mac = 0 ->
|
| Some real_mac when Macaddr.compare source_mac real_mac = 0 ->
|
||||||
Log.info (fun f ->
|
Log.info (fun f -> f ~header "client suggests updating %s -> %s (as expected)"
|
||||||
f ~header "client suggests updating %s -> %s (as expected)"
|
(Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac));
|
||||||
(Ipaddr.V4.to_string source_ip)
|
|
||||||
(Macaddr.to_string source_mac))
|
|
||||||
| Some other_mac ->
|
| Some other_mac ->
|
||||||
Log.warn (fun f ->
|
Log.warn (fun f -> f ~header "client suggests incorrect update %s -> %s (should be %s)"
|
||||||
f ~header "client suggests incorrect update %s -> %s (should be %s)"
|
(Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac) (Macaddr.to_string other_mac));
|
||||||
(Ipaddr.V4.to_string source_ip)
|
|
||||||
(Macaddr.to_string source_mac)
|
|
||||||
(Macaddr.to_string other_mac))
|
|
||||||
| None ->
|
| None ->
|
||||||
Log.warn (fun f ->
|
Log.warn (fun f -> f ~header "client suggests incorrect update %s -> %s (unexpected IP)"
|
||||||
f ~header
|
(Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac))
|
||||||
"client suggests incorrect update %s -> %s (unexpected IP)"
|
|
||||||
(Ipaddr.V4.to_string source_ip)
|
|
||||||
(Macaddr.to_string source_mac))
|
|
||||||
|
|
||||||
let input t arp =
|
let input t arp =
|
||||||
let op = arp.Arp_packet.operation in
|
let op = arp.Arp_packet.operation in
|
||||||
match op with
|
match op with
|
||||||
| Arp_packet.Request -> input_query t arp
|
| Arp_packet.Request -> input_query t arp
|
||||||
| Arp_packet.Reply ->
|
| Arp_packet.Reply -> input_gratuitous t arp; None
|
||||||
input_gratuitous t arp;
|
|
||||||
None
|
|
||||||
end
|
end
|
||||||
|
|
|
||||||
|
|
@ -1,32 +1,34 @@
|
||||||
(* Copyright (C) 2016, Thomas Leonard <thomas.leonard@unikernel.com>
|
(* Copyright (C) 2016, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
See the README file for details. *)
|
See the README file for details. *)
|
||||||
|
|
||||||
(** The ethernet networks connecting us to our client AppVMs. Note: each AppVM
|
(** The ethernet networks connecting us to our client AppVMs.
|
||||||
is on a point-to-point link, each link being considered to be a separate
|
Note: each AppVM is on a point-to-point link, each link being considered to be a separate Ethernet network. *)
|
||||||
Ethernet network. *)
|
|
||||||
|
|
||||||
open Fw_utils
|
open Fw_utils
|
||||||
|
|
||||||
type t
|
type t
|
||||||
(** A collection of clients. *)
|
(** A collection of clients. *)
|
||||||
|
|
||||||
type host = [ `Client of client_link | `Firewall | `External of Ipaddr.t ]
|
type host =
|
||||||
|
[ `Client of client_link
|
||||||
|
| `Firewall
|
||||||
|
| `External of Ipaddr.t ]
|
||||||
(* Note: Qubes does not allow us to distinguish between an external address and a
|
(* Note: Qubes does not allow us to distinguish between an external address and a
|
||||||
disconnected client.
|
disconnected client.
|
||||||
See: https://github.com/talex5/qubes-mirage-firewall/issues/9#issuecomment-246956850 *)
|
See: https://github.com/talex5/qubes-mirage-firewall/issues/9#issuecomment-246956850 *)
|
||||||
|
|
||||||
val create : Dao.network_config -> t Lwt.t
|
val create : client_gw:Ipaddr.V4.t -> t
|
||||||
(** [create ~client_gw] is a network of client machines. Qubes will have
|
(** [create ~client_gw] is a network of client machines.
|
||||||
configured the client machines to use [client_gw] as their default gateway.
|
Qubes will have configured the client machines to use [client_gw] as their default gateway. *)
|
||||||
*)
|
|
||||||
|
|
||||||
val add_client : t -> client_link -> unit Lwt.t
|
val add_client : t -> client_link -> unit Lwt.t
|
||||||
(** [add_client t client] registers a new client. If a client with this IP
|
(** [add_client t client] registers a new client. If a client with this IP address is already registered,
|
||||||
address is already registered, it waits for [remove_client] to be called on
|
it waits for [remove_client] to be called on that before adding the new client and returning. *)
|
||||||
that before adding the new client and returning. *)
|
|
||||||
|
|
||||||
val remove_client : t -> client_link -> unit
|
val remove_client : t -> client_link -> unit
|
||||||
|
|
||||||
val client_gw : t -> Ipaddr.V4.t
|
val client_gw : t -> Ipaddr.V4.t
|
||||||
|
|
||||||
val classify : t -> Ipaddr.t -> host
|
val classify : t -> Ipaddr.t -> host
|
||||||
val resolve : t -> host -> Ipaddr.t
|
val resolve : t -> host -> Ipaddr.t
|
||||||
|
|
||||||
|
|
@ -34,18 +36,18 @@ val lookup : t -> Ipaddr.V4.t -> client_link option
|
||||||
(** [lookup t addr] is the client with IP address [addr], if connected. *)
|
(** [lookup t addr] is the client with IP address [addr], if connected. *)
|
||||||
|
|
||||||
module ARP : sig
|
module ARP : sig
|
||||||
(** We already know the correct mapping of IP addresses to MAC addresses, so
|
(** We already know the correct mapping of IP addresses to MAC addresses, so we never
|
||||||
we never allow clients to update it. We log a warning if a client attempts
|
allow clients to update it. We log a warning if a client attempts to set incorrect
|
||||||
to set incorrect information. *)
|
information. *)
|
||||||
|
|
||||||
type arp
|
type arp
|
||||||
(** An ARP-responder for one client. *)
|
(** An ARP-responder for one client. *)
|
||||||
|
|
||||||
val create : net:t -> client_link -> arp
|
val create : net:t -> client_link -> arp
|
||||||
(** [create ~net client_link] is an ARP responder for [client_link]. It
|
(** [create ~net client_link] is an ARP responder for [client_link].
|
||||||
answers only for the client's gateway address. *)
|
It answers only for the client's gateway address. *)
|
||||||
|
|
||||||
val input : arp -> Arp_packet.t -> Arp_packet.t option
|
val input : arp -> Arp_packet.t -> Arp_packet.t option
|
||||||
(** Process one ethernet frame containing an ARP message. Returns a response
|
(** Process one ethernet frame containing an ARP message.
|
||||||
frame, if one is needed. *)
|
Returns a response frame, if one is needed. *)
|
||||||
end
|
end
|
||||||
|
|
|
||||||
170
client_net.ml
Normal file
170
client_net.ml
Normal file
|
|
@ -0,0 +1,170 @@
|
||||||
|
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
|
See the README file for details. *)
|
||||||
|
|
||||||
|
open Lwt.Infix
|
||||||
|
open Fw_utils
|
||||||
|
|
||||||
|
module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs))
|
||||||
|
module ClientEth = Ethernet.Make(Netback)
|
||||||
|
|
||||||
|
let src = Logs.Src.create "client_net" ~doc:"Client networking"
|
||||||
|
module Log = (val Logs.src_log src : Logs.LOG)
|
||||||
|
|
||||||
|
let writev eth dst proto fillfn =
|
||||||
|
Lwt.catch
|
||||||
|
(fun () ->
|
||||||
|
ClientEth.write eth dst proto fillfn >|= function
|
||||||
|
| Ok () -> ()
|
||||||
|
| Error e ->
|
||||||
|
Log.err (fun f -> f "error trying to send to client: @[%a@]"
|
||||||
|
ClientEth.pp_error e);
|
||||||
|
)
|
||||||
|
(fun ex ->
|
||||||
|
(* Usually Netback_shutdown, because the client disconnected *)
|
||||||
|
Log.err (fun f -> f "uncaught exception trying to send to client: @[%s@]"
|
||||||
|
(Printexc.to_string ex));
|
||||||
|
Lwt.return_unit
|
||||||
|
)
|
||||||
|
|
||||||
|
class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link =
|
||||||
|
let log_header = Fmt.strf "dom%d:%a" domid Ipaddr.V4.pp client_ip in
|
||||||
|
object
|
||||||
|
val queue = FrameQ.create (Ipaddr.V4.to_string client_ip)
|
||||||
|
val mutable rules = []
|
||||||
|
method get_rules = rules
|
||||||
|
method set_rules new_db = rules <- Dao.read_rules new_db client_ip
|
||||||
|
method my_mac = ClientEth.mac eth
|
||||||
|
method other_mac = client_mac
|
||||||
|
method my_ip = gateway_ip
|
||||||
|
method other_ip = client_ip
|
||||||
|
method writev proto fillfn =
|
||||||
|
FrameQ.send queue (fun () ->
|
||||||
|
writev eth client_mac proto fillfn
|
||||||
|
)
|
||||||
|
method log_header = log_header
|
||||||
|
end
|
||||||
|
|
||||||
|
let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty
|
||||||
|
|
||||||
|
(** Handle an ARP message from the client. *)
|
||||||
|
let input_arp ~fixed_arp ~iface request =
|
||||||
|
match Arp_packet.decode request with
|
||||||
|
| Error e ->
|
||||||
|
Log.warn (fun f -> f "Ignored unknown ARP message: %a" Arp_packet.pp_error e);
|
||||||
|
Lwt.return_unit
|
||||||
|
| Ok arp ->
|
||||||
|
match Client_eth.ARP.input fixed_arp arp with
|
||||||
|
| None -> Lwt.return_unit
|
||||||
|
| Some response ->
|
||||||
|
iface#writev `ARP (fun b -> Arp_packet.encode_into response b; Arp_packet.size)
|
||||||
|
|
||||||
|
(** Handle an IPv4 packet from the client. *)
|
||||||
|
let input_ipv4 get_ts cache ~iface ~router dns_client packet =
|
||||||
|
let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in
|
||||||
|
cache := cache';
|
||||||
|
match r with
|
||||||
|
| Error e ->
|
||||||
|
Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e);
|
||||||
|
Lwt.return_unit
|
||||||
|
| Ok None -> Lwt.return_unit
|
||||||
|
| Ok (Some packet) ->
|
||||||
|
let `IPv4 (ip, _) = packet in
|
||||||
|
let src = ip.Ipv4_packet.src in
|
||||||
|
if src = iface#other_ip then Firewall.ipv4_from_client dns_client router ~src:iface packet
|
||||||
|
else (
|
||||||
|
Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)"
|
||||||
|
Ipaddr.V4.pp src Ipaddr.V4.pp iface#other_ip);
|
||||||
|
Lwt.return_unit
|
||||||
|
)
|
||||||
|
|
||||||
|
(** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *)
|
||||||
|
let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client ~client_ip ~router ~cleanup_tasks qubesDB =
|
||||||
|
Netback.make ~domid ~device_id >>= fun backend ->
|
||||||
|
Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip));
|
||||||
|
ClientEth.connect backend >>= fun eth ->
|
||||||
|
let client_mac = Netback.frontend_mac backend in
|
||||||
|
let client_eth = router.Router.client_eth in
|
||||||
|
let gateway_ip = Client_eth.client_gw client_eth in
|
||||||
|
let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in
|
||||||
|
(* update the rules whenever QubesDB notices a change for this IP *)
|
||||||
|
let qubesdb_updater =
|
||||||
|
Lwt.catch
|
||||||
|
(fun () ->
|
||||||
|
let rec update current_db current_rules =
|
||||||
|
Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db >>= fun new_db ->
|
||||||
|
iface#set_rules new_db;
|
||||||
|
let new_rules = iface#get_rules in
|
||||||
|
(if current_rules = new_rules then
|
||||||
|
Log.debug (fun m -> m "Rules did not change for %s" (Ipaddr.V4.to_string client_ip))
|
||||||
|
else begin
|
||||||
|
Log.debug (fun m -> m "New firewall rules for %s@.%a"
|
||||||
|
(Ipaddr.V4.to_string client_ip)
|
||||||
|
Fmt.(list ~sep:(unit "@.") Pf_qubes.Parse_qubes.pp_rule) new_rules);
|
||||||
|
(* empty NAT table if rules are updated: they might deny old connections *)
|
||||||
|
My_nat.remove_connections router.Router.nat router.Router.ports client_ip;
|
||||||
|
end);
|
||||||
|
update new_db new_rules
|
||||||
|
in
|
||||||
|
update Qubes.DB.KeyMap.empty [])
|
||||||
|
(function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e)
|
||||||
|
in
|
||||||
|
Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater);
|
||||||
|
Router.add_client router iface >>= fun () ->
|
||||||
|
Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
|
||||||
|
let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in
|
||||||
|
let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in
|
||||||
|
let listener =
|
||||||
|
Lwt.catch
|
||||||
|
(fun () ->
|
||||||
|
Netback.listen backend ~header_size:Ethernet_wire.sizeof_ethernet (fun frame ->
|
||||||
|
match Ethernet_packet.Unmarshal.of_cstruct frame with
|
||||||
|
| Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit
|
||||||
|
| Ok (eth, payload) ->
|
||||||
|
match eth.Ethernet_packet.ethertype with
|
||||||
|
| `ARP -> input_arp ~fixed_arp ~iface payload
|
||||||
|
| `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router dns_client payload
|
||||||
|
| `IPv6 -> Lwt.return_unit (* TODO: oh no! *)
|
||||||
|
)
|
||||||
|
>|= or_raise "Listen on client interface" Netback.pp_error)
|
||||||
|
(function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e)
|
||||||
|
in
|
||||||
|
Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener);
|
||||||
|
Lwt.pick [ qubesdb_updater ; listener ]
|
||||||
|
|
||||||
|
(** A new client VM has been found in XenStore. Find its interface and connect to it. *)
|
||||||
|
let add_client get_ts dns_client ~router vif client_ip qubesDB =
|
||||||
|
let cleanup_tasks = Cleanup.create () in
|
||||||
|
Log.info (fun f -> f "add client vif %a with IP %a"
|
||||||
|
Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip);
|
||||||
|
Lwt.async (fun () ->
|
||||||
|
Lwt.catch (fun () ->
|
||||||
|
add_vif get_ts vif dns_client ~client_ip ~router ~cleanup_tasks qubesDB
|
||||||
|
)
|
||||||
|
(fun ex ->
|
||||||
|
Log.warn (fun f -> f "Error with client %a: %s"
|
||||||
|
Dao.ClientVif.pp vif (Printexc.to_string ex));
|
||||||
|
Lwt.return_unit
|
||||||
|
)
|
||||||
|
);
|
||||||
|
cleanup_tasks
|
||||||
|
|
||||||
|
(** Watch XenStore for notifications of new clients. *)
|
||||||
|
let listen get_ts dns_client qubesDB router =
|
||||||
|
Dao.watch_clients (fun new_set ->
|
||||||
|
(* Check for removed clients *)
|
||||||
|
!clients |> Dao.VifMap.iter (fun key cleanup ->
|
||||||
|
if not (Dao.VifMap.mem key new_set) then (
|
||||||
|
clients := !clients |> Dao.VifMap.remove key;
|
||||||
|
Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key);
|
||||||
|
Cleanup.cleanup cleanup
|
||||||
|
)
|
||||||
|
);
|
||||||
|
(* Check for added clients *)
|
||||||
|
new_set |> Dao.VifMap.iter (fun key ip_addr ->
|
||||||
|
if not (Dao.VifMap.mem key !clients) then (
|
||||||
|
let cleanup = add_client get_ts dns_client ~router key ip_addr qubesDB in
|
||||||
|
Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key);
|
||||||
|
clients := !clients |> Dao.VifMap.add key cleanup
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
12
client_net.mli
Normal file
12
client_net.mli
Normal file
|
|
@ -0,0 +1,12 @@
|
||||||
|
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
|
See the README file for details. *)
|
||||||
|
|
||||||
|
(** Handling client VMs. *)
|
||||||
|
|
||||||
|
val listen : (unit -> int64) ->
|
||||||
|
([ `host ] Domain_name.t -> (int32 * Dns.Rr_map.Ipv4_set.t, [> `Msg of string ]) result Lwt.t) ->
|
||||||
|
Qubes.DB.t -> Router.t -> 'a Lwt.t
|
||||||
|
(** [listen get_timestamp resolver db router] is a thread that watches for clients being added to and
|
||||||
|
removed from XenStore. Clients are connected to the client network and
|
||||||
|
packets are sent via [router]. We ensure the source IP address is correct
|
||||||
|
before routing a packet. *)
|
||||||
20
command.ml
20
command.ml
|
|
@ -4,30 +4,24 @@
|
||||||
(** Commands we provide via qvm-run. *)
|
(** Commands we provide via qvm-run. *)
|
||||||
|
|
||||||
open Lwt
|
open Lwt
|
||||||
|
|
||||||
module Flow = Qubes.RExec.Flow
|
module Flow = Qubes.RExec.Flow
|
||||||
|
|
||||||
let src = Logs.Src.create "command" ~doc:"qrexec command handler"
|
let src = Logs.Src.create "command" ~doc:"qrexec command handler"
|
||||||
|
|
||||||
module Log = (val Logs.src_log src : Logs.LOG)
|
module Log = (val Logs.src_log src : Logs.LOG)
|
||||||
|
|
||||||
let set_date_time flow =
|
let set_date_time flow =
|
||||||
Flow.read_line flow >|= function
|
Flow.read_line flow >|= function
|
||||||
| `Eof ->
|
| `Eof -> Log.warn (fun f -> f "EOF reading time from dom0"); 1
|
||||||
Log.warn (fun f -> f "EOF reading time from dom0");
|
| `Ok line -> Log.info (fun f -> f "TODO: set time to %S" line); 0
|
||||||
1
|
|
||||||
| `Ok line ->
|
|
||||||
Log.info (fun f -> f "TODO: set time to %S" line);
|
|
||||||
0
|
|
||||||
|
|
||||||
let handler ~user:_ cmd flow =
|
let handler ~user:_ cmd flow =
|
||||||
(* Write a message to the client and return an exit status of 1. *)
|
(* Write a message to the client and return an exit status of 1. *)
|
||||||
let error fmt =
|
let error fmt =
|
||||||
fmt
|
fmt |> Printf.ksprintf @@ fun s ->
|
||||||
|> Printf.ksprintf @@ fun s ->
|
Log.warn (fun f -> f "<< %s" s);
|
||||||
Log.warn (fun f -> f "<< %s" s);
|
Flow.ewritef flow "%s [while processing %S]" s cmd >|= fun () -> 1 in
|
||||||
Flow.ewritef flow "%s [while processing %S]" s cmd >|= fun () -> 1
|
|
||||||
in
|
|
||||||
match cmd with
|
match cmd with
|
||||||
| "QUBESRPC qubes.SetDateTime dom0" -> set_date_time flow
|
| "QUBESRPC qubes.SetDateTime dom0" -> set_date_time flow
|
||||||
| "QUBESRPC qubes.WaitForSession none" -> return 0 (* Always ready! *)
|
| "QUBESRPC qubes.WaitForSession none" -> return 0 (* Always ready! *)
|
||||||
| cmd -> error "Unknown command %S" cmd
|
| cmd -> error "Unknown command %S" cmd
|
||||||
|
|
|
||||||
58
config.ml
58
config.ml
|
|
@ -1,4 +1,3 @@
|
||||||
(* mirage >= 4.9.0 & < 4.10.0 *)
|
|
||||||
(* Copyright (C) 2017, Thomas Leonard <thomas.leonard@unikernel.com>
|
(* Copyright (C) 2017, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
See the README file for details. *)
|
See the README file for details. *)
|
||||||
|
|
||||||
|
|
@ -6,25 +5,40 @@
|
||||||
|
|
||||||
open Mirage
|
open Mirage
|
||||||
|
|
||||||
let main =
|
let table_size =
|
||||||
main
|
let open Functoria_key in
|
||||||
~packages:
|
let info = Arg.info
|
||||||
[
|
~doc:"The number of NAT entries to allocate."
|
||||||
package "vchan" ~min:"4.0.2";
|
~docv:"ENTRIES" ["nat-table-size"]
|
||||||
package "cstruct";
|
in
|
||||||
package "tcpip" ~min:"3.7.0";
|
let key = Arg.opt ~stage:`Both Arg.int 5_000 info in
|
||||||
package ~min:"2.3.0" ~sublibs:[ "mirage" ] "arp";
|
create "nat_table_size" key
|
||||||
package ~min:"3.0.0" "ethernet";
|
|
||||||
package "shared-memory-ring" ~min:"3.0.0";
|
|
||||||
package "mirage-net-xen" ~min:"2.1.4";
|
|
||||||
package "ipaddr" ~min:"5.2.0";
|
|
||||||
package "mirage-qubes" ~min:"0.9.1";
|
|
||||||
package ~min:"3.0.1" "mirage-nat";
|
|
||||||
package "mirage-logs";
|
|
||||||
package "mirage-xen" ~min:"8.0.0";
|
|
||||||
package ~min:"6.4.0" "dns-client";
|
|
||||||
package "pf-qubes";
|
|
||||||
]
|
|
||||||
"Unikernel" job
|
|
||||||
|
|
||||||
let () = register "qubes-firewall" [ main ]
|
let main =
|
||||||
|
foreign
|
||||||
|
~keys:[Functoria_key.abstract table_size]
|
||||||
|
~packages:[
|
||||||
|
package "vchan" ~min:"4.0.2";
|
||||||
|
package "cstruct";
|
||||||
|
package "astring";
|
||||||
|
package "tcpip" ~min:"3.7.0";
|
||||||
|
package "arp";
|
||||||
|
package "arp-mirage";
|
||||||
|
package "ethernet";
|
||||||
|
package "mirage-protocols";
|
||||||
|
package "shared-memory-ring" ~min:"3.0.0";
|
||||||
|
package "netchannel" ~min:"1.11.0";
|
||||||
|
package "mirage-net-xen";
|
||||||
|
package "ipaddr" ~min:"4.0.0";
|
||||||
|
package "mirage-qubes" ~min:"0.8.2";
|
||||||
|
package "mirage-nat" ~min:"2.2.1";
|
||||||
|
package "mirage-logs";
|
||||||
|
package "mirage-xen" ~min:"5.0.0";
|
||||||
|
package ~min:"4.5.0" "dns-client";
|
||||||
|
package "pf-qubes";
|
||||||
|
]
|
||||||
|
"Unikernel.Main" (random @-> mclock @-> job)
|
||||||
|
|
||||||
|
let () =
|
||||||
|
register "qubes-firewall" [main $ default_random $ default_monotonic_clock]
|
||||||
|
~argv:no_argv
|
||||||
|
|
|
||||||
206
dao.ml
206
dao.ml
|
|
@ -3,36 +3,38 @@
|
||||||
|
|
||||||
open Lwt.Infix
|
open Lwt.Infix
|
||||||
open Qubes
|
open Qubes
|
||||||
|
open Astring
|
||||||
|
|
||||||
let src = Logs.Src.create "dao" ~doc:"QubesDB data access"
|
let src = Logs.Src.create "dao" ~doc:"QubesDB data access"
|
||||||
|
|
||||||
module Log = (val Logs.src_log src : Logs.LOG)
|
module Log = (val Logs.src_log src : Logs.LOG)
|
||||||
|
|
||||||
module ClientVif = struct
|
module ClientVif = struct
|
||||||
type t = { domid : int; device_id : int }
|
type t = {
|
||||||
|
domid : int;
|
||||||
|
device_id : int;
|
||||||
|
}
|
||||||
|
|
||||||
let pp f { domid; device_id } =
|
let pp f { domid; device_id } = Fmt.pf f "{domid=%d;device_id=%d}" domid device_id
|
||||||
Fmt.pf f "{domid=%d;device_id=%d}" domid device_id
|
|
||||||
|
|
||||||
let compare = compare
|
let compare = compare
|
||||||
end
|
end
|
||||||
|
|
||||||
module VifMap = struct
|
module VifMap = struct
|
||||||
include Map.Make (ClientVif)
|
include Map.Make(ClientVif)
|
||||||
|
|
||||||
let rec of_list = function
|
let rec of_list = function
|
||||||
| [] -> empty
|
| [] -> empty
|
||||||
| (k, v) :: rest -> add k v (of_list rest)
|
| (k, v) :: rest -> add k v (of_list rest)
|
||||||
|
let find key t =
|
||||||
let find key t = try Some (find key t) with Not_found -> None
|
try Some (find key t)
|
||||||
|
with Not_found -> None
|
||||||
end
|
end
|
||||||
|
|
||||||
let directory ~handle dir =
|
let directory ~handle dir =
|
||||||
Xen_os.Xs.directory handle dir >|= function
|
OS.Xs.directory handle dir >|= function
|
||||||
| [ "" ] -> [] (* XenStore client bug *)
|
| [""] -> [] (* XenStore client bug *)
|
||||||
| items -> items
|
| items -> items
|
||||||
|
|
||||||
let db_root client_ip = "/qubes-firewall/" ^ Ipaddr.V4.to_string client_ip
|
let db_root client_ip =
|
||||||
|
"/qubes-firewall/" ^ (Ipaddr.V4.to_string client_ip)
|
||||||
|
|
||||||
let read_rules rules client_ip =
|
let read_rules rules client_ip =
|
||||||
let root = db_root client_ip in
|
let root = db_root client_ip in
|
||||||
|
|
@ -41,141 +43,105 @@ let read_rules rules client_ip =
|
||||||
Log.debug (fun f -> f "reading %s" pattern);
|
Log.debug (fun f -> f "reading %s" pattern);
|
||||||
match Qubes.DB.KeyMap.find_opt pattern rules with
|
match Qubes.DB.KeyMap.find_opt pattern rules with
|
||||||
| None ->
|
| None ->
|
||||||
Log.debug (fun f -> f "rule %d does not exist; won't look for more" n);
|
Log.debug (fun f -> f "rule %d does not exist; won't look for more" n);
|
||||||
Ok (List.rev l)
|
Ok (List.rev l)
|
||||||
| Some rule -> (
|
| Some rule ->
|
||||||
Log.debug (fun f -> f "rule %d: %s" n rule);
|
Log.debug (fun f -> f "rule %d: %s" n rule);
|
||||||
match Pf_qubes.Parse_qubes.parse_qubes ~number:n rule with
|
match Pf_qubes.Parse_qubes.parse_qubes ~number:n rule with
|
||||||
| Error e ->
|
| Error e -> Log.warn (fun f -> f "Error parsing rule %d: %s" n e); Error e
|
||||||
Log.warn (fun f -> f "Error parsing rule %d: %s" n e);
|
| Ok rule ->
|
||||||
Error e
|
Log.debug (fun f -> f "parsed rule: %a" Pf_qubes.Parse_qubes.pp_rule rule);
|
||||||
| Ok rule ->
|
get_rule (n+1) (rule :: l)
|
||||||
Log.debug (fun f ->
|
|
||||||
f "parsed rule: %a" Pf_qubes.Parse_qubes.pp_rule rule);
|
|
||||||
get_rule (n + 1) (rule :: l))
|
|
||||||
in
|
in
|
||||||
match get_rule 0 [] with
|
match get_rule 0 [] with
|
||||||
| Ok l -> l
|
| Ok l -> l
|
||||||
| Error e ->
|
| Error e ->
|
||||||
Log.warn (fun f ->
|
Log.warn (fun f -> f "Defaulting to deny-all because of rule parse failure (%s)" e);
|
||||||
f "Defaulting to deny-all because of rule parse failure (%s)" e);
|
[ Pf_qubes.Parse_qubes.({action = Drop;
|
||||||
[
|
proto = None;
|
||||||
Pf_qubes.Parse_qubes.
|
specialtarget = None;
|
||||||
{
|
dst = `any;
|
||||||
action = Drop;
|
dstports = None;
|
||||||
proto = None;
|
icmp_type = None;
|
||||||
specialtarget = None;
|
number = 0;})]
|
||||||
dst = `any;
|
|
||||||
dstports = None;
|
|
||||||
icmp_type = None;
|
|
||||||
number = 0;
|
|
||||||
};
|
|
||||||
]
|
|
||||||
|
|
||||||
let vifs client domid =
|
let vifs ~handle domid =
|
||||||
let open Lwt.Syntax in
|
match String.to_int domid with
|
||||||
match int_of_string_opt domid with
|
| None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return []
|
||||||
| None ->
|
|
||||||
Log.err (fun f -> f "Invalid domid %S" domid);
|
|
||||||
Lwt.return []
|
|
||||||
| Some domid ->
|
| Some domid ->
|
||||||
let path = Fmt.str "backend/vif/%d" domid in
|
let path = Printf.sprintf "backend/vif/%d" domid in
|
||||||
let vifs_of_domain handle =
|
directory ~handle path >>=
|
||||||
let* devices = directory ~handle path in
|
Lwt_list.filter_map_p (fun device_id ->
|
||||||
let ip_of_vif device_id =
|
match String.to_int device_id with
|
||||||
match int_of_string_opt device_id with
|
| None -> Log.err (fun f -> f "Invalid device ID %S for domid %d" device_id domid); Lwt.return_none
|
||||||
| None ->
|
| Some device_id ->
|
||||||
Log.err (fun f ->
|
let vif = { ClientVif.domid; device_id } in
|
||||||
f "Invalid device ID %S for domid %d" device_id domid);
|
Lwt.try_bind
|
||||||
Lwt.return_none
|
(fun () -> OS.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id))
|
||||||
| Some device_id -> (
|
(fun client_ip ->
|
||||||
let vif = { ClientVif.domid; device_id } in
|
let client_ip = Ipaddr.V4.of_string_exn client_ip in
|
||||||
let get_client_ip () =
|
Lwt.return (Some (vif, client_ip))
|
||||||
let* str =
|
)
|
||||||
Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id)
|
(function
|
||||||
in
|
| Xs_protocol.Enoent _ -> Lwt.return None
|
||||||
let client_ip = List.hd (String.split_on_char ' ' str) in
|
| ex ->
|
||||||
(* NOTE(dinosaure): it's safe to use [List.hd] here,
|
Log.err (fun f -> f "Error getting IP address of %a: %s"
|
||||||
[String.split_on_char] can not return an empty list. *)
|
ClientVif.pp vif (Printexc.to_string ex));
|
||||||
Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip)
|
Lwt.return None
|
||||||
in
|
)
|
||||||
Lwt.catch get_client_ip @@ function
|
)
|
||||||
| Xs_protocol.Enoent _ -> Lwt.return_none
|
|
||||||
| Ipaddr.Parse_error (msg, client_ip) ->
|
|
||||||
Log.err (fun f ->
|
|
||||||
f "Error parsing IP address of %a from %s: %s"
|
|
||||||
ClientVif.pp vif client_ip msg);
|
|
||||||
Lwt.return_none
|
|
||||||
| exn ->
|
|
||||||
Log.err (fun f ->
|
|
||||||
f "Error getting IP address of %a: %s" ClientVif.pp vif
|
|
||||||
(Printexc.to_string exn));
|
|
||||||
Lwt.return_none)
|
|
||||||
in
|
|
||||||
Lwt_list.filter_map_p ip_of_vif devices
|
|
||||||
in
|
|
||||||
Xen_os.Xs.immediate client vifs_of_domain
|
|
||||||
|
|
||||||
let watch_clients fn =
|
let watch_clients fn =
|
||||||
Xen_os.Xs.make () >>= fun xs ->
|
OS.Xs.make () >>= fun xs ->
|
||||||
let backend_vifs = "backend/vif" in
|
let backend_vifs = "backend/vif" in
|
||||||
Log.info (fun f -> f "Watching %s" backend_vifs);
|
Log.info (fun f -> f "Watching %s" backend_vifs);
|
||||||
Xen_os.Xs.wait xs (fun handle ->
|
OS.Xs.wait xs (fun handle ->
|
||||||
Lwt.catch
|
begin Lwt.catch
|
||||||
(fun () -> directory ~handle backend_vifs)
|
(fun () -> directory ~handle backend_vifs)
|
||||||
(function Xs_protocol.Enoent _ -> Lwt.return [] | ex -> Lwt.fail ex)
|
(function
|
||||||
>>= fun items ->
|
| Xs_protocol.Enoent _ -> Lwt.return []
|
||||||
Xen_os.Xs.make () >>= fun xs ->
|
| ex -> Lwt.fail ex)
|
||||||
Lwt_list.map_p (vifs xs) items >>= fun items ->
|
end >>= fun items ->
|
||||||
fn (List.concat items |> VifMap.of_list) >>= fun () ->
|
Lwt_list.map_p (vifs ~handle) items >>= fun items ->
|
||||||
(* Wait for further updates *)
|
fn (List.concat items |> VifMap.of_list);
|
||||||
Lwt.fail Xs_protocol.Eagain)
|
(* Wait for further updates *)
|
||||||
|
Lwt.fail Xs_protocol.Eagain
|
||||||
|
)
|
||||||
|
|
||||||
type network_config = {
|
type network_config = {
|
||||||
from_cmdline : bool;
|
uplink_netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *)
|
||||||
(* Specify if we have network configuration from command line or from qubesDB*)
|
uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *)
|
||||||
netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *)
|
|
||||||
our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *)
|
clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *)
|
||||||
dns : Ipaddr.V4.t;
|
|
||||||
dns2 : Ipaddr.V4.t;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
exception Missing_key of string
|
exception Missing_key of string
|
||||||
|
|
||||||
|
(* TODO: /qubes-secondary-dns *)
|
||||||
let try_read_network_config db =
|
let try_read_network_config db =
|
||||||
let get name =
|
let get name =
|
||||||
match DB.KeyMap.find_opt name db with
|
match DB.KeyMap.find_opt name db with
|
||||||
| None -> raise (Missing_key name)
|
| None -> raise (Missing_key name)
|
||||||
| Some value -> Ipaddr.V4.of_string_exn value
|
| Some value -> value in
|
||||||
in
|
let uplink_our_ip = get "/qubes-ip" |> Ipaddr.V4.of_string_exn in
|
||||||
let our_ip = get "/qubes-ip" in
|
let uplink_netvm_ip = get "/qubes-gateway" |> Ipaddr.V4.of_string_exn in
|
||||||
(* - IP address for this VM (only when VM has netvm set) *)
|
let clients_our_ip = get "/qubes-netvm-gateway" |> Ipaddr.V4.of_string_exn in
|
||||||
let netvm_ip = get "/qubes-gateway" in
|
Log.info (fun f -> f "@[<v2>Got network configuration from QubesDB:@,\
|
||||||
(* - default gateway IP (only when VM has netvm set); VM should add host route to this address directly via eth0 (or whatever default interface name is) *)
|
NetVM IP on uplink network: %a@,\
|
||||||
let dns = get "/qubes-primary-dns" in
|
Our IP on uplink network: %a@,\
|
||||||
let dns2 = get "/qubes-secondary-dns" in
|
Our IP on client networks: %a@]"
|
||||||
{ from_cmdline = false; netvm_ip; our_ip; dns; dns2 }
|
Ipaddr.V4.pp uplink_netvm_ip
|
||||||
|
Ipaddr.V4.pp uplink_our_ip
|
||||||
|
Ipaddr.V4.pp clients_our_ip);
|
||||||
|
{ uplink_netvm_ip; uplink_our_ip; clients_our_ip }
|
||||||
|
|
||||||
let read_network_config qubesDB =
|
let read_network_config qubesDB =
|
||||||
let rec aux bindings =
|
let rec aux bindings =
|
||||||
try Lwt.return (try_read_network_config bindings)
|
try Lwt.return (try_read_network_config bindings)
|
||||||
with Missing_key key ->
|
with Missing_key key ->
|
||||||
Log.warn (fun f ->
|
Log.warn (fun f -> f "QubesDB key %S not (yet) present; waiting for QubesDB to change..." key);
|
||||||
f "QubesDB key %S not (yet) present; waiting for QubesDB to change..."
|
|
||||||
key);
|
|
||||||
DB.after qubesDB bindings >>= aux
|
DB.after qubesDB bindings >>= aux
|
||||||
in
|
in
|
||||||
aux (DB.bindings qubesDB)
|
aux (DB.bindings qubesDB)
|
||||||
|
|
||||||
let print_network_config config =
|
|
||||||
Log.info (fun f ->
|
|
||||||
f
|
|
||||||
"@[<v2>Current network configuration (QubesDB or command line):@,\
|
|
||||||
NetVM IP on uplink network: %a@,\
|
|
||||||
Our IP on client networks: %a@,\
|
|
||||||
DNS primary resolver: %a@,\
|
|
||||||
DNS secondary resolver: %a@]"
|
|
||||||
Ipaddr.V4.pp config.netvm_ip Ipaddr.V4.pp config.our_ip Ipaddr.V4.pp
|
|
||||||
config.dns Ipaddr.V4.pp config.dns2)
|
|
||||||
|
|
||||||
let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error"
|
let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error"
|
||||||
|
|
|
||||||
40
dao.mli
40
dao.mli
|
|
@ -4,43 +4,37 @@
|
||||||
(** Wrapper for XenStore and QubesDB databases. *)
|
(** Wrapper for XenStore and QubesDB databases. *)
|
||||||
|
|
||||||
module ClientVif : sig
|
module ClientVif : sig
|
||||||
type t = { domid : int; device_id : int }
|
type t = {
|
||||||
|
domid : int;
|
||||||
|
device_id : int;
|
||||||
|
}
|
||||||
val pp : t Fmt.t
|
val pp : t Fmt.t
|
||||||
end
|
end
|
||||||
|
|
||||||
module VifMap : sig
|
module VifMap : sig
|
||||||
include Map.S with type key = ClientVif.t
|
include Map.S with type key = ClientVif.t
|
||||||
|
|
||||||
val find : key -> 'a t -> 'a option
|
val find : key -> 'a t -> 'a option
|
||||||
end
|
end
|
||||||
|
|
||||||
val watch_clients : (Ipaddr.V4.t VifMap.t -> unit Lwt.t) -> 'a Lwt.t
|
val watch_clients : (Ipaddr.V4.t VifMap.t -> unit) -> 'a Lwt.t
|
||||||
(** [watch_clients fn] calls [fn clients] with the list of backend clients in
|
(** [watch_clients fn] calls [fn clients] with the list of backend clients
|
||||||
XenStore, and again each time XenStore updates. *)
|
in XenStore, and again each time XenStore updates. *)
|
||||||
|
|
||||||
type network_config = {
|
type network_config = {
|
||||||
from_cmdline : bool;
|
uplink_netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *)
|
||||||
(* Specify if we have network configuration from command line or from qubesDB*)
|
uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *)
|
||||||
netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *)
|
|
||||||
our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *)
|
clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *)
|
||||||
dns : Ipaddr.V4.t;
|
|
||||||
dns2 : Ipaddr.V4.t;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
val read_network_config : Qubes.DB.t -> network_config Lwt.t
|
val read_network_config : Qubes.DB.t -> network_config Lwt.t
|
||||||
(** [read_network_config db] fetches the configuration from QubesDB. If it isn't
|
(** [read_network_config db] fetches the configuration from QubesDB.
|
||||||
there yet, it waits until it is. *)
|
If it isn't there yet, it waits until it is. *)
|
||||||
|
|
||||||
val db_root : Ipaddr.V4.t -> string
|
val db_root : Ipaddr.V4.t -> string
|
||||||
(** Returns the root path of the firewall rules in the QubesDB for a given IP
|
(** Returns the root path of the firewall rules in the QubesDB for a given IP address. *)
|
||||||
address. *)
|
|
||||||
|
|
||||||
val read_rules :
|
val read_rules : string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes.rule list
|
||||||
string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes.rule list
|
(** [read_rules bindings ip] extracts firewall rule information for [ip] from [bindings].
|
||||||
(** [read_rules bindings ip] extracts firewall rule information for [ip] from
|
If any rules fail to parse, it will return only one rule denying all traffic. *)
|
||||||
[bindings]. If any rules fail to parse, it will return only one rule denying
|
|
||||||
all traffic. *)
|
|
||||||
|
|
||||||
val print_network_config : network_config -> unit
|
|
||||||
val set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t
|
val set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t
|
||||||
|
|
|
||||||
|
|
@ -1,199 +1,149 @@
|
||||||
<svg class='diagram' xmlns='http://www.w3.org/2000/svg' version='1.1' height='425' width='600'>
|
<svg class='diagram' xmlns='http://www.w3.org/2000/svg' version='1.1' height='329' width='600'>
|
||||||
<g transform='translate(8,16)'>
|
<g transform='translate(8,16)'>
|
||||||
<path d='M 240,0 L 408,0' style='fill:none;stroke:#000;'></path>
|
<path d='M 272,0 L 360,0' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 240,32 L 408,32' style='fill:none;stroke:#000;'></path>
|
<path d='M 272,32 L 360,32' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 272,96 L 368,96' style='fill:none;stroke:#000;'></path>
|
<path d='M 120,96 L 224,96' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 272,128 L 368,128' style='fill:none;stroke:#000;'></path>
|
<path d='M 272,96 L 320,96' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 120,192 L 224,192' style='fill:none;stroke:#000;'></path>
|
<path d='M 320,96 L 360,96' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 272,192 L 320,192' style='fill:none;stroke:#000;'></path>
|
<path d='M 72,112 L 112,112' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 320,192 L 360,192' style='fill:none;stroke:#000;'></path>
|
<path d='M 224,112 L 264,112' style='fill:none;stroke:#000;'></path>
|
||||||
|
<path d='M 368,112 L 440,112' style='fill:none;stroke:#000;'></path>
|
||||||
|
<path d='M 272,128 L 320,128' style='fill:none;stroke:#000;'></path>
|
||||||
|
<path d='M 320,128 L 360,128' style='fill:none;stroke:#000;'></path>
|
||||||
|
<path d='M 400,144 L 440,144' style='fill:none;stroke:#000;'></path>
|
||||||
|
<path d='M 440,144 L 472,144' style='fill:none;stroke:#000;'></path>
|
||||||
|
<path d='M 72,160 L 112,160' style='fill:none;stroke:#000;'></path>
|
||||||
|
<path d='M 480,160 L 520,160' style='fill:none;stroke:#000;'></path>
|
||||||
|
<path d='M 400,176 L 472,176' style='fill:none;stroke:#000;'></path>
|
||||||
|
<path d='M 272,192 L 360,192' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 72,208 L 112,208' style='fill:none;stroke:#000;'></path>
|
<path d='M 72,208 L 112,208' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 224,208 L 264,208' style='fill:none;stroke:#000;'></path>
|
<path d='M 232,208 L 272,208' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 368,208 L 440,208' style='fill:none;stroke:#000;'></path>
|
<path d='M 360,208 L 440,208' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 272,224 L 320,224' style='fill:none;stroke:#000;'></path>
|
<path d='M 120,224 L 176,224' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 320,224 L 360,224' style='fill:none;stroke:#000;'></path>
|
<path d='M 176,224 L 224,224' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 400,240 L 440,240' style='fill:none;stroke:#000;'></path>
|
<path d='M 272,224 L 360,224' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 440,240 L 472,240' style='fill:none;stroke:#000;'></path>
|
<path d='M 120,96 L 120,224' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 72,256 L 112,256' style='fill:none;stroke:#000;'></path>
|
<path d='M 176,224 L 176,272' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 480,256 L 520,256' style='fill:none;stroke:#000;'></path>
|
<path d='M 224,96 L 224,112' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 400,272 L 472,272' style='fill:none;stroke:#000;'></path>
|
<path d='M 224,112 L 224,224' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 272,288 L 360,288' style='fill:none;stroke:#000;'></path>
|
<path d='M 272,0 L 272,32' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 72,304 L 112,304' style='fill:none;stroke:#000;'></path>
|
|
||||||
<path d='M 232,304 L 272,304' style='fill:none;stroke:#000;'></path>
|
|
||||||
<path d='M 360,304 L 440,304' style='fill:none;stroke:#000;'></path>
|
|
||||||
<path d='M 120,320 L 176,320' style='fill:none;stroke:#000;'></path>
|
|
||||||
<path d='M 176,320 L 224,320' style='fill:none;stroke:#000;'></path>
|
|
||||||
<path d='M 272,320 L 360,320' style='fill:none;stroke:#000;'></path>
|
|
||||||
<path d='M 120,192 L 120,320' style='fill:none;stroke:#000;'></path>
|
|
||||||
<path d='M 176,320 L 176,368' style='fill:none;stroke:#000;'></path>
|
|
||||||
<path d='M 224,192 L 224,208' style='fill:none;stroke:#000;'></path>
|
|
||||||
<path d='M 224,208 L 224,320' style='fill:none;stroke:#000;'></path>
|
|
||||||
<path d='M 240,0 L 240,32' style='fill:none;stroke:#000;'></path>
|
|
||||||
<path d='M 272,96 L 272,128' style='fill:none;stroke:#000;'></path>
|
<path d='M 272,96 L 272,128' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 272,192 L 272,224' style='fill:none;stroke:#000;'></path>
|
<path d='M 272,192 L 272,208' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 272,288 L 272,304' style='fill:none;stroke:#000;'></path>
|
<path d='M 272,208 L 272,224' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 272,304 L 272,320' style='fill:none;stroke:#000;'></path>
|
<path d='M 320,48 L 320,96' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 320,48 L 320,80' style='fill:none;stroke:#000;'></path>
|
<path d='M 320,128 L 320,176' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 320,144 L 320,192' style='fill:none;stroke:#000;'></path>
|
<path d='M 360,0 L 360,32' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 320,224 L 320,272' style='fill:none;stroke:#000;'></path>
|
<path d='M 360,96 L 360,128' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 360,192 L 360,224' style='fill:none;stroke:#000;'></path>
|
<path d='M 360,192 L 360,208' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 360,288 L 360,304' style='fill:none;stroke:#000;'></path>
|
<path d='M 360,208 L 360,224' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 360,304 L 360,320' style='fill:none;stroke:#000;'></path>
|
<path d='M 400,144 L 400,176' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 368,96 L 368,128' style='fill:none;stroke:#000;'></path>
|
<path d='M 440,112 L 440,144' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 400,240 L 400,272' style='fill:none;stroke:#000;'></path>
|
<path d='M 440,192 L 440,208' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 408,0 L 408,32' style='fill:none;stroke:#000;'></path>
|
<path d='M 472,144 L 472,176' style='fill:none;stroke:#000;'></path>
|
||||||
<path d='M 440,208 L 440,240' style='fill:none;stroke:#000;'></path>
|
<polygon points='80.000000,112.000000 68.000000,106.400002 68.000000,117.599998' style='fill:#000' transform='rotate(180.000000, 72.000000, 112.000000)'></polygon>
|
||||||
<path d='M 440,288 L 440,304' style='fill:none;stroke:#000;'></path>
|
<polygon points='80.000000,160.000000 68.000000,154.399994 68.000000,165.600006' style='fill:#000' transform='rotate(180.000000, 72.000000, 160.000000)'></polygon>
|
||||||
<path d='M 472,240 L 472,272' style='fill:none;stroke:#000;'></path>
|
|
||||||
<path d='M 320,80 L 320,88' style='fill:none;stroke:#000;'></path>
|
|
||||||
<polygon points='80.000000,208.000000 68.000000,202.399994 68.000000,213.600006' style='fill:#000' transform='rotate(180.000000, 72.000000, 208.000000)'></polygon>
|
<polygon points='80.000000,208.000000 68.000000,202.399994 68.000000,213.600006' style='fill:#000' transform='rotate(180.000000, 72.000000, 208.000000)'></polygon>
|
||||||
<polygon points='80.000000,256.000000 68.000000,250.399994 68.000000,261.600006' style='fill:#000' transform='rotate(180.000000, 72.000000, 256.000000)'></polygon>
|
<polygon points='120.000000,112.000000 108.000000,106.400002 108.000000,117.599998' style='fill:#000' transform='rotate(0.000000, 112.000000, 112.000000)'></polygon>
|
||||||
<polygon points='80.000000,304.000000 68.000000,298.399994 68.000000,309.600006' style='fill:#000' transform='rotate(180.000000, 72.000000, 304.000000)'></polygon>
|
<polygon points='120.000000,160.000000 108.000000,154.399994 108.000000,165.600006' style='fill:#000' transform='rotate(0.000000, 112.000000, 160.000000)'></polygon>
|
||||||
<polygon points='120.000000,208.000000 108.000000,202.399994 108.000000,213.600006' style='fill:#000' transform='rotate(0.000000, 112.000000, 208.000000)'></polygon>
|
<polygon points='120.000000,208.000000 108.000000,202.399994 108.000000,213.600006' style='fill:#000' transform='rotate(0.000000, 112.000000, 208.000000)'></polygon>
|
||||||
<polygon points='120.000000,256.000000 108.000000,250.399994 108.000000,261.600006' style='fill:#000' transform='rotate(0.000000, 112.000000, 256.000000)'></polygon>
|
<polygon points='184.000000,272.000000 172.000000,266.399994 172.000000,277.600006' style='fill:#000' transform='rotate(90.000000, 176.000000, 272.000000)'></polygon>
|
||||||
<polygon points='120.000000,304.000000 108.000000,298.399994 108.000000,309.600006' style='fill:#000' transform='rotate(0.000000, 112.000000, 304.000000)'></polygon>
|
<polygon points='240.000000,208.000000 228.000000,202.399994 228.000000,213.600006' style='fill:#000' transform='rotate(180.000000, 232.000000, 208.000000)'></polygon>
|
||||||
<polygon points='184.000000,368.000000 172.000000,362.399994 172.000000,373.600006' style='fill:#000' transform='rotate(90.000000, 176.000000, 368.000000)'></polygon>
|
<polygon points='272.000000,112.000000 260.000000,106.400002 260.000000,117.599998' style='fill:#000' transform='rotate(0.000000, 264.000000, 112.000000)'></polygon>
|
||||||
<polygon points='240.000000,304.000000 228.000000,298.399994 228.000000,309.600006' style='fill:#000' transform='rotate(180.000000, 232.000000, 304.000000)'></polygon>
|
|
||||||
<polygon points='272.000000,208.000000 260.000000,202.399994 260.000000,213.600006' style='fill:#000' transform='rotate(0.000000, 264.000000, 208.000000)'></polygon>
|
|
||||||
<path d='M 320,40 L 320,48' style='fill:none;stroke:#000;'></path>
|
<path d='M 320,40 L 320,48' style='fill:none;stroke:#000;'></path>
|
||||||
<polygon points='336.000000,48.000000 324.000000,42.400002 324.000000,53.599998' style='fill:#000' transform='rotate(270.000000, 320.000000, 48.000000)'></polygon>
|
<polygon points='336.000000,48.000000 324.000000,42.400002 324.000000,53.599998' style='fill:#000' transform='rotate(270.000000, 320.000000, 48.000000)'></polygon>
|
||||||
<path d='M 320,136 L 320,144' style='fill:none;stroke:#000;'></path>
|
<path d='M 320,176 L 320,184' style='fill:none;stroke:#000;'></path>
|
||||||
<polygon points='336.000000,144.000000 324.000000,138.399994 324.000000,149.600006' style='fill:#000' transform='rotate(270.000000, 320.000000, 144.000000)'></polygon>
|
<polygon points='336.000000,176.000000 324.000000,170.399994 324.000000,181.600006' style='fill:#000' transform='rotate(90.000000, 320.000000, 176.000000)'></polygon>
|
||||||
<path d='M 320,272 L 320,280' style='fill:none;stroke:#000;'></path>
|
<polygon points='376.000000,112.000000 364.000000,106.400002 364.000000,117.599998' style='fill:#000' transform='rotate(180.000000, 368.000000, 112.000000)'></polygon>
|
||||||
<polygon points='336.000000,272.000000 324.000000,266.399994 324.000000,277.600006' style='fill:#000' transform='rotate(90.000000, 320.000000, 272.000000)'></polygon>
|
<path d='M 440,184 L 440,192' style='fill:none;stroke:#000;'></path>
|
||||||
<polygon points='376.000000,208.000000 364.000000,202.399994 364.000000,213.600006' style='fill:#000' transform='rotate(180.000000, 368.000000, 208.000000)'></polygon>
|
<polygon points='456.000000,192.000000 444.000000,186.399994 444.000000,197.600006' style='fill:#000' transform='rotate(270.000000, 440.000000, 192.000000)'></polygon>
|
||||||
<path d='M 440,280 L 440,288' style='fill:none;stroke:#000;'></path>
|
<polygon points='488.000000,160.000000 476.000000,154.399994 476.000000,165.600006' style='fill:#000' transform='rotate(180.000000, 480.000000, 160.000000)'></polygon>
|
||||||
<polygon points='456.000000,288.000000 444.000000,282.399994 444.000000,293.600006' style='fill:#000' transform='rotate(270.000000, 440.000000, 288.000000)'></polygon>
|
<polygon points='528.000000,160.000000 516.000000,154.399994 516.000000,165.600006' style='fill:#000' transform='rotate(0.000000, 520.000000, 160.000000)'></polygon>
|
||||||
<polygon points='488.000000,256.000000 476.000000,250.399994 476.000000,261.600006' style='fill:#000' transform='rotate(180.000000, 480.000000, 256.000000)'></polygon>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='144' y='164' style='fill:#000;font-size:1em'>l</text>
|
||||||
<polygon points='528.000000,256.000000 516.000000,250.399994 516.000000,261.600006' style='fill:#000' transform='rotate(0.000000, 520.000000, 256.000000)'></polygon>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='544' y='164' style='fill:#000;font-size:1em'>y</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='312' y='20' style='fill:#000;font-size:1em'>r</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='552' y='164' style='fill:#000;font-size:1em'>s</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='352' y='68' style='fill:#000;font-size:1em'>e</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='216' y='260' style='fill:#000;font-size:1em'>t</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='288' y='116' style='fill:#000;font-size:1em'>n</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='456' y='164' style='fill:#000;font-size:1em'>k</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='360' y='164' style='fill:#000;font-size:1em'>k</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='16' y='212' style='fill:#000;font-size:1em'>r</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='200' y='260' style='fill:#000;font-size:1em'>e</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='312' y='212' style='fill:#000;font-size:1em'>u</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='216' y='356' style='fill:#000;font-size:1em'>t</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='312' y='20' style='fill:#000;font-size:1em'>l</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='248' y='68' style='fill:#000;font-size:1em'>t</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='168' y='164' style='fill:#000;font-size:1em'>n</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='32' y='212' style='fill:#000;font-size:1em'>w</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='184' y='164' style='fill:#000;font-size:1em'>_</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='40' y='212' style='fill:#000;font-size:1em'>o</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='296' y='20' style='fill:#000;font-size:1em'>r</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='320' y='212' style='fill:#000;font-size:1em'>w</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='152' y='164' style='fill:#000;font-size:1em'>i</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='280' y='20' style='fill:#000;font-size:1em'>e</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='8' y='212' style='fill:#000;font-size:1em'>e</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='136' y='260' style='fill:#000;font-size:1em'>c</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='56' y='212' style='fill:#000;font-size:1em'>l</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='168' y='260' style='fill:#000;font-size:1em'>n</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='224' y='260' style='fill:#000;font-size:1em'>o</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='40' y='308' style='fill:#000;font-size:1em'>n</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='168' y='292' style='fill:#000;font-size:1em'>n</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='192' y='356' style='fill:#000;font-size:1em'>o</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='56' y='116' style='fill:#000;font-size:1em'>k</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='176' y='388' style='fill:#000;font-size:1em'>S</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='568' y='164' style='fill:#000;font-size:1em'>n</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='160' y='404' style='fill:#000;font-size:1em'>(</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='32' y='212' style='fill:#000;font-size:1em'>o</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='272' y='68' style='fill:#000;font-size:1em'>n</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='40' y='116' style='fill:#000;font-size:1em'>o</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='176' y='260' style='fill:#000;font-size:1em'>t</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='576' y='164' style='fill:#000;font-size:1em'>e</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='192' y='404' style='fill:#000;font-size:1em'>0</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='328' y='212' style='fill:#000;font-size:1em'>e</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='56' y='260' style='fill:#000;font-size:1em'>]</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='160' y='292' style='fill:#000;font-size:1em'>e</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='192' y='260' style='fill:#000;font-size:1em'>n</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='432' y='164' style='fill:#000;font-size:1em'>l</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='184' y='356' style='fill:#000;font-size:1em'>m</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='536' y='164' style='fill:#000;font-size:1em'>s</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='48' y='260' style='fill:#000;font-size:1em'>.</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='184' y='292' style='fill:#000;font-size:1em'>t</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='392' y='20' style='fill:#000;font-size:1em'>B</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='160' y='308' style='fill:#000;font-size:1em'>(</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='408' y='68' style='fill:#000;font-size:1em'>k</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='288' y='116' style='fill:#000;font-size:1em'>f</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='304' y='116' style='fill:#000;font-size:1em'>t</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='424' y='164' style='fill:#000;font-size:1em'>p</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='440' y='164' style='fill:#000;font-size:1em'>i</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='208' y='260' style='fill:#000;font-size:1em'>i</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='192' y='260' style='fill:#000;font-size:1em'>o</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='320' y='116' style='fill:#000;font-size:1em'>w</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='176' y='164' style='fill:#000;font-size:1em'>t</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='416' y='164' style='fill:#000;font-size:1em'>u</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='448' y='164' style='fill:#000;font-size:1em'>n</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='560' y='164' style='fill:#000;font-size:1em'>-</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='48' y='212' style='fill:#000;font-size:1em'>a</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='304' y='212' style='fill:#000;font-size:1em'>o</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='152' y='292' style='fill:#000;font-size:1em'>X</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='176' y='292' style='fill:#000;font-size:1em'>S</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='200' y='292' style='fill:#000;font-size:1em'>r</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='184' y='308' style='fill:#000;font-size:1em'>m</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='304' y='20' style='fill:#000;font-size:1em'>u</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='352' y='68' style='fill:#000;font-size:1em'>c</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='48' y='116' style='fill:#000;font-size:1em'>r</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='56' y='164' style='fill:#000;font-size:1em'>]</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='200' y='164' style='fill:#000;font-size:1em'>e</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='296' y='212' style='fill:#000;font-size:1em'>r</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='296' y='116' style='fill:#000;font-size:1em'>i</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='200' y='260' style='fill:#000;font-size:1em'>n</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='240' y='260' style='fill:#000;font-size:1em'>s</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='584' y='164' style='fill:#000;font-size:1em'>t</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='344' y='68' style='fill:#000;font-size:1em'>e</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='360' y='68' style='fill:#000;font-size:1em'>k</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='368' y='68' style='fill:#000;font-size:1em'>s</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='32' y='116' style='fill:#000;font-size:1em'>w</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='312' y='116' style='fill:#000;font-size:1em'>e</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='32' y='164' style='fill:#000;font-size:1em'>.</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='192' y='164' style='fill:#000;font-size:1em'>n</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='208' y='292' style='fill:#000;font-size:1em'>e</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='336' y='116' style='fill:#000;font-size:1em'>l</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='232' y='260' style='fill:#000;font-size:1em'>r</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='24' y='212' style='fill:#000;font-size:1em'>s</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='320' y='20' style='fill:#000;font-size:1em'>e</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='328' y='20' style='fill:#000;font-size:1em'>s</text>
|
||||||
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='304' y='116' style='fill:#000;font-size:1em'>r</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='344' y='116' style='fill:#000;font-size:1em'>l</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='344' y='116' style='fill:#000;font-size:1em'>l</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='56' y='212' style='fill:#000;font-size:1em'>k</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='24' y='164' style='fill:#000;font-size:1em'>[</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='296' y='212' style='fill:#000;font-size:1em'>i</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='48' y='164' style='fill:#000;font-size:1em'>.</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='312' y='212' style='fill:#000;font-size:1em'>e</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='0' y='212' style='fill:#000;font-size:1em'>p</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='16' y='308' style='fill:#000;font-size:1em'>r</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='40' y='212' style='fill:#000;font-size:1em'>n</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='352' y='164' style='fill:#000;font-size:1em'>c</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='320' y='212' style='fill:#000;font-size:1em'>t</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='536' y='260' style='fill:#000;font-size:1em'>s</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='192' y='292' style='fill:#000;font-size:1em'>o</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='360' y='20' style='fill:#000;font-size:1em'>b</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='176' y='308' style='fill:#000;font-size:1em'>o</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='264' y='68' style='fill:#000;font-size:1em'>i</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='328' y='68' style='fill:#000;font-size:1em'>c</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='168' y='404' style='fill:#000;font-size:1em'>d</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='336' y='68' style='fill:#000;font-size:1em'>h</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='8' y='308' style='fill:#000;font-size:1em'>e</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='40' y='164' style='fill:#000;font-size:1em'>.</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='232' y='68' style='fill:#000;font-size:1em'>n</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='136' y='164' style='fill:#000;font-size:1em'>c</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='336' y='68' style='fill:#000;font-size:1em'>t</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='208' y='164' style='fill:#000;font-size:1em'>t</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='344' y='68' style='fill:#000;font-size:1em'>h</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='184' y='260' style='fill:#000;font-size:1em'>m</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='336' y='116' style='fill:#000;font-size:1em'>b</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='336' y='212' style='fill:#000;font-size:1em'>l</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='456' y='260' style='fill:#000;font-size:1em'>k</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='560' y='260' style='fill:#000;font-size:1em'>-</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='304' y='20' style='fill:#000;font-size:1em'>f</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='296' y='116' style='fill:#000;font-size:1em'>a</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='344' y='164' style='fill:#000;font-size:1em'>e</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='200' y='356' style='fill:#000;font-size:1em'>n</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='376' y='20' style='fill:#000;font-size:1em'>s</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='208' y='68' style='fill:#000;font-size:1em'>i</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='368' y='164' style='fill:#000;font-size:1em'>s</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='48' y='212' style='fill:#000;font-size:1em'>r</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='32' y='260' style='fill:#000;font-size:1em'>.</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='328' y='308' style='fill:#000;font-size:1em'>e</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='320' y='20' style='fill:#000;font-size:1em'>o</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='240' y='68' style='fill:#000;font-size:1em'>o</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='352' y='20' style='fill:#000;font-size:1em'>u</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='360' y='68' style='fill:#000;font-size:1em'>n</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='400' y='68' style='fill:#000;font-size:1em'>c</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='328' y='212' style='fill:#000;font-size:1em'>a</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='144' y='260' style='fill:#000;font-size:1em'>l</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='192' y='388' style='fill:#000;font-size:1em'>o</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='200' y='404' style='fill:#000;font-size:1em'>)</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='256' y='68' style='fill:#000;font-size:1em'>-</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='440' y='260' style='fill:#000;font-size:1em'>i</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='432' y='260' style='fill:#000;font-size:1em'>l</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='232' y='356' style='fill:#000;font-size:1em'>r</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='208' y='388' style='fill:#000;font-size:1em'>e</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='328' y='20' style='fill:#000;font-size:1em'>m</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='152' y='260' style='fill:#000;font-size:1em'>i</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='24' y='308' style='fill:#000;font-size:1em'>s</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='336' y='308' style='fill:#000;font-size:1em'>r</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='160' y='388' style='fill:#000;font-size:1em'>e</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='272' y='20' style='fill:#000;font-size:1em'>l</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='384' y='20' style='fill:#000;font-size:1em'>D</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='328' y='164' style='fill:#000;font-size:1em'>c</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='24' y='260' style='fill:#000;font-size:1em'>[</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='568' y='260' style='fill:#000;font-size:1em'>n</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='240' y='356' style='fill:#000;font-size:1em'>s</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='176' y='404' style='fill:#000;font-size:1em'>o</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='216' y='68' style='fill:#000;font-size:1em'>f</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='280' y='68' style='fill:#000;font-size:1em'>-</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='312' y='116' style='fill:#000;font-size:1em'>-</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='344' y='212' style='fill:#000;font-size:1em'>l</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='224' y='356' style='fill:#000;font-size:1em'>o</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='296' y='308' style='fill:#000;font-size:1em'>r</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='320' y='308' style='fill:#000;font-size:1em'>t</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='376' y='68' style='fill:#000;font-size:1em'>c</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='184' y='260' style='fill:#000;font-size:1em'>_</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='208' y='356' style='fill:#000;font-size:1em'>i</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='184' y='404' style='fill:#000;font-size:1em'>m</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='264' y='20' style='fill:#000;font-size:1em'>u</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='344' y='20' style='fill:#000;font-size:1em'>Q</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='208' y='260' style='fill:#000;font-size:1em'>t</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='576' y='260' style='fill:#000;font-size:1em'>e</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='48' y='308' style='fill:#000;font-size:1em'>a</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='384' y='68' style='fill:#000;font-size:1em'>h</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='40' y='260' style='fill:#000;font-size:1em'>.</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='584' y='260' style='fill:#000;font-size:1em'>t</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='0' y='308' style='fill:#000;font-size:1em'>p</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='56' y='308' style='fill:#000;font-size:1em'>l</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='168' y='388' style='fill:#000;font-size:1em'>n</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='200' y='388' style='fill:#000;font-size:1em'>r</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='368' y='20' style='fill:#000;font-size:1em'>e</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='424' y='260' style='fill:#000;font-size:1em'>p</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='288' y='20' style='fill:#000;font-size:1em'>s</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='288' y='68' style='fill:#000;font-size:1em'>n</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='448' y='260' style='fill:#000;font-size:1em'>n</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='544' y='260' style='fill:#000;font-size:1em'>y</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='152' y='388' style='fill:#000;font-size:1em'>X</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='160' y='260' style='fill:#000;font-size:1em'>e</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='416' y='260' style='fill:#000;font-size:1em'>u</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='552' y='260' style='fill:#000;font-size:1em'>s</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='392' y='68' style='fill:#000;font-size:1em'>e</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='320' y='116' style='fill:#000;font-size:1em'>t</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='336' y='164' style='fill:#000;font-size:1em'>h</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='32' y='308' style='fill:#000;font-size:1em'>o</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='312' y='308' style='fill:#000;font-size:1em'>u</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='296' y='68' style='fill:#000;font-size:1em'>a</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='304' y='68' style='fill:#000;font-size:1em'>t</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='304' y='212' style='fill:#000;font-size:1em'>r</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='256' y='20' style='fill:#000;font-size:1em'>r</text>
|
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='328' y='116' style='fill:#000;font-size:1em'>a</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='328' y='116' style='fill:#000;font-size:1em'>a</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='304' y='308' style='fill:#000;font-size:1em'>o</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='160' y='164' style='fill:#000;font-size:1em'>e</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='184' y='388' style='fill:#000;font-size:1em'>t</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='336' y='212' style='fill:#000;font-size:1em'>r</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='224' y='68' style='fill:#000;font-size:1em'>-</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='168' y='308' style='fill:#000;font-size:1em'>d</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='352' y='116' style='fill:#000;font-size:1em'>e</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='192' y='308' style='fill:#000;font-size:1em'>0</text>
|
||||||
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='288' y='212' style='fill:#000;font-size:1em'>f</text>
|
<text text-anchor='middle' font-family='Menlo,Lucida Console,monospace' x='200' y='308' style='fill:#000;font-size:1em'>)</text>
|
||||||
</g>
|
</g>
|
||||||
</svg>
|
</svg>
|
||||||
|
|
|
||||||
|
Before Width: | Height: | Size: 22 KiB After Width: | Height: | Size: 16 KiB |
635
dispatcher.ml
635
dispatcher.ml
|
|
@ -1,635 +0,0 @@
|
||||||
open Lwt.Infix
|
|
||||||
open Fw_utils
|
|
||||||
module Netback = Backend.Make (Xenstore.Make (Xen_os.Xs))
|
|
||||||
module ClientEth = Ethernet.Make (Netback)
|
|
||||||
module UplinkEth = Ethernet.Make (Netif)
|
|
||||||
|
|
||||||
let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch"
|
|
||||||
|
|
||||||
module Log = (val Logs.src_log src : Logs.LOG)
|
|
||||||
module Arp = Arp.Make (UplinkEth)
|
|
||||||
module I = Static_ipv4.Make (UplinkEth) (Arp)
|
|
||||||
module U = Udp.Make (I)
|
|
||||||
|
|
||||||
class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link =
|
|
||||||
let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in
|
|
||||||
object
|
|
||||||
val mutable rules = []
|
|
||||||
method get_rules = rules
|
|
||||||
method set_rules new_db = rules <- Dao.read_rules new_db client_ip
|
|
||||||
method my_mac = ClientEth.mac eth
|
|
||||||
method other_mac = client_mac
|
|
||||||
method my_ip = gateway_ip
|
|
||||||
method other_ip = client_ip
|
|
||||||
|
|
||||||
method writev proto fillfn =
|
|
||||||
Lwt.catch
|
|
||||||
(fun () ->
|
|
||||||
ClientEth.write eth client_mac proto fillfn >|= function
|
|
||||||
| Ok () -> ()
|
|
||||||
| Error e ->
|
|
||||||
Log.err (fun f ->
|
|
||||||
f "error trying to send to client: @[%a@]" ClientEth.pp_error
|
|
||||||
e))
|
|
||||||
(fun ex ->
|
|
||||||
(* Usually Netback_shutdown, because the client disconnected *)
|
|
||||||
Log.err (fun f ->
|
|
||||||
f "uncaught exception trying to send to client: @[%s@]"
|
|
||||||
(Printexc.to_string ex));
|
|
||||||
Lwt.return_unit)
|
|
||||||
|
|
||||||
method log_header = log_header
|
|
||||||
end
|
|
||||||
|
|
||||||
class netvm_iface eth mac ~my_ip ~other_ip : interface =
|
|
||||||
object
|
|
||||||
method my_mac = UplinkEth.mac eth
|
|
||||||
method my_ip = my_ip
|
|
||||||
method other_ip = other_ip
|
|
||||||
|
|
||||||
method writev ethertype fillfn =
|
|
||||||
Lwt.catch
|
|
||||||
(fun () ->
|
|
||||||
mac >>= fun dst ->
|
|
||||||
UplinkEth.write eth dst ethertype fillfn
|
|
||||||
>|= or_raise "Write to uplink" UplinkEth.pp_error)
|
|
||||||
(fun ex ->
|
|
||||||
Log.err (fun f ->
|
|
||||||
f "uncaught exception trying to send to uplink: @[%s@]"
|
|
||||||
(Printexc.to_string ex));
|
|
||||||
Lwt.return_unit)
|
|
||||||
end
|
|
||||||
|
|
||||||
type uplink = {
|
|
||||||
net : Netif.t;
|
|
||||||
eth : UplinkEth.t;
|
|
||||||
arp : Arp.t;
|
|
||||||
interface : interface;
|
|
||||||
mutable fragments : Fragments.Cache.t;
|
|
||||||
ip : I.t;
|
|
||||||
udp : U.t;
|
|
||||||
}
|
|
||||||
|
|
||||||
type t = {
|
|
||||||
uplink_connected : unit Lwt_condition.t;
|
|
||||||
uplink_disconnect : unit Lwt_condition.t;
|
|
||||||
uplink_disconnected : unit Lwt_condition.t;
|
|
||||||
mutable config : Dao.network_config;
|
|
||||||
clients : Client_eth.t;
|
|
||||||
nat : My_nat.t;
|
|
||||||
mutable uplink : uplink option;
|
|
||||||
}
|
|
||||||
|
|
||||||
let create ~config ~clients ~nat ~uplink =
|
|
||||||
{
|
|
||||||
uplink_connected = Lwt_condition.create ();
|
|
||||||
uplink_disconnect = Lwt_condition.create ();
|
|
||||||
uplink_disconnected = Lwt_condition.create ();
|
|
||||||
config;
|
|
||||||
clients;
|
|
||||||
nat;
|
|
||||||
uplink;
|
|
||||||
}
|
|
||||||
|
|
||||||
let update t ~config ~uplink =
|
|
||||||
t.config <- config;
|
|
||||||
t.uplink <- uplink;
|
|
||||||
Lwt.return_unit
|
|
||||||
|
|
||||||
let target t buf =
|
|
||||||
let dst_ip = buf.Ipv4_packet.dst in
|
|
||||||
match Client_eth.lookup t.clients dst_ip with
|
|
||||||
| Some client_link -> Some (client_link :> interface)
|
|
||||||
| None -> (
|
|
||||||
(* if dest is not a client, transfer it to our uplink *)
|
|
||||||
match t.uplink with
|
|
||||||
| None -> (
|
|
||||||
match Client_eth.lookup t.clients t.config.netvm_ip with
|
|
||||||
| Some uplink -> Some (uplink :> interface)
|
|
||||||
| None ->
|
|
||||||
Log.err (fun f ->
|
|
||||||
f
|
|
||||||
"We have a command line configuration %a but it's \
|
|
||||||
currently not connected to us (please check its netvm \
|
|
||||||
property)...%!"
|
|
||||||
Ipaddr.V4.pp t.config.netvm_ip);
|
|
||||||
None)
|
|
||||||
| Some uplink -> Some uplink.interface)
|
|
||||||
|
|
||||||
let add_client t = Client_eth.add_client t.clients
|
|
||||||
let remove_client t = Client_eth.remove_client t.clients
|
|
||||||
|
|
||||||
let classify t ip =
|
|
||||||
if ip = Ipaddr.V4 t.config.our_ip then `Firewall
|
|
||||||
else if ip = Ipaddr.V4 t.config.netvm_ip then `NetVM
|
|
||||||
else (Client_eth.classify t.clients ip :> Packet.host)
|
|
||||||
|
|
||||||
let resolve t = function
|
|
||||||
| `Firewall -> Ipaddr.V4 t.config.our_ip
|
|
||||||
| `NetVM -> Ipaddr.V4 t.config.netvm_ip
|
|
||||||
| #Client_eth.host as host -> Client_eth.resolve t.clients host
|
|
||||||
|
|
||||||
(* Transmission *)
|
|
||||||
|
|
||||||
let transmit_ipv4 packet iface =
|
|
||||||
Lwt.catch
|
|
||||||
(fun () ->
|
|
||||||
let fragments = ref [] in
|
|
||||||
iface#writev `IPv4 (fun b ->
|
|
||||||
match Nat_packet.into_cstruct packet b with
|
|
||||||
| Error e ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Failed to write packet to %a: %a" Ipaddr.V4.pp
|
|
||||||
iface#other_ip Nat_packet.pp_error e);
|
|
||||||
0
|
|
||||||
| Ok (n, frags) ->
|
|
||||||
fragments := frags;
|
|
||||||
n)
|
|
||||||
>>= fun () ->
|
|
||||||
Lwt_list.iter_s
|
|
||||||
(fun f ->
|
|
||||||
let size = Cstruct.length f in
|
|
||||||
iface#writev `IPv4 (fun b ->
|
|
||||||
Cstruct.blit f 0 b 0 size;
|
|
||||||
size))
|
|
||||||
!fragments)
|
|
||||||
(fun ex ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Failed to write packet to %a: %s" Ipaddr.V4.pp iface#other_ip
|
|
||||||
(Printexc.to_string ex));
|
|
||||||
Lwt.return_unit)
|
|
||||||
|
|
||||||
let forward_ipv4 t packet =
|
|
||||||
let (`IPv4 (ip, _)) = packet in
|
|
||||||
Lwt.catch
|
|
||||||
(fun () ->
|
|
||||||
match target t ip with
|
|
||||||
| Some iface -> transmit_ipv4 packet iface
|
|
||||||
| None -> Lwt.return_unit)
|
|
||||||
(fun ex ->
|
|
||||||
let dst_ip = ip.Ipv4_packet.dst in
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Failed to lookup for target %a: %s" Ipaddr.V4.pp dst_ip
|
|
||||||
(Printexc.to_string ex));
|
|
||||||
Lwt.return_unit)
|
|
||||||
|
|
||||||
(* NAT *)
|
|
||||||
|
|
||||||
let translate t packet = My_nat.translate t.nat packet
|
|
||||||
|
|
||||||
(* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *)
|
|
||||||
let add_nat_and_forward_ipv4 t packet =
|
|
||||||
let xl_host = t.config.our_ip in
|
|
||||||
match My_nat.add_nat_rule_and_translate t.nat ~xl_host `NAT packet with
|
|
||||||
| Ok packet -> forward_ipv4 t packet
|
|
||||||
| Error e ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet);
|
|
||||||
Lwt.return_unit
|
|
||||||
|
|
||||||
(* Add a NAT rule to redirect this conversation to [host:port] instead of us. *)
|
|
||||||
let nat_to t ~host ~port packet =
|
|
||||||
match resolve t host with
|
|
||||||
| Ipaddr.V6 _ ->
|
|
||||||
Log.warn (fun f -> f "Cannot NAT with IPv6");
|
|
||||||
Lwt.return_unit
|
|
||||||
| Ipaddr.V4 target -> (
|
|
||||||
let xl_host = t.config.our_ip in
|
|
||||||
match
|
|
||||||
My_nat.add_nat_rule_and_translate t.nat ~xl_host
|
|
||||||
(`Redirect (target, port))
|
|
||||||
packet
|
|
||||||
with
|
|
||||||
| Ok packet -> forward_ipv4 t packet
|
|
||||||
| Error e ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp
|
|
||||||
packet);
|
|
||||||
Lwt.return_unit)
|
|
||||||
|
|
||||||
let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst
|
|
||||||
(annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t =
|
|
||||||
let packet = Packet.to_mirage_nat_packet annotated_packet in
|
|
||||||
rules annotated_packet >>= fun action ->
|
|
||||||
match (action, dst) with
|
|
||||||
| `Accept, `Client client_link -> transmit_ipv4 packet client_link
|
|
||||||
| `Accept, (`External _ | `NetVM) -> (
|
|
||||||
match t.uplink with
|
|
||||||
| Some uplink -> transmit_ipv4 packet uplink.interface
|
|
||||||
| None -> (
|
|
||||||
match Client_eth.lookup t.clients t.config.netvm_ip with
|
|
||||||
| Some iface -> transmit_ipv4 packet iface
|
|
||||||
| None ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "No output interface for %a : drop" Nat_packet.pp packet);
|
|
||||||
Lwt.return_unit))
|
|
||||||
| `Accept, `Firewall ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet);
|
|
||||||
Lwt.return_unit
|
|
||||||
| `NAT, _ ->
|
|
||||||
Log.debug (fun f -> f "adding NAT rule for %a" Nat_packet.pp packet);
|
|
||||||
add_nat_and_forward_ipv4 t packet
|
|
||||||
| `NAT_to (host, port), _ -> nat_to t packet ~host ~port
|
|
||||||
| `Drop reason, _ ->
|
|
||||||
Log.debug (fun f ->
|
|
||||||
f "Dropped packet (%s) %a" reason Nat_packet.pp packet);
|
|
||||||
Lwt.return_unit
|
|
||||||
|
|
||||||
let ipv4_from_netvm t packet =
|
|
||||||
match Memory_pressure.status () with
|
|
||||||
| `Memory_critical -> Lwt.return_unit
|
|
||||||
| `Ok -> (
|
|
||||||
let (`IPv4 (ip, _transport)) = packet in
|
|
||||||
let src = classify t (Ipaddr.V4 ip.Ipv4_packet.src) in
|
|
||||||
let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
|
|
||||||
match Packet.of_mirage_nat_packet ~src ~dst packet with
|
|
||||||
| None -> Lwt.return_unit
|
|
||||||
| Some _ -> (
|
|
||||||
match src with
|
|
||||||
| `Client _ | `Firewall ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Frame from NetVM has internal source IP address! %a"
|
|
||||||
Nat_packet.pp packet);
|
|
||||||
Lwt.return_unit
|
|
||||||
| (`External _ | `NetVM) as src -> (
|
|
||||||
match translate t packet with
|
|
||||||
| Some frame -> forward_ipv4 t frame
|
|
||||||
| None -> (
|
|
||||||
match Packet.of_mirage_nat_packet ~src ~dst packet with
|
|
||||||
| None -> Lwt.return_unit
|
|
||||||
| Some packet -> apply_rules t Rules.from_netvm ~dst packet)))
|
|
||||||
)
|
|
||||||
|
|
||||||
let ipv4_from_client resolver dns_servers t ~src packet =
|
|
||||||
match Memory_pressure.status () with
|
|
||||||
| `Memory_critical -> Lwt.return_unit
|
|
||||||
| `Ok -> (
|
|
||||||
(* Check for existing NAT entry for this packet *)
|
|
||||||
match translate t packet with
|
|
||||||
| Some frame ->
|
|
||||||
forward_ipv4 t frame (* Some existing connection or redirect *)
|
|
||||||
| None -> (
|
|
||||||
(* No existing NAT entry. Check the firewall rules. *)
|
|
||||||
let (`IPv4 (ip, _transport)) = packet in
|
|
||||||
match classify t (Ipaddr.V4 ip.Ipv4_packet.src) with
|
|
||||||
| `Client _ | `Firewall -> (
|
|
||||||
let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
|
|
||||||
match
|
|
||||||
Packet.of_mirage_nat_packet ~src:(`Client src) ~dst packet
|
|
||||||
with
|
|
||||||
| None -> Lwt.return_unit
|
|
||||||
| Some firewall_packet ->
|
|
||||||
apply_rules t
|
|
||||||
(Rules.from_client resolver dns_servers)
|
|
||||||
~dst firewall_packet)
|
|
||||||
| `NetVM -> ipv4_from_netvm t packet
|
|
||||||
| `External _ ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Frame from Inside has external source IP address! %a"
|
|
||||||
Nat_packet.pp packet);
|
|
||||||
Lwt.return_unit))
|
|
||||||
|
|
||||||
(** Handle an ARP message from the client. *)
|
|
||||||
let client_handle_arp ~fixed_arp ~iface request =
|
|
||||||
match Arp_packet.decode request with
|
|
||||||
| Error e ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Ignored unknown ARP message: %a" Arp_packet.pp_error e);
|
|
||||||
Lwt.return_unit
|
|
||||||
| Ok arp -> (
|
|
||||||
match Client_eth.ARP.input fixed_arp arp with
|
|
||||||
| None -> Lwt.return_unit
|
|
||||||
| Some response ->
|
|
||||||
Lwt.catch
|
|
||||||
(fun () ->
|
|
||||||
iface#writev `ARP (fun b ->
|
|
||||||
Arp_packet.encode_into response b;
|
|
||||||
Arp_packet.size))
|
|
||||||
(fun ex ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Failed to write APR to %a: %s" Ipaddr.V4.pp iface#other_ip
|
|
||||||
(Printexc.to_string ex));
|
|
||||||
Lwt.return_unit))
|
|
||||||
|
|
||||||
(** Handle an IPv4 packet from the client. *)
|
|
||||||
let client_handle_ipv4 get_ts cache ~iface ~router dns_client dns_servers packet
|
|
||||||
=
|
|
||||||
let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in
|
|
||||||
cache := cache';
|
|
||||||
match r with
|
|
||||||
| Error e ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e);
|
|
||||||
Lwt.return_unit
|
|
||||||
| Ok None -> Lwt.return_unit
|
|
||||||
| Ok (Some packet) ->
|
|
||||||
let (`IPv4 (ip, _)) = packet in
|
|
||||||
let src = ip.Ipv4_packet.src in
|
|
||||||
if src = iface#other_ip then
|
|
||||||
ipv4_from_client dns_client dns_servers router ~src:iface packet
|
|
||||||
else if iface#other_ip = router.config.netvm_ip then
|
|
||||||
(* This can occurs when used with *BSD as netvm (and a gateway is set) *)
|
|
||||||
ipv4_from_netvm router packet
|
|
||||||
else (
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Incorrect source IP %a in IP packet from %a (dropping)"
|
|
||||||
Ipaddr.V4.pp src Ipaddr.V4.pp iface#other_ip);
|
|
||||||
Lwt.return_unit)
|
|
||||||
|
|
||||||
(** Connect to a new client's interface and listen for incoming frames and
|
|
||||||
firewall rule changes. *)
|
|
||||||
let conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip
|
|
||||||
~iface ~router ~cleanup_tasks qubesDB () =
|
|
||||||
let { Dao.ClientVif.domid; device_id } = vif in
|
|
||||||
Log.info (fun f ->
|
|
||||||
f "Client %d:%d (IP: %s) ready" domid device_id
|
|
||||||
(Ipaddr.V4.to_string client_ip));
|
|
||||||
|
|
||||||
(* update the rules whenever QubesDB notices a change for this IP *)
|
|
||||||
let qubesdb_updater =
|
|
||||||
Lwt.catch
|
|
||||||
(fun () ->
|
|
||||||
let rec update current_db current_rules =
|
|
||||||
Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db
|
|
||||||
>>= fun new_db ->
|
|
||||||
iface#set_rules new_db;
|
|
||||||
let new_rules = iface#get_rules in
|
|
||||||
if current_rules = new_rules then
|
|
||||||
Log.info (fun m ->
|
|
||||||
m "Rules did not change for %s" (Ipaddr.V4.to_string client_ip))
|
|
||||||
else (
|
|
||||||
Log.info (fun m ->
|
|
||||||
m "New firewall rules for %s@.%a"
|
|
||||||
(Ipaddr.V4.to_string client_ip)
|
|
||||||
Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule)
|
|
||||||
new_rules);
|
|
||||||
(* empty NAT table if rules are updated: they might deny old connections *)
|
|
||||||
My_nat.remove_connections router.nat client_ip);
|
|
||||||
update new_db new_rules
|
|
||||||
in
|
|
||||||
update Qubes.DB.KeyMap.empty [])
|
|
||||||
(function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e)
|
|
||||||
in
|
|
||||||
Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater);
|
|
||||||
|
|
||||||
let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in
|
|
||||||
let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in
|
|
||||||
let listener =
|
|
||||||
Lwt.catch
|
|
||||||
(fun () ->
|
|
||||||
Netback.listen backend ~header_size:Ethernet.Packet.sizeof_ethernet
|
|
||||||
(fun frame ->
|
|
||||||
match Ethernet.Packet.of_cstruct frame with
|
|
||||||
| Error err ->
|
|
||||||
Log.warn (fun f -> f "Invalid Ethernet frame: %s" err);
|
|
||||||
Lwt.return_unit
|
|
||||||
| Ok (eth, payload) -> (
|
|
||||||
match eth.Ethernet.Packet.ethertype with
|
|
||||||
| `ARP -> client_handle_arp ~fixed_arp ~iface payload
|
|
||||||
| `IPv4 ->
|
|
||||||
client_handle_ipv4 get_ts fragment_cache ~iface ~router
|
|
||||||
dns_client dns_servers payload
|
|
||||||
| `IPv6 -> Lwt.return_unit (* TODO: oh no! *)))
|
|
||||||
>|= or_raise "Listen on client interface" Netback.pp_error)
|
|
||||||
(function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e)
|
|
||||||
in
|
|
||||||
Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener);
|
|
||||||
(* NOTE(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task]
|
|
||||||
will cancel them if the client is disconnected. *)
|
|
||||||
Lwt.async (fun () -> Lwt.pick [ qubesdb_updater; listener ]);
|
|
||||||
Lwt.return_unit
|
|
||||||
|
|
||||||
(** A new client VM has been found in XenStore. Find its interface and connect
|
|
||||||
to it. *)
|
|
||||||
let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB =
|
|
||||||
let open Lwt.Syntax in
|
|
||||||
let cleanup_tasks = Cleanup.create () in
|
|
||||||
Log.info (fun f ->
|
|
||||||
f "add client vif %a with IP %a" Dao.ClientVif.pp vif Ipaddr.V4.pp
|
|
||||||
client_ip);
|
|
||||||
let { Dao.ClientVif.domid; device_id } = vif in
|
|
||||||
let* backend = Netback.make ~domid ~device_id in
|
|
||||||
let* eth = ClientEth.connect backend in
|
|
||||||
let client_mac = Netback.frontend_mac backend in
|
|
||||||
let client_eth = router.clients in
|
|
||||||
let gateway_ip = Client_eth.client_gw client_eth in
|
|
||||||
let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in
|
|
||||||
|
|
||||||
Cleanup.on_cleanup cleanup_tasks (fun () -> remove_client router iface);
|
|
||||||
Lwt.async (fun () ->
|
|
||||||
Lwt.catch
|
|
||||||
(fun () -> add_client router iface)
|
|
||||||
(fun ex ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Error with client %a: %s" Dao.ClientVif.pp vif
|
|
||||||
(Printexc.to_string ex));
|
|
||||||
Lwt.return_unit));
|
|
||||||
|
|
||||||
let* () =
|
|
||||||
Lwt.catch
|
|
||||||
(conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip
|
|
||||||
~iface ~router ~cleanup_tasks qubesDB)
|
|
||||||
@@ fun exn ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Error with client %a: %s" Dao.ClientVif.pp vif
|
|
||||||
(Printexc.to_string exn));
|
|
||||||
Lwt.return_unit
|
|
||||||
in
|
|
||||||
Lwt.return cleanup_tasks
|
|
||||||
|
|
||||||
(** Watch XenStore for notifications of new clients. *)
|
|
||||||
let wait_clients get_ts dns_client dns_servers qubesDB router =
|
|
||||||
let open Lwt.Syntax in
|
|
||||||
let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty in
|
|
||||||
Dao.watch_clients @@ fun new_set ->
|
|
||||||
(* Check for removed clients *)
|
|
||||||
let clean_up_clients key cleanup =
|
|
||||||
if not (Dao.VifMap.mem key new_set) then (
|
|
||||||
clients := !clients |> Dao.VifMap.remove key;
|
|
||||||
Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key);
|
|
||||||
Cleanup.cleanup cleanup)
|
|
||||||
in
|
|
||||||
Dao.VifMap.iter clean_up_clients !clients;
|
|
||||||
(* Check for added clients *)
|
|
||||||
let rec go seq =
|
|
||||||
match Seq.uncons seq with
|
|
||||||
| None -> Lwt.return_unit
|
|
||||||
| Some ((key, ipaddr), seq) when not (Dao.VifMap.mem key !clients) ->
|
|
||||||
let* cleanup =
|
|
||||||
add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB
|
|
||||||
in
|
|
||||||
Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key);
|
|
||||||
clients := Dao.VifMap.add key cleanup !clients;
|
|
||||||
go seq
|
|
||||||
| Some (_, seq) -> go seq
|
|
||||||
in
|
|
||||||
go (Dao.VifMap.to_seq new_set)
|
|
||||||
|
|
||||||
let send_dns_client_query t ~src_port ~dst ~dst_port buf =
|
|
||||||
match t.uplink with
|
|
||||||
| None ->
|
|
||||||
Log.err (fun f -> f "No uplink interface");
|
|
||||||
Lwt.return (Error (`Msg "failure"))
|
|
||||||
| Some uplink ->
|
|
||||||
Lwt.catch
|
|
||||||
(fun () ->
|
|
||||||
U.write ~src_port ~dst ~dst_port uplink.udp (Cstruct.of_string buf)
|
|
||||||
>|= function
|
|
||||||
| Error s ->
|
|
||||||
Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s);
|
|
||||||
Error (`Msg "failure")
|
|
||||||
| Ok () -> Ok ())
|
|
||||||
(fun ex ->
|
|
||||||
Log.err (fun f ->
|
|
||||||
f
|
|
||||||
"uncaught exception trying to send DNS request to uplink: \
|
|
||||||
@[%s@]"
|
|
||||||
(Printexc.to_string ex));
|
|
||||||
Lwt.return (Error (`Msg "DNS request not sent")))
|
|
||||||
|
|
||||||
(** Wait for packet from our uplink (we must have an uplink here...). *)
|
|
||||||
let rec uplink_listen get_ts dns_responses router =
|
|
||||||
Lwt_condition.wait router.uplink_connected >>= fun () ->
|
|
||||||
match router.uplink with
|
|
||||||
| None ->
|
|
||||||
Log.err (fun f ->
|
|
||||||
f "Uplink is connected but not found in the router, retrying...%!");
|
|
||||||
uplink_listen get_ts dns_responses router
|
|
||||||
| Some uplink ->
|
|
||||||
let listen =
|
|
||||||
Lwt.catch
|
|
||||||
(fun () ->
|
|
||||||
Netif.listen uplink.net ~header_size:Ethernet.Packet.sizeof_ethernet
|
|
||||||
(fun frame ->
|
|
||||||
(* Handle one Ethernet frame from NetVM *)
|
|
||||||
UplinkEth.input uplink.eth ~arpv4:(Arp.input uplink.arp)
|
|
||||||
~ipv4:(fun ip ->
|
|
||||||
let cache, r =
|
|
||||||
Nat_packet.of_ipv4_packet uplink.fragments
|
|
||||||
~now:(get_ts ()) ip
|
|
||||||
in
|
|
||||||
uplink.fragments <- cache;
|
|
||||||
match r with
|
|
||||||
| Error e ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Ignored unknown IPv4 message from uplink: %a"
|
|
||||||
Nat_packet.pp_error e);
|
|
||||||
Lwt.return ()
|
|
||||||
| Ok None -> Lwt.return_unit
|
|
||||||
| Ok (Some (`IPv4 (header, packet))) -> (
|
|
||||||
let open Udp_packet in
|
|
||||||
Log.debug (fun f ->
|
|
||||||
f "received ipv4 packet from %a on uplink"
|
|
||||||
Ipaddr.V4.pp header.Ipv4_packet.src);
|
|
||||||
match packet with
|
|
||||||
| `UDP (header, packet)
|
|
||||||
when My_nat.dns_port router.nat header.dst_port ->
|
|
||||||
Log.debug (fun f ->
|
|
||||||
f
|
|
||||||
"found a DNS packet whose dst_port (%d) was \
|
|
||||||
in the list of dns_client ports"
|
|
||||||
header.dst_port);
|
|
||||||
Lwt_mvar.put dns_responses
|
|
||||||
(header, Cstruct.to_string packet)
|
|
||||||
| _ -> ipv4_from_netvm router (`IPv4 (header, packet))))
|
|
||||||
~ipv6:(fun _ip -> Lwt.return_unit)
|
|
||||||
frame)
|
|
||||||
>|= or_raise "Uplink listen loop" Netif.pp_error)
|
|
||||||
(function
|
|
||||||
| Lwt.Canceled ->
|
|
||||||
(* We can be cancelled if reconnect_uplink is achieved (via the Lwt_condition), so we need to disconnect and broadcast when it's done
|
|
||||||
currently we delay 1s as Netif.disconnect is non-blocking... (need to fix upstream?) *)
|
|
||||||
Log.info (fun f -> f "disconnecting from our uplink");
|
|
||||||
U.disconnect uplink.udp >>= fun () ->
|
|
||||||
I.disconnect uplink.ip >>= fun () ->
|
|
||||||
(* mutable fragments : Fragments.Cache.t; *)
|
|
||||||
(* interface : interface; *)
|
|
||||||
Arp.disconnect uplink.arp >>= fun () ->
|
|
||||||
UplinkEth.disconnect uplink.eth >>= fun () ->
|
|
||||||
Netif.disconnect uplink.net >>= fun () ->
|
|
||||||
Lwt_condition.broadcast router.uplink_disconnected ();
|
|
||||||
Lwt.return_unit
|
|
||||||
| e -> Lwt.fail e)
|
|
||||||
in
|
|
||||||
let reconnect_uplink =
|
|
||||||
Lwt_condition.wait router.uplink_disconnect >>= fun () ->
|
|
||||||
Log.info (fun f -> f "we need to reconnect to the new uplink");
|
|
||||||
Lwt.return_unit
|
|
||||||
in
|
|
||||||
Lwt.pick [ listen; reconnect_uplink ] >>= fun () ->
|
|
||||||
uplink_listen get_ts dns_responses router
|
|
||||||
|
|
||||||
(** Connect to our uplink backend (we must have an uplink here...). *)
|
|
||||||
let connect config =
|
|
||||||
let my_ip = config.Dao.our_ip in
|
|
||||||
let gateway = config.Dao.netvm_ip in
|
|
||||||
Netif.connect "0" >>= fun net ->
|
|
||||||
UplinkEth.connect net >>= fun eth ->
|
|
||||||
Arp.connect eth >>= fun arp ->
|
|
||||||
Arp.add_ip arp my_ip >>= fun () ->
|
|
||||||
let cidr = Ipaddr.V4.Prefix.make 0 my_ip in
|
|
||||||
I.connect ~cidr ~gateway eth arp >>= fun ip ->
|
|
||||||
U.connect ip >>= fun udp ->
|
|
||||||
let netvm_mac =
|
|
||||||
Arp.query arp gateway >>= function
|
|
||||||
| Error e ->
|
|
||||||
Log.err (fun f -> f "Getting MAC of our NetVM: %a" Arp.pp_error e);
|
|
||||||
(* This mac address is a special address used by Qubes when the device
|
|
||||||
is not managed by Qubes itself. This can occurs inside a service
|
|
||||||
AppVM (e.g. VPN) when the service creates a new interface. *)
|
|
||||||
Lwt.return (Macaddr.of_string_exn "fe:ff:ff:ff:ff:ff")
|
|
||||||
| Ok mac -> Lwt.return mac
|
|
||||||
in
|
|
||||||
let interface =
|
|
||||||
new netvm_iface eth netvm_mac ~my_ip ~other_ip:config.Dao.netvm_ip
|
|
||||||
in
|
|
||||||
let fragments = Fragments.Cache.empty (256 * 1024) in
|
|
||||||
Lwt.return { net; eth; arp; interface; fragments; ip; udp }
|
|
||||||
|
|
||||||
(** Wait Xenstore for our uplink changes (we must have an uplink here...). *)
|
|
||||||
let uplink_wait_update qubesDB router =
|
|
||||||
let rec aux current_db =
|
|
||||||
let netvm = "/qubes-gateway" in
|
|
||||||
Log.info (fun f -> f "Waiting for netvm changes to %S...%!" netvm);
|
|
||||||
Qubes.DB.after qubesDB current_db >>= fun new_db ->
|
|
||||||
(match (router.uplink, Qubes.DB.KeyMap.find_opt netvm new_db) with
|
|
||||||
| Some uplink, Some netvm
|
|
||||||
when not
|
|
||||||
(String.equal netvm
|
|
||||||
(Ipaddr.V4.to_string uplink.interface#other_ip)) ->
|
|
||||||
Log.info (fun f ->
|
|
||||||
f "Our netvm IP has changed, before it was %s, now it's: %s%!"
|
|
||||||
(Ipaddr.V4.to_string uplink.interface#other_ip)
|
|
||||||
netvm);
|
|
||||||
Lwt_condition.broadcast router.uplink_disconnect ();
|
|
||||||
(* wait for uplink disconnexion *)
|
|
||||||
Lwt_condition.wait router.uplink_disconnected >>= fun () ->
|
|
||||||
Dao.read_network_config qubesDB >>= fun config ->
|
|
||||||
Dao.print_network_config config;
|
|
||||||
connect config >>= fun uplink ->
|
|
||||||
update router ~config ~uplink:(Some uplink) >>= fun () ->
|
|
||||||
Lwt_condition.broadcast router.uplink_connected ();
|
|
||||||
Lwt.return_unit
|
|
||||||
| None, Some _ ->
|
|
||||||
(* a new interface is attributed to qubes-mirage-firewall *)
|
|
||||||
Log.info (fun f -> f "Going from netvm not connected to %s%!" netvm);
|
|
||||||
Dao.read_network_config qubesDB >>= fun config ->
|
|
||||||
Dao.print_network_config config;
|
|
||||||
connect config >>= fun uplink ->
|
|
||||||
update router ~config ~uplink:(Some uplink) >>= fun () ->
|
|
||||||
Lwt_condition.broadcast router.uplink_connected ();
|
|
||||||
Lwt.return_unit
|
|
||||||
| Some _, None ->
|
|
||||||
(* This currently is never triggered :( *)
|
|
||||||
Log.info (fun f ->
|
|
||||||
f "TODO: Our netvm disapeared, troubles are coming!%!");
|
|
||||||
Lwt.return_unit
|
|
||||||
| Some _, Some _ (* The new netvm IP is unchanged (it's our old netvm IP) *)
|
|
||||||
| None, None ->
|
|
||||||
Log.info (fun f ->
|
|
||||||
f "QubesDB has changed but not the situation of our netvm!%!");
|
|
||||||
Lwt.return_unit)
|
|
||||||
>>= fun () -> aux new_db
|
|
||||||
in
|
|
||||||
aux Qubes.DB.KeyMap.empty
|
|
||||||
129
firewall.ml
Normal file
129
firewall.ml
Normal file
|
|
@ -0,0 +1,129 @@
|
||||||
|
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
|
See the README file for details. *)
|
||||||
|
|
||||||
|
open Packet
|
||||||
|
open Lwt.Infix
|
||||||
|
|
||||||
|
let src = Logs.Src.create "firewall" ~doc:"Packet handler"
|
||||||
|
module Log = (val Logs.src_log src : Logs.LOG)
|
||||||
|
|
||||||
|
(* Transmission *)
|
||||||
|
|
||||||
|
let transmit_ipv4 packet iface =
|
||||||
|
Lwt.catch
|
||||||
|
(fun () ->
|
||||||
|
let fragments = ref [] in
|
||||||
|
iface#writev `IPv4 (fun b ->
|
||||||
|
match Nat_packet.into_cstruct packet b with
|
||||||
|
| Error e ->
|
||||||
|
Log.warn (fun f -> f "Failed to write packet to %a: %a"
|
||||||
|
Ipaddr.V4.pp iface#other_ip
|
||||||
|
Nat_packet.pp_error e);
|
||||||
|
0
|
||||||
|
| Ok (n, frags) -> fragments := frags ; n) >>= fun () ->
|
||||||
|
Lwt_list.iter_s (fun f ->
|
||||||
|
let size = Cstruct.len f in
|
||||||
|
iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size))
|
||||||
|
!fragments)
|
||||||
|
(fun ex ->
|
||||||
|
Log.warn (fun f -> f "Failed to write packet to %a: %s"
|
||||||
|
Ipaddr.V4.pp iface#other_ip
|
||||||
|
(Printexc.to_string ex));
|
||||||
|
Lwt.return_unit
|
||||||
|
)
|
||||||
|
|
||||||
|
let forward_ipv4 t packet =
|
||||||
|
let `IPv4 (ip, _) = packet in
|
||||||
|
match Router.target t ip with
|
||||||
|
| Some iface -> transmit_ipv4 packet iface
|
||||||
|
| None -> Lwt.return_unit
|
||||||
|
|
||||||
|
(* NAT *)
|
||||||
|
|
||||||
|
let translate t packet =
|
||||||
|
My_nat.translate t.Router.nat packet
|
||||||
|
|
||||||
|
(* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *)
|
||||||
|
let add_nat_and_forward_ipv4 t packet =
|
||||||
|
let open Router in
|
||||||
|
let xl_host = t.uplink#my_ip in
|
||||||
|
My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host `NAT packet >>= function
|
||||||
|
| Ok packet -> forward_ipv4 t packet
|
||||||
|
| Error e ->
|
||||||
|
Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet);
|
||||||
|
Lwt.return_unit
|
||||||
|
|
||||||
|
(* Add a NAT rule to redirect this conversation to [host:port] instead of us. *)
|
||||||
|
let nat_to t ~host ~port packet =
|
||||||
|
let open Router in
|
||||||
|
match resolve t host with
|
||||||
|
| Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit
|
||||||
|
| Ipaddr.V4 target ->
|
||||||
|
let xl_host = t.uplink#my_ip in
|
||||||
|
My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host (`Redirect (target, port)) packet >>= function
|
||||||
|
| Ok packet -> forward_ipv4 t packet
|
||||||
|
| Error e ->
|
||||||
|
Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp packet);
|
||||||
|
Lwt.return_unit
|
||||||
|
|
||||||
|
let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst (annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t =
|
||||||
|
let packet = to_mirage_nat_packet annotated_packet in
|
||||||
|
rules annotated_packet >>= fun action ->
|
||||||
|
match action, dst with
|
||||||
|
| `Accept, `Client client_link -> transmit_ipv4 packet client_link
|
||||||
|
| `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink
|
||||||
|
| `Accept, `Firewall ->
|
||||||
|
Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet);
|
||||||
|
Lwt.return_unit
|
||||||
|
| `NAT, _ ->
|
||||||
|
Log.debug (fun f -> f "adding NAT rule for %a" Nat_packet.pp packet);
|
||||||
|
add_nat_and_forward_ipv4 t packet
|
||||||
|
| `NAT_to (host, port), _ -> nat_to t packet ~host ~port
|
||||||
|
| `Drop reason, _ ->
|
||||||
|
Log.debug (fun f -> f "Dropped packet (%s) %a" reason Nat_packet.pp packet);
|
||||||
|
Lwt.return_unit
|
||||||
|
|
||||||
|
let handle_low_memory t =
|
||||||
|
match Memory_pressure.status () with
|
||||||
|
| `Memory_critical -> (* TODO: should happen before copying and async *)
|
||||||
|
Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table");
|
||||||
|
My_nat.reset t.Router.nat t.Router.ports >|= fun () ->
|
||||||
|
`Memory_critical
|
||||||
|
| `Ok -> Lwt.return `Ok
|
||||||
|
|
||||||
|
let ipv4_from_client resolver t ~src packet =
|
||||||
|
handle_low_memory t >>= function
|
||||||
|
| `Memory_critical -> Lwt.return_unit
|
||||||
|
| `Ok ->
|
||||||
|
(* Check for existing NAT entry for this packet *)
|
||||||
|
translate t packet >>= function
|
||||||
|
| Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *)
|
||||||
|
| None ->
|
||||||
|
(* No existing NAT entry. Check the firewall rules. *)
|
||||||
|
let `IPv4 (ip, _transport) = packet in
|
||||||
|
let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
|
||||||
|
match of_mirage_nat_packet ~src:(`Client src) ~dst packet with
|
||||||
|
| None -> Lwt.return_unit
|
||||||
|
| Some firewall_packet -> apply_rules t (Rules.from_client resolver) ~dst firewall_packet
|
||||||
|
|
||||||
|
let ipv4_from_netvm t packet =
|
||||||
|
handle_low_memory t >>= function
|
||||||
|
| `Memory_critical -> Lwt.return_unit
|
||||||
|
| `Ok ->
|
||||||
|
let `IPv4 (ip, _transport) = packet in
|
||||||
|
let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) in
|
||||||
|
let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
|
||||||
|
match Packet.of_mirage_nat_packet ~src ~dst packet with
|
||||||
|
| None -> Lwt.return_unit
|
||||||
|
| Some _ ->
|
||||||
|
match src with
|
||||||
|
| `Client _ | `Firewall ->
|
||||||
|
Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" Nat_packet.pp packet);
|
||||||
|
Lwt.return_unit
|
||||||
|
| `External _ | `NetVM as src ->
|
||||||
|
translate t packet >>= function
|
||||||
|
| Some frame -> forward_ipv4 t frame
|
||||||
|
| None ->
|
||||||
|
match Packet.of_mirage_nat_packet ~src ~dst packet with
|
||||||
|
| None -> Lwt.return_unit
|
||||||
|
| Some packet -> apply_rules t Rules.from_netvm ~dst packet
|
||||||
13
firewall.mli
Normal file
13
firewall.mli
Normal file
|
|
@ -0,0 +1,13 @@
|
||||||
|
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
|
See the README file for details. *)
|
||||||
|
|
||||||
|
(** Classify IP packets, apply rules and send as appropriate. *)
|
||||||
|
|
||||||
|
val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t
|
||||||
|
(** Handle a packet from the outside world (this module will validate the source IP). *)
|
||||||
|
|
||||||
|
(* TODO the function type is a workaround, rework the module dependencies / functors to get rid of it *)
|
||||||
|
val ipv4_from_client : ([ `host ] Domain_name.t -> (int32 * Dns.Rr_map.Ipv4_set.t, [> `Msg of string ]) result Lwt.t) ->
|
||||||
|
Router.t -> src:Fw_utils.client_link -> Nat_packet.t -> unit Lwt.t
|
||||||
|
(** Handle a packet from a client. Caller must check the source IP matches the client's
|
||||||
|
before calling this. *)
|
||||||
32
frameQ.ml
Normal file
32
frameQ.ml
Normal file
|
|
@ -0,0 +1,32 @@
|
||||||
|
(* Copyright (C) 2016, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
|
See the README file for details. *)
|
||||||
|
|
||||||
|
let src = Logs.Src.create "frameQ" ~doc:"Interface output queue"
|
||||||
|
module Log = (val Logs.src_log src : Logs.LOG)
|
||||||
|
|
||||||
|
type t = {
|
||||||
|
name : string;
|
||||||
|
mutable items : int;
|
||||||
|
}
|
||||||
|
|
||||||
|
let create name = { name; items = 0 }
|
||||||
|
|
||||||
|
(* Note: the queue is only used if we already filled the transmit buffer. *)
|
||||||
|
let max_qlen = 10
|
||||||
|
|
||||||
|
let send q fn =
|
||||||
|
if q.items = max_qlen then (
|
||||||
|
Log.warn (fun f -> f "Maximum queue length exceeded for %s: dropping frame" q.name);
|
||||||
|
Lwt.return_unit
|
||||||
|
) else (
|
||||||
|
let sent = fn () in
|
||||||
|
if Lwt.state sent = Lwt.Sleep then (
|
||||||
|
q.items <- q.items + 1;
|
||||||
|
Log.info (fun f -> f "Queue length for %s: incr to %d" q.name q.items);
|
||||||
|
Lwt.on_termination sent (fun () ->
|
||||||
|
q.items <- q.items - 1;
|
||||||
|
Log.info (fun f -> f "Queue length for %s: decr to %d" q.name q.items);
|
||||||
|
)
|
||||||
|
);
|
||||||
|
sent
|
||||||
|
)
|
||||||
15
frameQ.mli
Normal file
15
frameQ.mli
Normal file
|
|
@ -0,0 +1,15 @@
|
||||||
|
(* Copyright (C) 2016, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
|
See the README file for details. *)
|
||||||
|
|
||||||
|
(** Keep track of the queue length for output buffers. *)
|
||||||
|
|
||||||
|
type t
|
||||||
|
|
||||||
|
val create : string -> t
|
||||||
|
(** [create name] is a new empty queue. [name] is used in log messages. *)
|
||||||
|
|
||||||
|
val send : t -> (unit -> unit Lwt.t) -> unit Lwt.t
|
||||||
|
(** [send t fn] checks that the queue isn't overloaded and calls [fn ()] if it's OK.
|
||||||
|
The item is considered to be queued until the result of [fn] has resolved.
|
||||||
|
In the case of mirage-net-xen's [writev], this happens when the frame has been
|
||||||
|
added to the ring (not when it is consumed), which is fine for us. *)
|
||||||
31
fw_utils.ml
31
fw_utils.ml
|
|
@ -3,10 +3,25 @@
|
||||||
|
|
||||||
(** General utility functions. *)
|
(** General utility functions. *)
|
||||||
|
|
||||||
|
module IpMap = struct
|
||||||
|
include Map.Make(Ipaddr.V4)
|
||||||
|
let find x map =
|
||||||
|
try Some (find x map)
|
||||||
|
with Not_found -> None
|
||||||
|
end
|
||||||
|
|
||||||
|
module Int = struct
|
||||||
|
type t = int
|
||||||
|
let compare (a:t) (b:t) = compare a b
|
||||||
|
end
|
||||||
|
|
||||||
|
module IntSet = Set.Make(Int)
|
||||||
|
module IntMap = Map.Make(Int)
|
||||||
|
|
||||||
(** An Ethernet interface. *)
|
(** An Ethernet interface. *)
|
||||||
class type interface = object
|
class type interface = object
|
||||||
method my_mac : Macaddr.t
|
method my_mac : Macaddr.t
|
||||||
method writev : Ethernet.Packet.proto -> (Cstruct.t -> int) -> unit Lwt.t
|
method writev : Mirage_protocols.Ethernet.proto -> (Cstruct.t -> int) -> unit Lwt.t
|
||||||
method my_ip : Ipaddr.V4.t
|
method my_ip : Ipaddr.V4.t
|
||||||
method other_ip : Ipaddr.V4.t
|
method other_ip : Ipaddr.V4.t
|
||||||
end
|
end
|
||||||
|
|
@ -15,16 +30,14 @@ end
|
||||||
class type client_link = object
|
class type client_link = object
|
||||||
inherit interface
|
inherit interface
|
||||||
method other_mac : Macaddr.t
|
method other_mac : Macaddr.t
|
||||||
method log_header : string (* For log messages *)
|
method log_header : string (* For log messages *)
|
||||||
method get_rules : Pf_qubes.Parse_qubes.rule list
|
method get_rules: Pf_qubes.Parse_qubes.rule list
|
||||||
method set_rules : string Qubes.DB.KeyMap.t -> unit
|
method set_rules: string Qubes.DB.KeyMap.t -> unit
|
||||||
end
|
end
|
||||||
|
|
||||||
(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload.
|
(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *)
|
||||||
*)
|
|
||||||
let eth_header ethertype ~src ~dst =
|
let eth_header ethertype ~src ~dst =
|
||||||
Ethernet.Packet.make_cstruct
|
Ethernet_packet.Marshal.make_cstruct { Ethernet_packet.source = src; destination = dst; ethertype }
|
||||||
{ Ethernet.Packet.source = src; destination = dst; ethertype }
|
|
||||||
|
|
||||||
let error fmt =
|
let error fmt =
|
||||||
let err s = Failure s in
|
let err s = Failure s in
|
||||||
|
|
@ -32,4 +45,4 @@ let error fmt =
|
||||||
|
|
||||||
let or_raise msg pp = function
|
let or_raise msg pp = function
|
||||||
| Ok x -> x
|
| Ok x -> x
|
||||||
| Error e -> failwith (Fmt.str "%s: %a" msg pp e)
|
| Error e -> failwith (Fmt.strf "%s: %a" msg pp e)
|
||||||
|
|
|
||||||
|
|
@ -1,21 +1,49 @@
|
||||||
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
See the README file for details. *)
|
See the README file for details. *)
|
||||||
|
|
||||||
let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor"
|
open Lwt
|
||||||
|
|
||||||
|
let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor"
|
||||||
module Log = (val Logs.src_log src : Logs.LOG)
|
module Log = (val Logs.src_log src : Logs.LOG)
|
||||||
|
|
||||||
let fraction_free stats =
|
let total_pages = OS.MM.Heap_pages.total ()
|
||||||
let { Xen_os.Memory.free_words; heap_words; _ } = stats in
|
let pagesize_kb = Io_page.page_size / 1024
|
||||||
float free_words /. float heap_words
|
|
||||||
|
|
||||||
let init () = Gc.full_major ()
|
let meminfo ~used =
|
||||||
|
let mem_total = total_pages * pagesize_kb in
|
||||||
|
let mem_free = (total_pages - used) * pagesize_kb in
|
||||||
|
Log.info (fun f -> f "Writing meminfo: free %d / %d kB (%.2f %%)"
|
||||||
|
mem_free mem_total (float_of_int mem_free /. float_of_int mem_total *. 100.0));
|
||||||
|
Printf.sprintf "MemTotal: %d kB\n\
|
||||||
|
MemFree: %d kB\n\
|
||||||
|
Buffers: 0 kB\n\
|
||||||
|
Cached: 0 kB\n\
|
||||||
|
SwapTotal: 0 kB\n\
|
||||||
|
SwapFree: 0 kB\n" mem_total mem_free
|
||||||
|
|
||||||
|
let report_mem_usage used =
|
||||||
|
Lwt.async (fun () ->
|
||||||
|
let open OS in
|
||||||
|
Xs.make () >>= fun xs ->
|
||||||
|
Xs.immediate xs (fun h ->
|
||||||
|
Xs.write h "memory/meminfo" (meminfo ~used)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
|
let init () =
|
||||||
|
Gc.full_major ();
|
||||||
|
let used = OS.MM.Heap_pages.used () in
|
||||||
|
report_mem_usage used
|
||||||
|
|
||||||
let status () =
|
let status () =
|
||||||
let stats = Xen_os.Memory.quick_stat () in
|
let used = OS.MM.Heap_pages.used () |> float_of_int in
|
||||||
if fraction_free stats > 0.5 then `Ok
|
let frac = used /. float_of_int total_pages in
|
||||||
|
if frac < 0.9 then `Ok
|
||||||
else (
|
else (
|
||||||
Gc.full_major ();
|
Gc.full_major ();
|
||||||
Xen_os.Memory.trim ();
|
let used = OS.MM.Heap_pages.used () in
|
||||||
let stats = Xen_os.Memory.quick_stat () in
|
report_mem_usage used;
|
||||||
if fraction_free stats < 0.6 then `Memory_critical else `Ok)
|
let frac = float_of_int used /. float_of_int total_pages in
|
||||||
|
if frac > 0.9 then `Memory_critical
|
||||||
|
else `Ok
|
||||||
|
)
|
||||||
|
|
|
||||||
|
|
@ -8,5 +8,5 @@ val status : unit -> [ `Ok | `Memory_critical ]
|
||||||
(** Check the memory situation. If we're running low, do a GC (work-around for
|
(** Check the memory situation. If we're running low, do a GC (work-around for
|
||||||
http://caml.inria.fr/mantis/view.php?id=7100 and OCaml GC needing to malloc
|
http://caml.inria.fr/mantis/view.php?id=7100 and OCaml GC needing to malloc
|
||||||
extra space to run finalisers). Returns [`Memory_critical] if memory is
|
extra space to run finalisers). Returns [`Memory_critical] if memory is
|
||||||
still low - caller should take action to reduce memory use. After GC,
|
still low - caller should take action to reduce memory use.
|
||||||
updates meminfo in XenStore. *)
|
After GC, updates meminfo in XenStore. *)
|
||||||
|
|
|
||||||
112
my_dns.ml
112
my_dns.ml
|
|
@ -1,81 +1,57 @@
|
||||||
open Lwt.Infix
|
open Lwt.Infix
|
||||||
|
|
||||||
type +'a io = 'a Lwt.t
|
module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct
|
||||||
type io_addr = Ipaddr.V4.t * int
|
type +'a io = 'a Lwt.t
|
||||||
|
type io_addr = Ipaddr.V4.t * int
|
||||||
|
type ns_addr = [ `TCP | `UDP ] * io_addr
|
||||||
|
type stack = Router.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * Cstruct.t) Lwt_mvar.t
|
||||||
|
|
||||||
type stack =
|
type t = {
|
||||||
Dispatcher.t
|
nameserver : ns_addr ;
|
||||||
* (src_port:int ->
|
stack : stack ;
|
||||||
dst:Ipaddr.V4.t ->
|
timeout_ns : int64 ;
|
||||||
dst_port:int ->
|
}
|
||||||
string ->
|
type context = { t : t ; timeout_ns : int64 ref; mutable src_port : int }
|
||||||
(unit, [ `Msg of string ]) result Lwt.t)
|
|
||||||
* (Udp_packet.t * string) Lwt_mvar.t
|
|
||||||
|
|
||||||
module IM = Map.Make (Int)
|
let nameserver t = t.nameserver
|
||||||
|
let rng = R.generate ?g:None
|
||||||
|
let clock = C.elapsed_ns
|
||||||
|
|
||||||
type t = {
|
let create ?(nameserver = `UDP, (Ipaddr.V4.of_string_exn "91.239.100.100", 53)) ~timeout stack =
|
||||||
protocol : Dns.proto;
|
{ nameserver ; stack ; timeout_ns = timeout }
|
||||||
nameserver : io_addr;
|
|
||||||
stack : stack;
|
|
||||||
timeout_ns : int64;
|
|
||||||
mutable requests : string Lwt_condition.t IM.t;
|
|
||||||
}
|
|
||||||
|
|
||||||
type context = t
|
let with_timeout ctx f =
|
||||||
|
let timeout = OS.Time.sleep_ns !(ctx.timeout_ns) >|= fun () -> Error (`Msg "DNS request timeout") in
|
||||||
|
let start = clock () in
|
||||||
|
Lwt.pick [ f ; timeout ] >|= fun result ->
|
||||||
|
let stop = clock () in
|
||||||
|
ctx.timeout_ns := Int64.sub !(ctx.timeout_ns) (Int64.sub stop start);
|
||||||
|
result
|
||||||
|
|
||||||
let nameservers { protocol; nameserver; _ } = (protocol, [ nameserver ])
|
let connect ?nameserver:_ (t : t) = Lwt.return (Ok { t ; timeout_ns = ref t.timeout_ns ; src_port = 0 })
|
||||||
let rng = Mirage_crypto_rng.generate ?g:None
|
|
||||||
let clock = Mirage_mtime.elapsed_ns
|
|
||||||
|
|
||||||
let rec read t =
|
let send (ctx : context) buf : (unit, [> `Msg of string ]) result Lwt.t =
|
||||||
let _, _, answer = t.stack in
|
let open Router in
|
||||||
Lwt_mvar.take answer >>= fun (_, data) ->
|
let open My_nat in
|
||||||
(if String.length data > 2 then
|
let dst, dst_port = snd ctx.t.nameserver in
|
||||||
match IM.find_opt (String.get_uint16_be data 0) t.requests with
|
let router, send_udp, _ = ctx.t.stack in
|
||||||
| Some cond -> Lwt_condition.broadcast cond data
|
let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in
|
||||||
| None -> ());
|
ctx.src_port <- src_port;
|
||||||
read t
|
with_timeout ctx (send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg)
|
||||||
|
|
||||||
let create ?nameservers ~timeout stack =
|
let recv ctx =
|
||||||
let protocol, nameserver =
|
let open Router in
|
||||||
match nameservers with
|
let open My_nat in
|
||||||
| None | Some (_, []) -> invalid_arg "no nameserver found"
|
let router, _, answers = ctx.t.stack in
|
||||||
| Some (proto, ns :: _) -> (proto, ns)
|
with_timeout ctx
|
||||||
in
|
(Lwt_mvar.take answers >|= fun (_, dns_response) -> Ok dns_response) >|= fun result ->
|
||||||
let t =
|
router.ports.dns_udp := Ports.remove ctx.src_port !(router.ports.dns_udp);
|
||||||
{ protocol; nameserver; stack; timeout_ns = timeout; requests = IM.empty }
|
result
|
||||||
in
|
|
||||||
Lwt.async (fun () -> read t);
|
|
||||||
t
|
|
||||||
|
|
||||||
let with_timeout timeout_ns f =
|
let close _ = Lwt.return_unit
|
||||||
let timeout =
|
|
||||||
Mirage_sleep.ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout")
|
|
||||||
in
|
|
||||||
Lwt.pick [ f; timeout ]
|
|
||||||
|
|
||||||
let connect (t : t) = Lwt.return (Ok (t.protocol, t))
|
let bind = Lwt.bind
|
||||||
|
|
||||||
let send_recv (ctx : context) buf : (string, [> `Msg of string ]) result Lwt.t =
|
let lift = Lwt.return
|
||||||
let dst, dst_port = ctx.nameserver in
|
end
|
||||||
let router, send_udp, _ = ctx.stack in
|
|
||||||
let src_port, evict =
|
|
||||||
My_nat.free_udp_port router.nat ~src:router.config.our_ip ~dst ~dst_port:53
|
|
||||||
in
|
|
||||||
let id = String.get_uint16_be buf 0 in
|
|
||||||
with_timeout ctx.timeout_ns
|
|
||||||
(let cond = Lwt_condition.create () in
|
|
||||||
ctx.requests <- IM.add id cond ctx.requests;
|
|
||||||
send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg
|
|
||||||
>>= function
|
|
||||||
| Ok () -> Lwt_condition.wait cond >|= fun dns_response -> Ok dns_response
|
|
||||||
| Error _ as e -> Lwt.return e)
|
|
||||||
>|= fun result ->
|
|
||||||
ctx.requests <- IM.remove id ctx.requests;
|
|
||||||
evict ();
|
|
||||||
result
|
|
||||||
|
|
||||||
let close _ = Lwt.return_unit
|
|
||||||
let bind = Lwt.bind
|
|
||||||
let lift = Lwt.return
|
|
||||||
|
|
|
||||||
155
my_nat.ml
155
my_nat.ml
|
|
@ -1,86 +1,109 @@
|
||||||
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
See the README file for details. *)
|
See the README file for details. *)
|
||||||
|
|
||||||
let src = Logs.Src.create "my-nat" ~doc:"NAT shim"
|
open Lwt.Infix
|
||||||
|
|
||||||
|
let src = Logs.Src.create "my-nat" ~doc:"NAT shim"
|
||||||
module Log = (val Logs.src_log src : Logs.LOG)
|
module Log = (val Logs.src_log src : Logs.LOG)
|
||||||
|
|
||||||
type action = [ `NAT | `Redirect of Mirage_nat.endpoint ]
|
type action = [
|
||||||
|
| `NAT
|
||||||
|
| `Redirect of Mirage_nat.endpoint
|
||||||
|
]
|
||||||
|
|
||||||
|
type ports = {
|
||||||
|
nat_tcp : Ports.t ref;
|
||||||
|
nat_udp : Ports.t ref;
|
||||||
|
nat_icmp : Ports.t ref;
|
||||||
|
dns_udp : Ports.t ref;
|
||||||
|
}
|
||||||
|
|
||||||
|
let empty_ports () =
|
||||||
|
let nat_tcp = ref Ports.empty in
|
||||||
|
let nat_udp = ref Ports.empty in
|
||||||
|
let nat_icmp = ref Ports.empty in
|
||||||
|
let dns_udp = ref Ports.empty in
|
||||||
|
{ nat_tcp ; nat_udp ; nat_icmp ; dns_udp }
|
||||||
|
|
||||||
module Nat = Mirage_nat_lru
|
module Nat = Mirage_nat_lru
|
||||||
|
|
||||||
module S = Set.Make (struct
|
type t = {
|
||||||
type t = int
|
table : Nat.t;
|
||||||
|
}
|
||||||
let compare (a : int) (b : int) = compare a b
|
|
||||||
end)
|
|
||||||
|
|
||||||
type t = { table : Nat.t; mutable udp_dns : S.t; last_resort_port : int }
|
|
||||||
|
|
||||||
let pick_port () = 1024 + Random.int (0xffff - 1024)
|
|
||||||
|
|
||||||
let create ~max_entries =
|
let create ~max_entries =
|
||||||
let tcp_size = 7 * max_entries / 8 in
|
let tcp_size = 7 * max_entries / 8 in
|
||||||
let udp_size = max_entries - tcp_size in
|
let udp_size = max_entries - tcp_size in
|
||||||
let table = Nat.empty ~tcp_size ~udp_size ~icmp_size:100 in
|
Nat.empty ~tcp_size ~udp_size ~icmp_size:100 >|= fun table ->
|
||||||
let last_resort_port = pick_port () in
|
{ table }
|
||||||
{ table; udp_dns = S.empty; last_resort_port }
|
|
||||||
|
|
||||||
let pick_free_port t proto =
|
|
||||||
let rec go retries =
|
|
||||||
if retries = 0 then None
|
|
||||||
else
|
|
||||||
let p = 1024 + Random.int (0xffff - 1024) in
|
|
||||||
match proto with
|
|
||||||
| `Udp when S.mem p t.udp_dns || p = t.last_resort_port -> go (retries - 1)
|
|
||||||
| _ -> Some p
|
|
||||||
in
|
|
||||||
go 10
|
|
||||||
|
|
||||||
let free_udp_port t ~src ~dst ~dst_port =
|
|
||||||
let rec go retries =
|
|
||||||
if retries = 0 then (t.last_resort_port, Fun.id)
|
|
||||||
else
|
|
||||||
let src_port =
|
|
||||||
Option.value ~default:t.last_resort_port (pick_free_port t `Udp)
|
|
||||||
in
|
|
||||||
if Nat.is_port_free t.table `Udp ~src ~dst ~src_port ~dst_port then
|
|
||||||
let remove =
|
|
||||||
if src_port <> t.last_resort_port then (
|
|
||||||
t.udp_dns <- S.add src_port t.udp_dns;
|
|
||||||
fun () -> t.udp_dns <- S.remove src_port t.udp_dns)
|
|
||||||
else Fun.id
|
|
||||||
in
|
|
||||||
(src_port, remove)
|
|
||||||
else go (retries - 1)
|
|
||||||
in
|
|
||||||
go 10
|
|
||||||
|
|
||||||
let dns_port t port = S.mem port t.udp_dns || port = t.last_resort_port
|
|
||||||
|
|
||||||
let translate t packet =
|
let translate t packet =
|
||||||
match Nat.translate t.table packet with
|
Nat.translate t.table packet >|= function
|
||||||
| Error ((`Untranslated | `TTL_exceeded) as e) ->
|
| Error (`Untranslated | `TTL_exceeded as e) ->
|
||||||
Log.debug (fun f ->
|
Log.debug (fun f -> f "Failed to NAT %a: %a"
|
||||||
f "Failed to NAT %a: %a" Nat_packet.pp packet Mirage_nat.pp_error e);
|
Nat_packet.pp packet
|
||||||
None
|
Mirage_nat.pp_error e
|
||||||
|
);
|
||||||
|
None
|
||||||
| Ok packet -> Some packet
|
| Ok packet -> Some packet
|
||||||
|
|
||||||
let remove_connections t ip = ignore (Nat.remove_connections t.table ip)
|
let pick_free_port ~nat_ports ~dns_ports =
|
||||||
|
Ports.pick_free_port ~consult:dns_ports nat_ports
|
||||||
|
|
||||||
let add_nat_rule_and_translate t ~xl_host action packet =
|
(* just clears the nat ports, dns ports stay as is *)
|
||||||
let proto =
|
let reset t ports =
|
||||||
match packet with
|
ports.nat_tcp := Ports.empty;
|
||||||
| `IPv4 (_, `TCP _) -> `Tcp
|
ports.nat_udp := Ports.empty;
|
||||||
| `IPv4 (_, `UDP _) -> `Udp
|
ports.nat_icmp := Ports.empty;
|
||||||
| `IPv4 (_, `ICMP _) -> `Icmp
|
Nat.reset t.table
|
||||||
|
|
||||||
|
let remove_connections t ports ip =
|
||||||
|
let freed_ports = Nat.remove_connections t.table ip in
|
||||||
|
ports.nat_tcp := Ports.diff !(ports.nat_tcp) (Ports.of_list freed_ports.Mirage_nat.tcp);
|
||||||
|
ports.nat_udp := Ports.diff !(ports.nat_udp) (Ports.of_list freed_ports.Mirage_nat.udp);
|
||||||
|
ports.nat_icmp := Ports.diff !(ports.nat_icmp) (Ports.of_list freed_ports.Mirage_nat.icmp)
|
||||||
|
|
||||||
|
let add_nat_rule_and_translate t ports ~xl_host action packet =
|
||||||
|
let apply_action xl_port =
|
||||||
|
Lwt.catch (fun () ->
|
||||||
|
Nat.add t.table packet (xl_host, xl_port) action
|
||||||
|
)
|
||||||
|
(function
|
||||||
|
| Out_of_memory -> Lwt.return (Error `Out_of_memory)
|
||||||
|
| x -> Lwt.fail x
|
||||||
|
)
|
||||||
in
|
in
|
||||||
match
|
let rec aux ~retries =
|
||||||
Nat.add t.table packet xl_host (fun () -> pick_free_port t proto) action
|
let nat_ports, dns_ports =
|
||||||
with
|
match packet with
|
||||||
| Error `Overlap -> Error "Too many retries"
|
| `IPv4 (_, `TCP _) -> ports.nat_tcp, ref Ports.empty
|
||||||
| Error `Cannot_NAT -> Error "Cannot NAT this packet"
|
| `IPv4 (_, `UDP _) -> ports.nat_udp, ports.dns_udp
|
||||||
| Ok () ->
|
| `IPv4 (_, `ICMP _) -> ports.nat_icmp, ref Ports.empty
|
||||||
|
in
|
||||||
|
let xl_port = pick_free_port ~nat_ports ~dns_ports in
|
||||||
|
apply_action xl_port >>= function
|
||||||
|
| Error `Out_of_memory ->
|
||||||
|
(* Because hash tables resize in big steps, this can happen even if we have a fair
|
||||||
|
chunk of free memory. *)
|
||||||
|
Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table...");
|
||||||
|
reset t ports >>= fun () ->
|
||||||
|
aux ~retries:(retries - 1)
|
||||||
|
| Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries")
|
||||||
|
| Error `Overlap ->
|
||||||
|
if retries = 0 then (
|
||||||
|
Log.warn (fun f -> f "Failed to find a free port; resetting NAT table");
|
||||||
|
reset t ports >>= fun () ->
|
||||||
|
aux ~retries:(retries - 1)
|
||||||
|
) else (
|
||||||
|
aux ~retries:(retries - 1)
|
||||||
|
)
|
||||||
|
| Error `Cannot_NAT ->
|
||||||
|
Lwt.return (Error "Cannot NAT this packet")
|
||||||
|
| Ok () ->
|
||||||
Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table);
|
Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table);
|
||||||
Option.to_result ~none:"No NAT entry, even after adding one!"
|
translate t packet >|= function
|
||||||
(translate t packet)
|
| None -> Error "No NAT entry, even after adding one!"
|
||||||
|
| Some packet ->
|
||||||
|
Ok packet
|
||||||
|
in
|
||||||
|
aux ~retries:100
|
||||||
|
|
|
||||||
37
my_nat.mli
37
my_nat.mli
|
|
@ -3,24 +3,25 @@
|
||||||
|
|
||||||
(* Abstract over NAT interface (todo: remove this) *)
|
(* Abstract over NAT interface (todo: remove this) *)
|
||||||
|
|
||||||
|
type ports = private {
|
||||||
|
nat_tcp : Ports.t ref;
|
||||||
|
nat_udp : Ports.t ref;
|
||||||
|
nat_icmp : Ports.t ref;
|
||||||
|
dns_udp : Ports.t ref;
|
||||||
|
}
|
||||||
|
|
||||||
|
val empty_ports : unit -> ports
|
||||||
|
|
||||||
type t
|
type t
|
||||||
type action = [ `NAT | `Redirect of Mirage_nat.endpoint ]
|
|
||||||
|
|
||||||
val free_udp_port :
|
type action = [
|
||||||
t ->
|
| `NAT
|
||||||
src:Ipaddr.V4.t ->
|
| `Redirect of Mirage_nat.endpoint
|
||||||
dst:Ipaddr.V4.t ->
|
]
|
||||||
dst_port:int ->
|
|
||||||
int * (unit -> unit)
|
|
||||||
|
|
||||||
val dns_port : t -> int -> bool
|
val create : max_entries:int -> t Lwt.t
|
||||||
val create : max_entries:int -> t
|
val reset : t -> ports -> unit Lwt.t
|
||||||
val remove_connections : t -> Ipaddr.V4.t -> unit
|
val remove_connections : t -> ports -> Ipaddr.V4.t -> unit
|
||||||
val translate : t -> Nat_packet.t -> Nat_packet.t option
|
val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t
|
||||||
|
val add_nat_rule_and_translate : t -> ports ->
|
||||||
val add_nat_rule_and_translate :
|
xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t
|
||||||
t ->
|
|
||||||
xl_host:Ipaddr.V4.t ->
|
|
||||||
action ->
|
|
||||||
Nat_packet.t ->
|
|
||||||
(Nat_packet.t, string) result
|
|
||||||
|
|
|
||||||
46
packet.ml
46
packet.ml
|
|
@ -8,8 +8,9 @@ type port = int
|
||||||
type host =
|
type host =
|
||||||
[ `Client of client_link | `Firewall | `NetVM | `External of Ipaddr.t ]
|
[ `Client of client_link | `Firewall | `NetVM | `External of Ipaddr.t ]
|
||||||
|
|
||||||
type transport_header =
|
type transport_header = [`TCP of Tcp.Tcp_packet.t
|
||||||
[ `TCP of Tcp.Tcp_packet.t | `UDP of Udp_packet.t | `ICMP of Icmpv4_packet.t ]
|
|`UDP of Udp_packet.t
|
||||||
|
|`ICMP of Icmpv4_packet.t]
|
||||||
|
|
||||||
type ('src, 'dst) t = {
|
type ('src, 'dst) t = {
|
||||||
ipv4_header : Ipv4_packet.t;
|
ipv4_header : Ipv4_packet.t;
|
||||||
|
|
@ -18,14 +19,13 @@ type ('src, 'dst) t = {
|
||||||
src : 'src;
|
src : 'src;
|
||||||
dst : 'dst;
|
dst : 'dst;
|
||||||
}
|
}
|
||||||
|
|
||||||
let pp_transport_header f = function
|
let pp_transport_header f = function
|
||||||
| `ICMP h -> Icmpv4_packet.pp f h
|
| `ICMP h -> Icmpv4_packet.pp f h
|
||||||
| `TCP h -> Tcp.Tcp_packet.pp f h
|
| `TCP h -> Tcp.Tcp_packet.pp f h
|
||||||
| `UDP h -> Udp_packet.pp f h
|
| `UDP h -> Udp_packet.pp f h
|
||||||
|
|
||||||
let pp_host fmt = function
|
let pp_host fmt = function
|
||||||
| `Client c -> Ipaddr.V4.pp fmt c#other_ip
|
| `Client c -> Ipaddr.V4.pp fmt (c#other_ip)
|
||||||
| `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp ip
|
| `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp ip
|
||||||
| `NetVM -> Format.pp_print_string fmt "net-vm"
|
| `NetVM -> Format.pp_print_string fmt "net-vm"
|
||||||
| `External ip -> Format.fprintf fmt "external(%a)" Ipaddr.pp ip
|
| `External ip -> Format.fprintf fmt "external(%a)" Ipaddr.pp ip
|
||||||
|
|
@ -33,28 +33,32 @@ let pp_host fmt = function
|
||||||
|
|
||||||
let to_mirage_nat_packet t : Nat_packet.t =
|
let to_mirage_nat_packet t : Nat_packet.t =
|
||||||
match t.transport_header with
|
match t.transport_header with
|
||||||
| `TCP h -> `IPv4 (t.ipv4_header, `TCP (h, t.transport_payload))
|
| `TCP h -> `IPv4 (t.ipv4_header, (`TCP (h, t.transport_payload)))
|
||||||
| `UDP h -> `IPv4 (t.ipv4_header, `UDP (h, t.transport_payload))
|
| `UDP h -> `IPv4 (t.ipv4_header, (`UDP (h, t.transport_payload)))
|
||||||
| `ICMP h -> `IPv4 (t.ipv4_header, `ICMP (h, t.transport_payload))
|
| `ICMP h -> `IPv4 (t.ipv4_header, (`ICMP (h, t.transport_payload)))
|
||||||
|
|
||||||
let of_mirage_nat_packet ~src ~dst packet : ('a, 'b) t option =
|
let of_mirage_nat_packet ~src ~dst packet : ('a, 'b) t option =
|
||||||
let (`IPv4 (ipv4_header, ipv4_payload)) = packet in
|
let `IPv4 (ipv4_header, ipv4_payload) = packet in
|
||||||
let transport_header, transport_payload =
|
let transport_header, transport_payload = match ipv4_payload with
|
||||||
match ipv4_payload with
|
| `TCP (h, p) -> `TCP h, p
|
||||||
| `TCP (h, p) -> (`TCP h, p)
|
| `UDP (h, p) -> `UDP h, p
|
||||||
| `UDP (h, p) -> (`UDP h, p)
|
| `ICMP (h, p) -> `ICMP h, p
|
||||||
| `ICMP (h, p) -> (`ICMP h, p)
|
|
||||||
in
|
in
|
||||||
Some { ipv4_header; transport_header; transport_payload; src; dst }
|
Some {
|
||||||
|
ipv4_header;
|
||||||
|
transport_header;
|
||||||
|
transport_payload;
|
||||||
|
src;
|
||||||
|
dst;
|
||||||
|
}
|
||||||
|
|
||||||
(* possible actions to take for a packet: *)
|
(* possible actions to take for a packet: *)
|
||||||
type action =
|
type action = [
|
||||||
[ `Accept (* Send to destination, unmodified. *)
|
| `Accept (* Send to destination, unmodified. *)
|
||||||
| `NAT
|
| `NAT (* Rewrite source field to the firewall's IP, with a fresh source port.
|
||||||
(* Rewrite source field to the firewall's IP, with a fresh source port.
|
|
||||||
Also, add translation rules for future traffic in both directions,
|
Also, add translation rules for future traffic in both directions,
|
||||||
between these hosts on these ports, and corresponding ICMP error traffic. *)
|
between these hosts on these ports, and corresponding ICMP error traffic. *)
|
||||||
| `NAT_to of host * port
|
| `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's
|
||||||
(* As for [`NAT], but also rewrite the packet's
|
|
||||||
destination fields so it will be sent to [host:port]. *)
|
destination fields so it will be sent to [host:port]. *)
|
||||||
| `Drop of string (* Drop packet for this reason. *) ]
|
| `Drop of string (* Drop packet for this reason. *)
|
||||||
|
]
|
||||||
|
|
|
||||||
30
packet.mli
30
packet.mli
|
|
@ -1,13 +1,15 @@
|
||||||
type port = int
|
type port = int
|
||||||
|
|
||||||
type host =
|
type host =
|
||||||
[ `Client of Fw_utils.client_link (** an IP address on the private network *)
|
[ `Client of Fw_utils.client_link (** an IP address on the private network *)
|
||||||
| `Firewall (** the firewall's IP on the private network *)
|
| `Firewall (** the firewall's IP on the private network *)
|
||||||
| `NetVM (** the IP of the firewall's default route *)
|
| `NetVM (** the IP of the firewall's default route *)
|
||||||
| `External of Ipaddr.t (** an IP on the public network *) ]
|
| `External of Ipaddr.t (** an IP on the public network *)
|
||||||
|
]
|
||||||
|
|
||||||
type transport_header =
|
type transport_header = [`TCP of Tcp.Tcp_packet.t
|
||||||
[ `TCP of Tcp.Tcp_packet.t | `UDP of Udp_packet.t | `ICMP of Icmpv4_packet.t ]
|
|`UDP of Udp_packet.t
|
||||||
|
|`ICMP of Icmpv4_packet.t]
|
||||||
|
|
||||||
type ('src, 'dst) t = {
|
type ('src, 'dst) t = {
|
||||||
ipv4_header : Ipv4_packet.t;
|
ipv4_header : Ipv4_packet.t;
|
||||||
|
|
@ -18,18 +20,20 @@ type ('src, 'dst) t = {
|
||||||
}
|
}
|
||||||
|
|
||||||
val pp_transport_header : Format.formatter -> transport_header -> unit
|
val pp_transport_header : Format.formatter -> transport_header -> unit
|
||||||
|
|
||||||
val pp_host : Format.formatter -> host -> unit
|
val pp_host : Format.formatter -> host -> unit
|
||||||
|
|
||||||
val to_mirage_nat_packet : ('a, 'b) t -> Nat_packet.t
|
val to_mirage_nat_packet : ('a, 'b) t -> Nat_packet.t
|
||||||
|
|
||||||
val of_mirage_nat_packet : src:'a -> dst:'b -> Nat_packet.t -> ('a, 'b) t option
|
val of_mirage_nat_packet : src:'a -> dst:'b -> Nat_packet.t -> ('a, 'b) t option
|
||||||
|
|
||||||
(* possible actions to take for a packet: *)
|
(* possible actions to take for a packet: *)
|
||||||
type action =
|
type action = [
|
||||||
[ `Accept (* Send to destination, unmodified. *)
|
| `Accept (* Send to destination, unmodified. *)
|
||||||
| `NAT
|
| `NAT (* Rewrite source field to the firewall's IP, with a fresh source port.
|
||||||
(* Rewrite source field to the firewall's IP, with a fresh source port.
|
|
||||||
Also, add translation rules for future traffic in both directions,
|
Also, add translation rules for future traffic in both directions,
|
||||||
between these hosts on these ports, and corresponding ICMP error traffic. *)
|
between these hosts on these ports, and corresponding ICMP error traffic. *)
|
||||||
| `NAT_to of host * port
|
| `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's
|
||||||
(* As for [`NAT], but also rewrite the packet's
|
|
||||||
destination fields so it will be sent to [host:port]. *)
|
destination fields so it will be sent to [host:port]. *)
|
||||||
| `Drop of string (* Drop packet for this reason. *) ]
|
| `Drop of string (* Drop packet for this reason. *)
|
||||||
|
]
|
||||||
|
|
|
||||||
16
ports.ml
Normal file
16
ports.ml
Normal file
|
|
@ -0,0 +1,16 @@
|
||||||
|
module Set = Set.Make(struct
|
||||||
|
type t = int
|
||||||
|
let compare a b = compare a b
|
||||||
|
end)
|
||||||
|
|
||||||
|
include Set
|
||||||
|
|
||||||
|
let rec pick_free_port ?(retries = 10) ~consult add_to =
|
||||||
|
let p = 1024 + Random.int (0xffff - 1024) in
|
||||||
|
if (mem p !consult || mem p !add_to) && retries <> 0
|
||||||
|
then pick_free_port ~retries:(retries - 1) ~consult add_to
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
add_to := add p !add_to;
|
||||||
|
p
|
||||||
|
end
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
0c3c2c0e62a834112c69d7cddc5dd6f70ecb93afa988768fb860ed26e423b1f8 dist/qubes-firewall.xen
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
ac049069b35f786fa11b18a2261d7dbecd588301af0363ef6888ec9d924dc989 dist/qubes-firewall.xen
|
|
||||||
37
router.ml
Normal file
37
router.ml
Normal file
|
|
@ -0,0 +1,37 @@
|
||||||
|
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
|
See the README file for details. *)
|
||||||
|
|
||||||
|
open Fw_utils
|
||||||
|
|
||||||
|
(* The routing table *)
|
||||||
|
|
||||||
|
type t = {
|
||||||
|
client_eth : Client_eth.t;
|
||||||
|
nat : My_nat.t;
|
||||||
|
uplink : interface;
|
||||||
|
(* NOTE: do not try to make this pure, it relies on mvars / side effects *)
|
||||||
|
ports : My_nat.ports;
|
||||||
|
}
|
||||||
|
|
||||||
|
let create ~client_eth ~uplink ~nat =
|
||||||
|
let ports = My_nat.empty_ports () in
|
||||||
|
{ client_eth; nat; uplink; ports }
|
||||||
|
|
||||||
|
let target t buf =
|
||||||
|
let dst_ip = buf.Ipv4_packet.dst in
|
||||||
|
match Client_eth.lookup t.client_eth dst_ip with
|
||||||
|
| Some client_link -> Some (client_link :> interface)
|
||||||
|
| None -> Some t.uplink
|
||||||
|
|
||||||
|
let add_client t = Client_eth.add_client t.client_eth
|
||||||
|
let remove_client t = Client_eth.remove_client t.client_eth
|
||||||
|
|
||||||
|
let classify t ip =
|
||||||
|
if ip = Ipaddr.V4 t.uplink#my_ip then `Firewall
|
||||||
|
else if ip = Ipaddr.V4 t.uplink#other_ip then `NetVM
|
||||||
|
else (Client_eth.classify t.client_eth ip :> Packet.host)
|
||||||
|
|
||||||
|
let resolve t = function
|
||||||
|
| `Firewall -> Ipaddr.V4 t.uplink#my_ip
|
||||||
|
| `NetVM -> Ipaddr.V4 t.uplink#other_ip
|
||||||
|
| #Client_eth.host as host -> Client_eth.resolve t.client_eth host
|
||||||
32
router.mli
Normal file
32
router.mli
Normal file
|
|
@ -0,0 +1,32 @@
|
||||||
|
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
|
See the README file for details. *)
|
||||||
|
|
||||||
|
(** Routing packets to the right network interface. *)
|
||||||
|
|
||||||
|
open Fw_utils
|
||||||
|
|
||||||
|
type t = private {
|
||||||
|
client_eth : Client_eth.t;
|
||||||
|
nat : My_nat.t;
|
||||||
|
uplink : interface;
|
||||||
|
ports : My_nat.ports;
|
||||||
|
}
|
||||||
|
|
||||||
|
val create :
|
||||||
|
client_eth:Client_eth.t ->
|
||||||
|
uplink:interface ->
|
||||||
|
nat:My_nat.t ->
|
||||||
|
t
|
||||||
|
(** [create ~client_eth ~uplink ~nat] is a new routing table
|
||||||
|
that routes packets outside of [client_eth] via [uplink]. *)
|
||||||
|
|
||||||
|
val target : t -> Ipv4_packet.t -> interface option
|
||||||
|
(** [target t packet] is the interface to which [packet] should be routed. *)
|
||||||
|
|
||||||
|
val add_client : t -> client_link -> unit Lwt.t
|
||||||
|
(** [add_client t iface] adds a rule for routing packets addressed to [iface]. *)
|
||||||
|
|
||||||
|
val remove_client : t -> client_link -> unit
|
||||||
|
|
||||||
|
val classify : t -> Ipaddr.t -> Packet.host
|
||||||
|
val resolve : t -> Packet.host -> Ipaddr.t
|
||||||
136
rules.ml
136
rules.ml
|
|
@ -8,115 +8,103 @@ open Lwt.Infix
|
||||||
module Q = Pf_qubes.Parse_qubes
|
module Q = Pf_qubes.Parse_qubes
|
||||||
|
|
||||||
let src = Logs.Src.create "rules" ~doc:"Firewall rules"
|
let src = Logs.Src.create "rules" ~doc:"Firewall rules"
|
||||||
|
|
||||||
module Log = (val Logs.src_log src : Logs.LOG)
|
module Log = (val Logs.src_log src : Logs.LOG)
|
||||||
|
|
||||||
|
(* the upstream NetVM will redirect TCP and UDP port 53 traffic with
|
||||||
|
these destination IPs to its upstream nameserver. *)
|
||||||
|
let default_dns_servers = [
|
||||||
|
Ipaddr.V4.of_string_exn "10.139.1.1";
|
||||||
|
Ipaddr.V4.of_string_exn "10.139.1.2";
|
||||||
|
]
|
||||||
let dns_port = 53
|
let dns_port = 53
|
||||||
|
|
||||||
module Classifier = struct
|
module Classifier = struct
|
||||||
let matches_port dstports (port : int) =
|
|
||||||
match dstports with
|
let matches_port dstports (port : int) = match dstports with
|
||||||
| None -> true
|
| None -> true
|
||||||
| Some (Q.Range_inclusive (min, max)) -> min <= port && port <= max
|
| Some (Q.Range_inclusive (min, max)) -> min <= port && port <= max
|
||||||
|
|
||||||
let matches_proto rule dns_servers packet =
|
let matches_proto rule packet = match rule.Q.proto, rule.Q.specialtarget with
|
||||||
match (rule.Q.proto, rule.Q.specialtarget) with
|
|
||||||
| None, None -> true
|
| None, None -> true
|
||||||
| None, Some `dns
|
| None, Some `dns when List.mem packet.ipv4_header.Ipv4_packet.dst default_dns_servers -> begin
|
||||||
when List.mem packet.ipv4_header.Ipv4_packet.dst dns_servers -> (
|
(* specialtarget=dns applies only to the specialtarget destination IPs, and
|
||||||
(* specialtarget=dns applies only to the specialtarget destination IPs, and
|
|
||||||
specialtarget=dns is also implicitly tcp/udp port 53 *)
|
specialtarget=dns is also implicitly tcp/udp port 53 *)
|
||||||
match packet.transport_header with
|
match packet.transport_header with
|
||||||
| `TCP header -> header.Tcp.Tcp_packet.dst_port = dns_port
|
| `TCP header -> header.Tcp.Tcp_packet.dst_port = dns_port
|
||||||
| `UDP header -> header.Udp_packet.dst_port = dns_port
|
| `UDP header -> header.Udp_packet.dst_port = dns_port
|
||||||
| _ -> false)
|
| _ -> false
|
||||||
(* DNS rules can only match traffic headed to the specialtarget hosts, so any other destination
|
end
|
||||||
|
(* DNS rules can only match traffic headed to the specialtarget hosts, so any other destination
|
||||||
isn't a match for DNS rules *)
|
isn't a match for DNS rules *)
|
||||||
| None, Some `dns -> false
|
| None, Some `dns -> false
|
||||||
| Some rule_proto, _ -> (
|
| Some rule_proto, _ -> match rule_proto, packet.transport_header with
|
||||||
match (rule_proto, packet.transport_header) with
|
| `tcp, `TCP header -> matches_port rule.Q.dstports header.Tcp.Tcp_packet.dst_port
|
||||||
| `tcp, `TCP header ->
|
| `udp, `UDP header -> matches_port rule.Q.dstports header.Udp_packet.dst_port
|
||||||
matches_port rule.Q.dstports header.Tcp.Tcp_packet.dst_port
|
| `icmp, `ICMP header ->
|
||||||
| `udp, `UDP header ->
|
begin
|
||||||
matches_port rule.Q.dstports header.Udp_packet.dst_port
|
match rule.Q.icmp_type with
|
||||||
| `icmp, `ICMP header -> (
|
| None -> true
|
||||||
match rule.Q.icmp_type with
|
| Some rule_icmp_type ->
|
||||||
| None -> true
|
0 = compare rule_icmp_type @@ Icmpv4_wire.ty_to_int header.Icmpv4_packet.ty
|
||||||
| Some rule_icmp_type ->
|
end
|
||||||
0
|
| _, _ -> false
|
||||||
= compare rule_icmp_type
|
|
||||||
@@ Icmpv4_wire.ty_to_int header.Icmpv4_packet.ty)
|
|
||||||
| _, _ -> false)
|
|
||||||
|
|
||||||
let matches_dest dns_client rule packet =
|
let matches_dest dns_client rule packet =
|
||||||
let ip = packet.ipv4_header.Ipv4_packet.dst in
|
let ip = packet.ipv4_header.Ipv4_packet.dst in
|
||||||
match rule.Q.dst with
|
match rule.Q.dst with
|
||||||
| `any -> Lwt.return @@ `Match rule
|
| `any -> Lwt.return @@ `Match rule
|
||||||
| `hosts subnet ->
|
| `hosts subnet ->
|
||||||
Lwt.return
|
Lwt.return @@ if (Ipaddr.Prefix.mem Ipaddr.(V4 ip) subnet) then `Match rule else `No_match
|
||||||
@@
|
| `dnsname name ->
|
||||||
if Ipaddr.Prefix.mem Ipaddr.(V4 ip) subnet then `Match rule
|
Log.debug (fun f -> f "Resolving %a" Domain_name.pp name);
|
||||||
|
dns_client name >|= function
|
||||||
|
| Ok (_ttl, found_ips) ->
|
||||||
|
if Dns.Rr_map.Ipv4_set.mem ip found_ips
|
||||||
|
then `Match rule
|
||||||
else `No_match
|
else `No_match
|
||||||
| `dnsname name -> (
|
| Error (`Msg m) ->
|
||||||
Log.debug (fun f -> f "Resolving %a" Domain_name.pp name);
|
Log.warn (fun f -> f "Ignoring rule %a, could not resolve" Q.pp_rule rule);
|
||||||
dns_client name >|= function
|
Log.debug (fun f -> f "%s" m);
|
||||||
| Ok (_ttl, found_ips) ->
|
`No_match
|
||||||
if Ipaddr.V4.Set.mem ip found_ips then `Match rule else `No_match
|
| Error _ -> assert false (* TODO: fix type of dns_client so that this case can go *)
|
||||||
| Error (`Msg m) ->
|
|
||||||
Log.warn (fun f ->
|
|
||||||
f "Ignoring rule %a, could not resolve" Q.pp_rule rule);
|
|
||||||
Log.debug (fun f -> f "%s" m);
|
|
||||||
`No_match
|
|
||||||
| Error _ ->
|
|
||||||
assert
|
|
||||||
false (* TODO: fix type of dns_client so that this case can go *))
|
|
||||||
end
|
end
|
||||||
|
|
||||||
let find_first_match dns_client dns_servers packet acc rule =
|
let find_first_match dns_client packet acc rule =
|
||||||
match acc with
|
match acc with
|
||||||
| `No_match ->
|
| `No_match ->
|
||||||
if Classifier.matches_proto rule dns_servers packet then
|
if Classifier.matches_proto rule packet
|
||||||
Classifier.matches_dest dns_client rule packet
|
then Classifier.matches_dest dns_client rule packet
|
||||||
else Lwt.return `No_match
|
else Lwt.return `No_match
|
||||||
| q -> Lwt.return q
|
| q -> Lwt.return q
|
||||||
|
|
||||||
(* Does the packet match our rules? *)
|
(* Does the packet match our rules? *)
|
||||||
let classify_client_packet dns_client dns_servers
|
let classify_client_packet dns_client (packet : ([`Client of Fw_utils.client_link], _) Packet.t) =
|
||||||
(packet : ([ `Client of Fw_utils.client_link ], _) Packet.t) =
|
|
||||||
let (`Client client_link) = packet.src in
|
let (`Client client_link) = packet.src in
|
||||||
let rules = client_link#get_rules in
|
let rules = client_link#get_rules in
|
||||||
Lwt_list.fold_left_s
|
Lwt_list.fold_left_s (find_first_match dns_client packet) `No_match rules >|= function
|
||||||
(find_first_match dns_client dns_servers packet)
|
|
||||||
`No_match rules
|
|
||||||
>|= function
|
|
||||||
| `No_match -> `Drop "No matching rule; assuming default drop"
|
| `No_match -> `Drop "No matching rule; assuming default drop"
|
||||||
| `Match { Q.action = Q.Accept; _ } -> `Accept
|
| `Match {Q.action = Q.Accept; _} -> `Accept
|
||||||
| `Match ({ Q.action = Q.Drop; _ } as rule) ->
|
| `Match ({Q.action = Q.Drop; _} as rule) ->
|
||||||
`Drop
|
`Drop (Format.asprintf "rule number %a explicitly drops this packet" Q.pp_rule rule)
|
||||||
(Format.asprintf "rule number %a explicitly drops this packet" Q.pp_rule
|
|
||||||
rule)
|
|
||||||
|
|
||||||
let translate_accepted_packets dns_client dns_servers packet =
|
let translate_accepted_packets dns_client packet =
|
||||||
classify_client_packet dns_client dns_servers packet >|= function
|
classify_client_packet dns_client packet >|= function
|
||||||
| `Accept -> `NAT
|
| `Accept -> `NAT
|
||||||
| `Drop s -> `Drop s
|
| `Drop s -> `Drop s
|
||||||
|
|
||||||
(** Packets from the private interface that don't match any NAT table entry are
|
(** Packets from the private interface that don't match any NAT table entry are being checked against the fw rules here *)
|
||||||
being checked against the fw rules here *)
|
let from_client dns_client (packet : ([`Client of Fw_utils.client_link], _) Packet.t) : Packet.action Lwt.t =
|
||||||
let from_client dns_client dns_servers
|
|
||||||
(packet : ([ `Client of Fw_utils.client_link ], _) Packet.t) :
|
|
||||||
Packet.action Lwt.t =
|
|
||||||
match packet with
|
match packet with
|
||||||
| { dst = `External _; _ } | { dst = `NetVM; _ } ->
|
| { dst = `Firewall; transport_header = `UDP header; _ } ->
|
||||||
translate_accepted_packets dns_client dns_servers packet
|
if header.Udp_packet.dst_port = dns_port
|
||||||
| { dst = `Firewall; _ } ->
|
then Lwt.return @@ `NAT_to (`NetVM, dns_port)
|
||||||
Lwt.return @@ `Drop "packet addressed to firewall itself"
|
else Lwt.return @@ `Drop "packet addressed to client gateway"
|
||||||
| { dst = `Client _; _ } ->
|
| { dst = `External _ ; _ } | { dst = `NetVM; _ } -> translate_accepted_packets dns_client packet
|
||||||
classify_client_packet dns_client dns_servers packet
|
| { dst = `Firewall ; _ } -> Lwt.return @@ `Drop "packet addressed to firewall itself"
|
||||||
|
| { dst = `Client _ ; _ } -> classify_client_packet dns_client packet
|
||||||
| _ -> Lwt.return @@ `Drop "could not classify packet"
|
| _ -> Lwt.return @@ `Drop "could not classify packet"
|
||||||
|
|
||||||
(** Packets from the outside world that don't match any NAT table entry are
|
(** Packets from the outside world that don't match any NAT table entry are being dropped by default *)
|
||||||
being dropped by default *)
|
let from_netvm (_packet : ([`NetVM | `External of _], _) Packet.t) : Packet.action Lwt.t =
|
||||||
let from_netvm (_packet : ([ `NetVM | `External of _ ], _) Packet.t) :
|
|
||||||
Packet.action Lwt.t =
|
|
||||||
Lwt.return @@ `Drop "drop by default"
|
Lwt.return @@ `Drop "drop by default"
|
||||||
|
|
|
||||||
|
|
@ -2,32 +2,26 @@ open Mirage
|
||||||
|
|
||||||
let pin = "git+https://github.com/roburio/alcotest.git#mirage"
|
let pin = "git+https://github.com/roburio/alcotest.git#mirage"
|
||||||
|
|
||||||
let packages =
|
let packages = [
|
||||||
[
|
package "ethernet";
|
||||||
package "ethernet";
|
package "arp";
|
||||||
package "arp";
|
package "arp-mirage";
|
||||||
package "arp-mirage";
|
package "ipaddr";
|
||||||
package "ipaddr";
|
package "tcpip" ~sublibs:["stack-direct"; "icmpv4"; "ipv4"; "udp"; "tcp"];
|
||||||
package "tcpip" ~sublibs:[ "stack-direct"; "icmpv4"; "ipv4"; "udp"; "tcp" ];
|
package "mirage-qubes";
|
||||||
package "mirage-qubes";
|
package "mirage-qubes-ipv4";
|
||||||
package "mirage-qubes-ipv4";
|
package "dns-client" ~sublibs:["mirage"];
|
||||||
package "dns-client" ~sublibs:[ "mirage" ];
|
package ~pin "alcotest";
|
||||||
package ~pin "alcotest";
|
package ~pin "alcotest-mirage";
|
||||||
package ~pin "alcotest-mirage";
|
]
|
||||||
]
|
|
||||||
|
|
||||||
let client =
|
let client =
|
||||||
foreign ~packages "Unikernel.Client"
|
foreign ~packages
|
||||||
@@ random @-> time @-> mclock @-> network @-> qubesdb @-> job
|
"Unikernel.Client" @@ random @-> time @-> mclock @-> network @-> qubesdb @-> job
|
||||||
|
|
||||||
let db = default_qubesdb
|
let db = default_qubesdb
|
||||||
let network = default_network
|
let network = default_network
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
let job =
|
let job = [ client $ default_random $ default_time $ default_monotonic_clock $ network $ db ] in
|
||||||
[
|
|
||||||
client $ default_random $ default_time $ default_monotonic_clock $ network
|
|
||||||
$ db;
|
|
||||||
]
|
|
||||||
in
|
|
||||||
register "http-fetch" job
|
register "http-fetch" job
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,6 @@
|
||||||
open Lwt.Infix
|
open Lwt.Infix
|
||||||
|
|
||||||
(* https://www.qubes-os.org/doc/vm-interface/#firewall-rules-in-4x *)
|
(* https://www.qubes-os.org/doc/vm-interface/#firewall-rules-in-4x *)
|
||||||
let src = Logs.Src.create "firewall test" ~doc:"Firewalltest"
|
let src = Logs.Src.create "firewall test" ~doc:"Firewalltest"
|
||||||
|
|
||||||
module Log = (val Logs.src_log src : Logs.LOG)
|
module Log = (val Logs.src_log src : Logs.LOG)
|
||||||
|
|
||||||
(* TODO
|
(* TODO
|
||||||
|
|
@ -41,24 +39,18 @@ module Log = (val Logs.src_log src : Logs.LOG)
|
||||||
|
|
||||||
(* Point-to-point links out of a netvm always have this IP TODO clarify with Marek *)
|
(* Point-to-point links out of a netvm always have this IP TODO clarify with Marek *)
|
||||||
let netvm = "10.137.0.5"
|
let netvm = "10.137.0.5"
|
||||||
|
|
||||||
(* default "nameserver"s, which netvm redirects to whatever its real nameservers are *)
|
(* default "nameserver"s, which netvm redirects to whatever its real nameservers are *)
|
||||||
let nameserver_1, nameserver_2 = ("10.139.1.1", "10.139.1.2")
|
let nameserver_1, nameserver_2 = "10.139.1.1", "10.139.1.2"
|
||||||
|
|
||||||
module Client
|
module Client (R: Mirage_random.S) (Time: Mirage_time.S) (Clock : Mirage_clock.MCLOCK) (NET: Mirage_net.S) (DB : Qubes.S.DB) = struct
|
||||||
(R : Mirage_crypto_rng_mirage.S)
|
module E = Ethernet.Make(NET)
|
||||||
(Time : Mirage_time.S)
|
module A = Arp.Make(E)(Time)
|
||||||
(Clock : Mirage_clock.MCLOCK)
|
module I = Qubesdb_ipv4.Make(DB)(R)(Clock)(E)(A)
|
||||||
(NET : Mirage_net.S)
|
module Icmp = Icmpv4.Make(I)
|
||||||
(DB : Qubes.S.DB) =
|
module U = Udp.Make(I)(R)
|
||||||
struct
|
module T = Tcp.Flow.Make(I)(Time)(Clock)(R)
|
||||||
module E = Ethernet.Make (NET)
|
|
||||||
module A = Arp.Make (E) (Time)
|
module Alcotest = Alcotest_mirage.Make(Clock)
|
||||||
module I = Qubesdb_ipv4.Make (DB) (R) (Clock) (E) (A)
|
|
||||||
module Icmp = Icmpv4.Make (I)
|
|
||||||
module U = Udp.Make (I) (R)
|
|
||||||
module T = Tcp.Flow.Make (I) (Time) (Clock) (R)
|
|
||||||
module Alcotest = Alcotest_mirage.Make (Clock)
|
|
||||||
|
|
||||||
module Stack = struct
|
module Stack = struct
|
||||||
(* A Mirage_stack.V4 implementation which diverts DHCP messages to a DHCP
|
(* A Mirage_stack.V4 implementation which diverts DHCP messages to a DHCP
|
||||||
|
|
@ -74,77 +66,67 @@ struct
|
||||||
module IPV4 = I
|
module IPV4 = I
|
||||||
|
|
||||||
type t = {
|
type t = {
|
||||||
net : NET.t;
|
net : NET.t ; eth : E.t ; arp : A.t ;
|
||||||
eth : E.t;
|
ip : I.t ; icmp : Icmp.t ; udp : U.t ; tcp : T.t ;
|
||||||
arp : A.t;
|
udp_listeners : (int, U.callback) Hashtbl.t ;
|
||||||
ip : I.t;
|
tcp_listeners : (int, T.listener) Hashtbl.t ;
|
||||||
icmp : Icmp.t;
|
mutable icmp_listener : (src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> Cstruct.t -> unit Lwt.t) option ;
|
||||||
udp : U.t;
|
|
||||||
tcp : T.t;
|
|
||||||
udp_listeners : (int, U.callback) Hashtbl.t;
|
|
||||||
tcp_listeners : (int, T.listener) Hashtbl.t;
|
|
||||||
mutable icmp_listener :
|
|
||||||
(src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> Cstruct.t -> unit Lwt.t) option;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
let ipv4 { ip; _ } = ip
|
let ipv4 { ip ; _ } = ip
|
||||||
let udpv4 { udp; _ } = udp
|
let udpv4 { udp ; _ } = udp
|
||||||
let tcpv4 { tcp; _ } = tcp
|
let tcpv4 { tcp ; _ } = tcp
|
||||||
let icmpv4 { icmp; _ } = icmp
|
let icmpv4 { icmp ; _ } = icmp
|
||||||
|
|
||||||
let listener h port = Hashtbl.find_opt h port
|
let listener h port = Hashtbl.find_opt h port
|
||||||
let udp_listener h ~dst_port = listener h dst_port
|
let udp_listener h ~dst_port = listener h dst_port
|
||||||
|
|
||||||
let listen_udpv4 { udp_listeners; _ } ~port cb =
|
let listen_udpv4 { udp_listeners ; _ } ~port cb =
|
||||||
Hashtbl.replace udp_listeners port cb
|
Hashtbl.replace udp_listeners port cb
|
||||||
|
|
||||||
let stop_listen_udpv4 { udp_listeners; _ } ~port =
|
let stop_listen_udpv4 { udp_listeners ; _ } ~port =
|
||||||
Hashtbl.remove udp_listeners port
|
Hashtbl.remove udp_listeners port
|
||||||
|
|
||||||
let listen_tcpv4 ?keepalive { tcp_listeners; _ } ~port cb =
|
let listen_tcpv4 ?keepalive { tcp_listeners ; _ } ~port cb =
|
||||||
Hashtbl.replace tcp_listeners port { T.process = cb; T.keepalive }
|
Hashtbl.replace tcp_listeners port { T.process = cb ; T.keepalive }
|
||||||
|
|
||||||
let stop_listen_tcpv4 { tcp_listeners; _ } ~port =
|
let stop_listen_tcpv4 { tcp_listeners ; _ } ~port =
|
||||||
Hashtbl.remove tcp_listeners port
|
Hashtbl.remove tcp_listeners port
|
||||||
|
|
||||||
let listen_icmp t cb = t.icmp_listener <- cb
|
let listen_icmp t cb = t.icmp_listener <- cb
|
||||||
|
|
||||||
let listen t =
|
let listen t =
|
||||||
let ethif_listener =
|
let ethif_listener =
|
||||||
E.input ~arpv4:(A.input t.arp)
|
E.input
|
||||||
~ipv4:
|
~arpv4:(A.input t.arp)
|
||||||
(I.input
|
~ipv4:(
|
||||||
~tcp:(T.input t.tcp ~listeners:(listener t.tcp_listeners))
|
I.input
|
||||||
~udp:(U.input t.udp ~listeners:(udp_listener t.udp_listeners))
|
~tcp:(T.input t.tcp ~listeners:(listener t.tcp_listeners))
|
||||||
~default:(fun ~proto ~src ~dst buf ->
|
~udp:(U.input t.udp ~listeners:(udp_listener t.udp_listeners))
|
||||||
match proto with
|
~default:(fun ~proto ~src ~dst buf ->
|
||||||
| 1 -> (
|
match proto with
|
||||||
match t.icmp_listener with
|
| 1 ->
|
||||||
|
begin match t.icmp_listener with
|
||||||
| None -> Icmp.input t.icmp ~src ~dst buf
|
| None -> Icmp.input t.icmp ~src ~dst buf
|
||||||
| Some cb -> cb ~src ~dst buf)
|
| Some cb -> cb ~src ~dst buf
|
||||||
| _ -> Lwt.return_unit)
|
end
|
||||||
t.ip)
|
| _ -> Lwt.return_unit)
|
||||||
|
t.ip)
|
||||||
~ipv6:(fun _ -> Lwt.return_unit)
|
~ipv6:(fun _ -> Lwt.return_unit)
|
||||||
t.eth
|
t.eth
|
||||||
in
|
in
|
||||||
NET.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet ethif_listener
|
NET.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet ethif_listener
|
||||||
>>= function
|
>>= function
|
||||||
| Error e ->
|
| Error e ->
|
||||||
Logs.warn (fun p -> p "%a" NET.pp_error e);
|
Logs.warn (fun p -> p "%a" NET.pp_error e) ;
|
||||||
Lwt.return_unit
|
Lwt.return_unit
|
||||||
| Ok _res -> Lwt.return_unit
|
| Ok _res -> Lwt.return_unit
|
||||||
|
|
||||||
let connect net eth arp ip icmp udp tcp =
|
let connect net eth arp ip icmp udp tcp =
|
||||||
{
|
{ net ; eth ; arp ; ip ; icmp ; udp ; tcp ;
|
||||||
net;
|
udp_listeners = Hashtbl.create 2 ;
|
||||||
eth;
|
tcp_listeners = Hashtbl.create 2 ;
|
||||||
arp;
|
icmp_listener = None ;
|
||||||
ip;
|
|
||||||
icmp;
|
|
||||||
udp;
|
|
||||||
tcp;
|
|
||||||
udp_listeners = Hashtbl.create 2;
|
|
||||||
tcp_listeners = Hashtbl.create 2;
|
|
||||||
icmp_listener = None;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
let disconnect _ =
|
let disconnect _ =
|
||||||
|
|
@ -152,39 +134,31 @@ struct
|
||||||
Lwt.return_unit
|
Lwt.return_unit
|
||||||
end
|
end
|
||||||
|
|
||||||
module Dns = Dns_client_mirage.Make (R) (Time) (Clock) (Stack)
|
module Dns = Dns_client_mirage.Make(R)(Time)(Clock)(Stack)
|
||||||
|
|
||||||
let make_ping_packet payload =
|
let make_ping_packet payload =
|
||||||
let echo_request =
|
let echo_request = { Icmpv4_packet.code = 0; (* constant for echo request/reply *)
|
||||||
{
|
ty = Icmpv4_wire.Echo_request;
|
||||||
Icmpv4_packet.code = 0;
|
subheader = Icmpv4_packet.(Id_and_seq (0, 0)); } in
|
||||||
(* constant for echo request/reply *)
|
|
||||||
ty = Icmpv4_wire.Echo_request;
|
|
||||||
subheader = Icmpv4_packet.(Id_and_seq (0, 0));
|
|
||||||
}
|
|
||||||
in
|
|
||||||
Icmpv4_packet.Marshal.make_cstruct echo_request ~payload
|
Icmpv4_packet.Marshal.make_cstruct echo_request ~payload
|
||||||
|
|
||||||
let is_ping_reply src server packet =
|
let is_ping_reply src server packet =
|
||||||
(0 = Ipaddr.V4.(compare src @@ of_string_exn server))
|
0 = Ipaddr.V4.(compare src @@ of_string_exn server) &&
|
||||||
&& packet.Icmpv4_packet.code = 0
|
packet.Icmpv4_packet.code = 0 &&
|
||||||
&& packet.Icmpv4_packet.ty = Icmpv4_wire.Echo_reply
|
packet.Icmpv4_packet.ty = Icmpv4_wire.Echo_reply &&
|
||||||
&& packet.Icmpv4_packet.subheader = Icmpv4_packet.(Id_and_seq (0, 0))
|
packet.Icmpv4_packet.subheader = Icmpv4_packet.(Id_and_seq (0, 0))
|
||||||
|
|
||||||
let ping_denied_listener server resp_received stack =
|
let ping_denied_listener server resp_received stack =
|
||||||
let icmp_listener ~src ~dst:_ buf =
|
let icmp_listener ~src ~dst:_ buf =
|
||||||
(* hopefully this is a reply to an ICMP echo request we sent *)
|
(* hopefully this is a reply to an ICMP echo request we sent *)
|
||||||
Log.info (fun f ->
|
Log.info (fun f -> f "ping test: ICMP message received from %a: %a" I.pp_ipaddr src Cstruct.hexdump_pp buf);
|
||||||
f "ping test: ICMP message received from %a: %a" I.pp_ipaddr src
|
|
||||||
Cstruct.hexdump_pp buf);
|
|
||||||
match Icmpv4_packet.Unmarshal.of_cstruct buf with
|
match Icmpv4_packet.Unmarshal.of_cstruct buf with
|
||||||
| Error e ->
|
| Error e -> Log.err (fun f -> f "couldn't parse ICMP packet: %s" e);
|
||||||
Log.err (fun f -> f "couldn't parse ICMP packet: %s" e);
|
Lwt.return_unit
|
||||||
Lwt.return_unit
|
|
||||||
| Ok (packet, _payload) ->
|
| Ok (packet, _payload) ->
|
||||||
Log.info (fun f -> f "ICMP message: %a" Icmpv4_packet.pp packet);
|
Log.info (fun f -> f "ICMP message: %a" Icmpv4_packet.pp packet);
|
||||||
if is_ping_reply src server packet then resp_received := true;
|
if is_ping_reply src server packet then resp_received := true;
|
||||||
Lwt.return_unit
|
Lwt.return_unit
|
||||||
in
|
in
|
||||||
Stack.listen_icmp stack (Some icmp_listener)
|
Stack.listen_icmp stack (Some icmp_listener)
|
||||||
|
|
||||||
|
|
@ -192,68 +166,49 @@ struct
|
||||||
let resp_received = ref false in
|
let resp_received = ref false in
|
||||||
Log.info (fun f -> f "Entering ping test: %s" server);
|
Log.info (fun f -> f "Entering ping test: %s" server);
|
||||||
ping_denied_listener server resp_received stack;
|
ping_denied_listener server resp_received stack;
|
||||||
Icmp.write (Stack.icmpv4 stack)
|
Icmp.write (Stack.icmpv4 stack) ~dst:(Ipaddr.V4.of_string_exn server) (make_ping_packet (Cstruct.of_string "hi")) >>= function
|
||||||
~dst:(Ipaddr.V4.of_string_exn server)
|
| Error e -> Log.err (fun f -> f "ping test: error sending ping: %a" Icmp.pp_error e); Lwt.return_unit
|
||||||
(make_ping_packet (Cstruct.of_string "hi"))
|
|
||||||
>>= function
|
|
||||||
| Error e ->
|
|
||||||
Log.err (fun f -> f "ping test: error sending ping: %a" Icmp.pp_error e);
|
|
||||||
Lwt.return_unit
|
|
||||||
| Ok () ->
|
| Ok () ->
|
||||||
Log.info (fun f -> f "ping test: sent ping to %s" server);
|
Log.info (fun f -> f "ping test: sent ping to %s" server);
|
||||||
Time.sleep_ns 2_000_000_000L >>= fun () ->
|
Time.sleep_ns 2_000_000_000L >>= fun () ->
|
||||||
if !resp_received then
|
(if !resp_received then
|
||||||
Log.err (fun f ->
|
Log.err (fun f -> f "ping test failed: server %s got a response, block expected :(" server)
|
||||||
f "ping test failed: server %s got a response, block expected :("
|
else
|
||||||
server)
|
Log.err (fun f -> f "ping test passed: successfully blocked :)")
|
||||||
else Log.err (fun f -> f "ping test passed: successfully blocked :)");
|
);
|
||||||
Stack.listen_icmp stack None;
|
Stack.listen_icmp stack None;
|
||||||
Lwt.return_unit
|
Lwt.return_unit
|
||||||
|
|
||||||
let icmp_error_type stack () =
|
let icmp_error_type stack () =
|
||||||
let resp_correct = ref false in
|
let resp_correct = ref false in
|
||||||
let echo_server = Ipaddr.V4.of_string_exn netvm in
|
let echo_server = Ipaddr.V4.of_string_exn netvm in
|
||||||
let icmp_callback ~src ~dst:_ buf =
|
let icmp_callback ~src ~dst:_ buf =
|
||||||
(if Ipaddr.V4.compare src echo_server = 0 then
|
if Ipaddr.V4.compare src echo_server = 0 then begin
|
||||||
(* TODO: check that packet is error packet *)
|
(* TODO: check that packet is error packet *)
|
||||||
match Icmpv4_packet.Unmarshal.of_cstruct buf with
|
match Icmpv4_packet.Unmarshal.of_cstruct buf with
|
||||||
| Error e -> Log.err (fun f -> f "Error parsing icmp packet %s" e)
|
| Error e -> Log.err (fun f -> f "Error parsing icmp packet %s" e)
|
||||||
| Ok (packet, _) ->
|
| Ok (packet, _) ->
|
||||||
(* TODO don't hardcode the numbers, make a datatype *)
|
(* TODO don't hardcode the numbers, make a datatype *)
|
||||||
if
|
if packet.Icmpv4_packet.code = 10 (* unreachable, admin prohibited *)
|
||||||
packet.Icmpv4_packet.code
|
|
||||||
= 10 (* unreachable, admin prohibited *)
|
|
||||||
then resp_correct := true
|
then resp_correct := true
|
||||||
else
|
else Log.debug (fun f -> f "Unrelated icmp packet %a" Icmpv4_packet.pp packet)
|
||||||
Log.debug (fun f ->
|
end;
|
||||||
f "Unrelated icmp packet %a" Icmpv4_packet.pp packet));
|
|
||||||
Lwt.return_unit
|
Lwt.return_unit
|
||||||
in
|
in
|
||||||
let content = Cstruct.of_string "important data" in
|
let content = Cstruct.of_string "important data" in
|
||||||
Stack.listen_icmp stack (Some icmp_callback);
|
Stack.listen_icmp stack (Some icmp_callback);
|
||||||
U.write ~src_port:1337 ~dst:echo_server ~dst_port:1338 (Stack.udpv4 stack)
|
U.write ~src_port:1337 ~dst:echo_server ~dst_port:1338 (Stack.udpv4 stack) content >>= function
|
||||||
content
|
| Ok () -> (* .. listener: test with accept rule, if we get reply we're good *)
|
||||||
>>= function
|
Time.sleep_ns 1_000_000_000L >>= fun () ->
|
||||||
| Ok () ->
|
if !resp_correct
|
||||||
(* .. listener: test with accept rule, if we get reply we're good *)
|
then Log.info (fun m -> m "UDP fetch test to port %d succeeded :)" 1338)
|
||||||
Time.sleep_ns 1_000_000_000L >>= fun () ->
|
else Log.err (fun f -> f "UDP fetch test to port %d: failed. :( correct response not received" 1338);
|
||||||
if !resp_correct then
|
Stack.listen_icmp stack None;
|
||||||
Log.info (fun m -> m "UDP fetch test to port %d succeeded :)" 1338)
|
Lwt.return_unit
|
||||||
else
|
|
||||||
Log.err (fun f ->
|
|
||||||
f
|
|
||||||
"UDP fetch test to port %d: failed. :( correct response not \
|
|
||||||
received"
|
|
||||||
1338);
|
|
||||||
Stack.listen_icmp stack None;
|
|
||||||
Lwt.return_unit
|
|
||||||
| Error e ->
|
| Error e ->
|
||||||
Log.err (fun f ->
|
Log.err (fun f -> f "UDP fetch test to port %d failed: :( couldn't write the packet: %a"
|
||||||
f
|
1338 U.pp_error e);
|
||||||
"UDP fetch test to port %d failed: :( couldn't write the packet: \
|
Lwt.return_unit
|
||||||
%a"
|
|
||||||
1338 U.pp_error e);
|
|
||||||
Lwt.return_unit
|
|
||||||
|
|
||||||
let tcp_connect msg server port tcp () =
|
let tcp_connect msg server port tcp () =
|
||||||
Log.info (fun f -> f "Entering tcp connect test: %s:%d" server port);
|
Log.info (fun f -> f "Entering tcp connect test: %s:%d" server port);
|
||||||
|
|
@ -261,141 +216,98 @@ struct
|
||||||
let msg' = Printf.sprintf "TCP connect test %s to %s:%d" msg server port in
|
let msg' = Printf.sprintf "TCP connect test %s to %s:%d" msg server port in
|
||||||
T.create_connection tcp (ip, port) >>= function
|
T.create_connection tcp (ip, port) >>= function
|
||||||
| Ok flow ->
|
| Ok flow ->
|
||||||
Log.info (fun f -> f "%s passed :)" msg');
|
Log.info (fun f -> f "%s passed :)" msg');
|
||||||
T.close flow
|
T.close flow
|
||||||
| Error e ->
|
| Error e -> Log.err (fun f -> f "%s failed: Connection failed (%a) :(" msg' T.pp_error e);
|
||||||
Log.err (fun f ->
|
Lwt.return_unit
|
||||||
f "%s failed: Connection failed (%a) :(" msg' T.pp_error e);
|
|
||||||
Lwt.return_unit
|
|
||||||
|
|
||||||
let tcp_connect_denied msg server port tcp () =
|
let tcp_connect_denied msg server port tcp () =
|
||||||
let ip = Ipaddr.V4.of_string_exn server in
|
let ip = Ipaddr.V4.of_string_exn server in
|
||||||
let msg' =
|
let msg' = Printf.sprintf "TCP connect denied test %s to %s:%d" msg server port in
|
||||||
Printf.sprintf "TCP connect denied test %s to %s:%d" msg server port
|
let connect = (T.create_connection tcp (ip, port) >>= function
|
||||||
|
| Ok flow ->
|
||||||
|
Log.err (fun f -> f "%s failed: Connection should be denied, but was not. :(" msg');
|
||||||
|
T.close flow
|
||||||
|
| Error e -> Log.info (fun f -> f "%s passed (error text: %a) :)" msg' T.pp_error e);
|
||||||
|
Lwt.return_unit)
|
||||||
in
|
in
|
||||||
let connect =
|
let timeout = (
|
||||||
T.create_connection tcp (ip, port) >>= function
|
|
||||||
| Ok flow ->
|
|
||||||
Log.err (fun f ->
|
|
||||||
f "%s failed: Connection should be denied, but was not. :(" msg');
|
|
||||||
T.close flow
|
|
||||||
| Error e ->
|
|
||||||
Log.info (fun f ->
|
|
||||||
f "%s passed (error text: %a) :)" msg' T.pp_error e);
|
|
||||||
Lwt.return_unit
|
|
||||||
in
|
|
||||||
let timeout =
|
|
||||||
Time.sleep_ns 1_000_000_000L >>= fun () ->
|
Time.sleep_ns 1_000_000_000L >>= fun () ->
|
||||||
Log.info (fun f -> f "%s passed :)" msg');
|
Log.info (fun f -> f "%s passed :)" msg');
|
||||||
Lwt.return_unit
|
Lwt.return_unit)
|
||||||
in
|
in
|
||||||
Lwt.pick [ connect; timeout ]
|
Lwt.pick [ connect ; timeout ]
|
||||||
|
|
||||||
let udp_fetch ~src_port ~echo_server_port stack () =
|
let udp_fetch ~src_port ~echo_server_port stack () =
|
||||||
Log.info (fun f ->
|
Log.info (fun f -> f "Entering udp fetch test: %d -> %s:%d"
|
||||||
f "Entering udp fetch test: %d -> %s:%d" src_port netvm echo_server_port);
|
src_port netvm echo_server_port);
|
||||||
let resp_correct = ref false in
|
let resp_correct = ref false in
|
||||||
let echo_server = Ipaddr.V4.of_string_exn netvm in
|
let echo_server = Ipaddr.V4.of_string_exn netvm in
|
||||||
let content = Cstruct.of_string "important data" in
|
let content = Cstruct.of_string "important data" in
|
||||||
let udp_listener : U.callback =
|
let udp_listener : U.callback = (fun ~src ~dst:_ ~src_port buf ->
|
||||||
fun ~src ~dst:_ ~src_port buf ->
|
Log.debug (fun f -> f "listen_udpv4 function invoked for packet: %a" Cstruct.hexdump_pp buf);
|
||||||
Log.debug (fun f ->
|
if ((0 = Ipaddr.V4.compare echo_server src) && src_port = echo_server_port) then
|
||||||
f "listen_udpv4 function invoked for packet: %a" Cstruct.hexdump_pp
|
match Cstruct.equal buf content with
|
||||||
buf);
|
| true -> (* yay *)
|
||||||
if 0 = Ipaddr.V4.compare echo_server src && src_port = echo_server_port
|
Log.info (fun f -> f "UDP fetch test to port %d: passed :)" echo_server_port);
|
||||||
then (
|
|
||||||
match Cstruct.equal buf content with
|
|
||||||
| true ->
|
|
||||||
(* yay *)
|
|
||||||
Log.info (fun f ->
|
|
||||||
f "UDP fetch test to port %d: passed :)" echo_server_port);
|
|
||||||
resp_correct := true;
|
resp_correct := true;
|
||||||
Lwt.return_unit
|
Lwt.return_unit
|
||||||
| false ->
|
| false -> (* oh no *)
|
||||||
(* oh no *)
|
Log.err (fun f -> f "UDP fetch test to port %d: failed. :( Packet corrupted; expected %a but got %a"
|
||||||
Log.err (fun f ->
|
echo_server_port Cstruct.hexdump_pp content Cstruct.hexdump_pp buf);
|
||||||
f
|
Lwt.return_unit
|
||||||
"UDP fetch test to port %d: failed. :( Packet corrupted; \
|
else
|
||||||
expected %a but got %a"
|
begin
|
||||||
echo_server_port Cstruct.hexdump_pp content Cstruct.hexdump_pp
|
(* disregard this packet *)
|
||||||
buf);
|
Log.debug (fun f -> f "packet is not from the echo server or has the wrong source port (%d but we wanted %d)"
|
||||||
Lwt.return_unit)
|
src_port echo_server_port);
|
||||||
else (
|
(* don't cancel the listener, since we want to keep listening *)
|
||||||
(* disregard this packet *)
|
Lwt.return_unit
|
||||||
Log.debug (fun f ->
|
end
|
||||||
f
|
)
|
||||||
"packet is not from the echo server or has the wrong source port \
|
|
||||||
(%d but we wanted %d)"
|
|
||||||
src_port echo_server_port);
|
|
||||||
(* don't cancel the listener, since we want to keep listening *)
|
|
||||||
Lwt.return_unit)
|
|
||||||
in
|
in
|
||||||
Stack.listen_udpv4 stack ~port:src_port udp_listener;
|
Stack.listen_udpv4 stack ~port:src_port udp_listener;
|
||||||
U.write ~src_port ~dst:echo_server ~dst_port:echo_server_port
|
U.write ~src_port ~dst:echo_server ~dst_port:echo_server_port (Stack.udpv4 stack) content >>= function
|
||||||
(Stack.udpv4 stack) content
|
| Ok () -> (* .. listener: test with accept rule, if we get reply we're good *)
|
||||||
>>= function
|
Time.sleep_ns 1_000_000_000L >>= fun () ->
|
||||||
| Ok () ->
|
Stack.stop_listen_udpv4 stack ~port:src_port;
|
||||||
(* .. listener: test with accept rule, if we get reply we're good *)
|
if !resp_correct then Lwt.return_unit else begin
|
||||||
Time.sleep_ns 1_000_000_000L >>= fun () ->
|
Log.err (fun f -> f "UDP fetch test to port %d: failed. :( correct response not received" echo_server_port);
|
||||||
Stack.stop_listen_udpv4 stack ~port:src_port;
|
|
||||||
if !resp_correct then Lwt.return_unit
|
|
||||||
else (
|
|
||||||
Log.err (fun f ->
|
|
||||||
f
|
|
||||||
"UDP fetch test to port %d: failed. :( correct response not \
|
|
||||||
received"
|
|
||||||
echo_server_port);
|
|
||||||
Lwt.return_unit)
|
|
||||||
| Error e ->
|
|
||||||
Log.err (fun f ->
|
|
||||||
f
|
|
||||||
"UDP fetch test to port %d failed: :( couldn't write the packet: \
|
|
||||||
%a"
|
|
||||||
echo_server_port U.pp_error e);
|
|
||||||
Lwt.return_unit
|
Lwt.return_unit
|
||||||
|
end
|
||||||
|
| Error e ->
|
||||||
|
Log.err (fun f -> f "UDP fetch test to port %d failed: :( couldn't write the packet: %a"
|
||||||
|
echo_server_port U.pp_error e);
|
||||||
|
Lwt.return_unit
|
||||||
|
|
||||||
let dns_expect_failure ~nameserver ~hostname stack () =
|
let dns_expect_failure ~nameserver ~hostname stack () =
|
||||||
let lookup = Domain_name.(of_string_exn hostname |> host_exn) in
|
let lookup = Domain_name.(of_string_exn hostname |> host_exn) in
|
||||||
let nameserver' = (`UDP, (Ipaddr.V4.of_string_exn nameserver, 53)) in
|
let nameserver' = `UDP, (Ipaddr.V4.of_string_exn nameserver, 53) in
|
||||||
let dns = Dns.create ~nameserver:nameserver' stack in
|
let dns = Dns.create ~nameserver:nameserver' stack in
|
||||||
Dns.gethostbyname dns lookup >>= function
|
Dns.gethostbyname dns lookup >>= function
|
||||||
| Error (`Msg s) when String.compare s "Truncated UDP response" <> 0 ->
|
| Error (`Msg s) when String.compare s "Truncated UDP response" <> 0 -> Log.debug (fun f -> f "DNS test to %s failed as expected: %s"
|
||||||
Log.debug (fun f ->
|
nameserver s);
|
||||||
f "DNS test to %s failed as expected: %s" nameserver s);
|
Log.info (fun f -> f "DNS traffic to %s correctly blocked :)" nameserver);
|
||||||
Log.info (fun f ->
|
Lwt.return_unit
|
||||||
f "DNS traffic to %s correctly blocked :)" nameserver);
|
|
||||||
Lwt.return_unit
|
|
||||||
| Error (`Msg s) ->
|
| Error (`Msg s) ->
|
||||||
Log.debug (fun f ->
|
Log.debug (fun f -> f "DNS test to %s failed unexpectedly (truncated response): %s :("
|
||||||
f "DNS test to %s failed unexpectedly (truncated response): %s :("
|
nameserver s);
|
||||||
nameserver s);
|
Lwt.return_unit
|
||||||
Lwt.return_unit
|
| Ok addr -> Log.err (fun f -> f "DNS test to %s should have been blocked, but looked up %s:%a" nameserver hostname Ipaddr.V4.pp addr);
|
||||||
| Ok addr ->
|
Lwt.return_unit
|
||||||
Log.err (fun f ->
|
|
||||||
f "DNS test to %s should have been blocked, but looked up %s:%a"
|
|
||||||
nameserver hostname Ipaddr.V4.pp addr);
|
|
||||||
Lwt.return_unit
|
|
||||||
|
|
||||||
let dns_then_tcp_denied server stack () =
|
let dns_then_tcp_denied server stack () =
|
||||||
let parsed_server = Domain_name.(of_string_exn server |> host_exn) in
|
let parsed_server = Domain_name.(of_string_exn server |> host_exn) in
|
||||||
(* ask dns about server *)
|
(* ask dns about server *)
|
||||||
Log.debug (fun f ->
|
Log.debug (fun f -> f "going to make a dns thing using nameserver %s" nameserver_1);
|
||||||
f "going to make a dns thing using nameserver %s" nameserver_1);
|
let dns = Dns.create ~nameserver:(`UDP, ((Ipaddr.V4.of_string_exn nameserver_1), 53)) stack in
|
||||||
let dns =
|
|
||||||
Dns.create
|
|
||||||
~nameserver:(`UDP, (Ipaddr.V4.of_string_exn nameserver_1, 53))
|
|
||||||
stack
|
|
||||||
in
|
|
||||||
Log.debug (fun f -> f "OK, going to look up %s now" server);
|
Log.debug (fun f -> f "OK, going to look up %s now" server);
|
||||||
Dns.gethostbyname dns parsed_server >>= function
|
Dns.gethostbyname dns parsed_server >>= function
|
||||||
| Error (`Msg s) ->
|
| Error (`Msg s) -> Log.err (fun f -> f "couldn't look up ip for %s: %s" server s); Lwt.return_unit
|
||||||
Log.err (fun f -> f "couldn't look up ip for %s: %s" server s);
|
|
||||||
Lwt.return_unit
|
|
||||||
| Ok addr ->
|
| Ok addr ->
|
||||||
Log.debug (fun f ->
|
Log.debug (fun f -> f "looked up ip for %s: %a" server Ipaddr.V4.pp addr);
|
||||||
f "looked up ip for %s: %a" server Ipaddr.V4.pp addr);
|
Log.err (fun f -> f "Do more stuff here!!!! :(");
|
||||||
Log.err (fun f -> f "Do more stuff here!!!! :(");
|
Lwt.return_unit
|
||||||
Lwt.return_unit
|
|
||||||
|
|
||||||
let start _random _time _clock network db =
|
let start _random _time _clock network db =
|
||||||
E.connect network >>= fun ethernet ->
|
E.connect network >>= fun ethernet ->
|
||||||
|
|
@ -404,64 +316,42 @@ struct
|
||||||
Icmp.connect ipv4 >>= fun icmp ->
|
Icmp.connect ipv4 >>= fun icmp ->
|
||||||
U.connect ipv4 >>= fun udp ->
|
U.connect ipv4 >>= fun udp ->
|
||||||
T.connect ipv4 >>= fun tcp ->
|
T.connect ipv4 >>= fun tcp ->
|
||||||
let stack = Stack.connect network ethernet arp ipv4 icmp udp tcp in
|
|
||||||
|
let stack = Stack.connect network ethernet arp ipv4 icmp udp tcp in
|
||||||
Lwt.async (fun () -> Stack.listen stack);
|
Lwt.async (fun () -> Stack.listen stack);
|
||||||
|
|
||||||
(* put this first because tcp_connect_denied tests also generate icmp messages *)
|
(* put this first because tcp_connect_denied tests also generate icmp messages *)
|
||||||
let general_tests : unit Alcotest.test =
|
let general_tests : unit Alcotest.test = ("firewall tests", [
|
||||||
( "firewall tests",
|
("UDP fetch", `Quick, udp_fetch ~src_port:9090 ~echo_server_port:1235 stack);
|
||||||
[
|
("Ping expect failure", `Quick, ping_expect_failure "8.8.8.8" stack );
|
||||||
( "UDP fetch",
|
(* TODO: ping_expect_success to the netvm, for which we have an icmptype rule in update-firewall.sh *)
|
||||||
`Quick,
|
("ICMP error type", `Quick, icmp_error_type stack)
|
||||||
udp_fetch ~src_port:9090 ~echo_server_port:1235 stack );
|
] ) in
|
||||||
("Ping expect failure", `Quick, ping_expect_failure "8.8.8.8" stack);
|
|
||||||
(* TODO: ping_expect_success to the netvm, for which we have an icmptype rule in update-firewall.sh *)
|
|
||||||
("ICMP error type", `Quick, icmp_error_type stack);
|
|
||||||
] )
|
|
||||||
in
|
|
||||||
Alcotest.run ~and_exit:false "name" [ general_tests ] >>= fun () ->
|
Alcotest.run ~and_exit:false "name" [ general_tests ] >>= fun () ->
|
||||||
let tcp_tests : unit Alcotest.test =
|
let tcp_tests : unit Alcotest.test = ("tcp tests", [
|
||||||
( "tcp tests",
|
(* this test fails on 4.0R3
|
||||||
[
|
|
||||||
(* this test fails on 4.0R3
|
|
||||||
("TCP connect", `Quick, tcp_connect "when trying specialtarget" nameserver_1 53 tcp); *)
|
("TCP connect", `Quick, tcp_connect "when trying specialtarget" nameserver_1 53 tcp); *)
|
||||||
("TCP connect", `Quick, tcp_connect_denied "" netvm 53 tcp);
|
("TCP connect", `Quick, tcp_connect_denied "" netvm 53 tcp);
|
||||||
( "TCP connect",
|
("TCP connect", `Quick, tcp_connect_denied "when trying below range" netvm 6667 tcp);
|
||||||
`Quick,
|
("TCP connect", `Quick, tcp_connect "when trying lower bound in range" netvm 6668 tcp);
|
||||||
tcp_connect_denied "when trying below range" netvm 6667 tcp );
|
("TCP connect", `Quick, tcp_connect "when trying upper bound in range" netvm 6670 tcp);
|
||||||
( "TCP connect",
|
("TCP connect", `Quick, tcp_connect_denied "when trying above range" netvm 6671 tcp);
|
||||||
`Quick,
|
("TCP connect", `Quick, tcp_connect_denied "" netvm 8082 tcp);
|
||||||
tcp_connect "when trying lower bound in range" netvm 6668 tcp );
|
] ) in
|
||||||
( "TCP connect",
|
|
||||||
`Quick,
|
|
||||||
tcp_connect "when trying upper bound in range" netvm 6670 tcp );
|
|
||||||
( "TCP connect",
|
|
||||||
`Quick,
|
|
||||||
tcp_connect_denied "when trying above range" netvm 6671 tcp );
|
|
||||||
("TCP connect", `Quick, tcp_connect_denied "" netvm 8082 tcp);
|
|
||||||
] )
|
|
||||||
in
|
|
||||||
|
|
||||||
(* replace the udp-related listeners with the right one for tcp *)
|
(* replace the udp-related listeners with the right one for tcp *)
|
||||||
Alcotest.run "name" [ tcp_tests ] >>= fun () ->
|
Alcotest.run "name" [ tcp_tests ] >>= fun () ->
|
||||||
(* use the stack abstraction only after the other tests have run, since it's not friendly with outside use of its modules *)
|
(* use the stack abstraction only after the other tests have run, since it's not friendly with outside use of its modules *)
|
||||||
let stack_tests =
|
let stack_tests = "stack tests", [
|
||||||
( "stack tests",
|
("DNS expect failure", `Quick, dns_expect_failure ~nameserver:"8.8.8.8" ~hostname:"mirage.io" stack);
|
||||||
[
|
|
||||||
( "DNS expect failure",
|
(* the test below won't work on @linse's internet,
|
||||||
`Quick,
|
|
||||||
dns_expect_failure ~nameserver:"8.8.8.8" ~hostname:"mirage.io" stack
|
|
||||||
);
|
|
||||||
(* the test below won't work on @linse's internet,
|
|
||||||
* because the nameserver there doesn't answer on TCP port 53,
|
* because the nameserver there doesn't answer on TCP port 53,
|
||||||
* only UDP port 53. Dns_mirage_client.ml disregards our request
|
* only UDP port 53. Dns_mirage_client.ml disregards our request
|
||||||
* to use UDP and uses TCP anyway, so this request can never work there. *)
|
* to use UDP and uses TCP anyway, so this request can never work there. *)
|
||||||
(* If we can figure out a way to have this test unikernel do a UDP lookup with minimal pain,
|
(* If we can figure out a way to have this test unikernel do a UDP lookup with minimal pain,
|
||||||
* we should re-enable this test. *)
|
* we should re-enable this test. *)
|
||||||
( "DNS lookup + TCP connect",
|
("DNS lookup + TCP connect", `Quick, dns_then_tcp_denied "google.com" stack);
|
||||||
`Quick,
|
] in
|
||||||
dns_then_tcp_denied "google.com" stack );
|
|
||||||
] )
|
|
||||||
in
|
|
||||||
Alcotest.run "name" [ stack_tests ]
|
Alcotest.run "name" [ stack_tests ]
|
||||||
end
|
end
|
||||||
|
|
|
||||||
182
unikernel.ml
182
unikernel.ml
|
|
@ -3,124 +3,92 @@
|
||||||
|
|
||||||
open Lwt
|
open Lwt
|
||||||
open Qubes
|
open Qubes
|
||||||
open Cmdliner
|
|
||||||
|
|
||||||
let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
|
let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
|
||||||
|
|
||||||
module Log = (val Logs.src_log src : Logs.LOG)
|
module Log = (val Logs.src_log src : Logs.LOG)
|
||||||
|
|
||||||
let nat_table_size =
|
module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct
|
||||||
let doc =
|
module Uplink = Uplink.Make(R)(Clock)
|
||||||
Arg.info ~doc:"The number of NAT entries to allocate." [ "nat-table-size" ]
|
module Dns_transport = My_dns.Transport(R)(Clock)
|
||||||
in
|
module Dns_client = Dns_client.Make(Dns_transport)
|
||||||
Mirage_runtime.register_arg Arg.(value & opt int 5_000 doc)
|
|
||||||
|
|
||||||
let ipv4 =
|
(* Set up networking and listen for incoming packets. *)
|
||||||
let doc = Arg.info ~doc:"Manual IP setting." [ "ipv4" ] in
|
let network dns_client dns_responses uplink qubesDB router =
|
||||||
Mirage_runtime.register_arg Arg.(value & opt string "0.0.0.0" doc)
|
(* Report success *)
|
||||||
|
Dao.set_iptables_error qubesDB "" >>= fun () ->
|
||||||
let ipv4_gw =
|
(* Handle packets from both networks *)
|
||||||
let doc = Arg.info ~doc:"Manual Gateway IP setting." [ "ipv4-gw" ] in
|
Lwt.choose [
|
||||||
Mirage_runtime.register_arg Arg.(value & opt string "0.0.0.0" doc)
|
Client_net.listen Clock.elapsed_ns dns_client qubesDB router;
|
||||||
|
Uplink.listen uplink Clock.elapsed_ns dns_responses router
|
||||||
let ipv4_dns =
|
|
||||||
let doc = Arg.info ~doc:"Manual DNS IP setting." [ "ipv4-dns" ] in
|
|
||||||
Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.1" doc)
|
|
||||||
|
|
||||||
let ipv4_dns2 =
|
|
||||||
let doc = Arg.info ~doc:"Manual Second DNS IP setting." [ "ipv4-dns2" ] in
|
|
||||||
Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.2" doc)
|
|
||||||
|
|
||||||
module Dns_client = Dns_client.Make (My_dns)
|
|
||||||
|
|
||||||
(* Set up networking and listen for incoming packets. *)
|
|
||||||
let network dns_client dns_responses dns_servers qubesDB router =
|
|
||||||
(* Report success *)
|
|
||||||
Dao.set_iptables_error qubesDB "" >>= fun () ->
|
|
||||||
(* Handle packets from both networks *)
|
|
||||||
Lwt.choose
|
|
||||||
[
|
|
||||||
Dispatcher.wait_clients Mirage_mtime.elapsed_ns dns_client dns_servers
|
|
||||||
qubesDB router;
|
|
||||||
Dispatcher.uplink_wait_update qubesDB router;
|
|
||||||
Dispatcher.uplink_listen Mirage_mtime.elapsed_ns dns_responses router;
|
|
||||||
]
|
]
|
||||||
|
|
||||||
(* Main unikernel entry point (called from auto-generated main.ml). *)
|
(* We don't use the GUI, but it's interesting to keep an eye on it.
|
||||||
let start () =
|
If the other end dies, don't let it take us with it (can happen on logout). *)
|
||||||
let open Lwt.Syntax in
|
let watch_gui gui =
|
||||||
let start_time = Mirage_mtime.elapsed_ns () in
|
Lwt.async (fun () ->
|
||||||
(* Start qrexec agent and QubesDB agent in parallel *)
|
Lwt.try_bind
|
||||||
let* qrexec = RExec.connect ~domid:0 () in
|
(fun () ->
|
||||||
let agent_listener = RExec.listen qrexec Command.handler in
|
gui >>= fun gui ->
|
||||||
let* qubesDB = DB.connect ~domid:0 () in
|
Log.info (fun f -> f "GUI agent connected");
|
||||||
let startup_time =
|
GUI.listen gui ()
|
||||||
let ( - ) = Int64.sub in
|
)
|
||||||
let time_in_ns = Mirage_mtime.elapsed_ns () - start_time in
|
(fun `Cant_happen -> assert false)
|
||||||
Int64.to_float time_in_ns /. 1e9
|
(fun ex ->
|
||||||
in
|
Log.warn (fun f -> f "GUI thread failed: %s" (Printexc.to_string ex));
|
||||||
Log.info (fun f ->
|
Lwt.return_unit
|
||||||
f "QubesDB and qrexec agents connected in %.3f s" startup_time);
|
)
|
||||||
(* Watch for shutdown requests from Qubes *)
|
)
|
||||||
let shutdown_rq =
|
|
||||||
Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
|
|
||||||
Lwt.return_unit
|
|
||||||
in
|
|
||||||
(* Set up networking *)
|
|
||||||
let nat = My_nat.create ~max_entries:(nat_table_size ()) in
|
|
||||||
|
|
||||||
let netvm_ip = Ipaddr.V4.of_string_exn (ipv4_gw ()) in
|
(* Main unikernel entry point (called from auto-generated main.ml). *)
|
||||||
let our_ip = Ipaddr.V4.of_string_exn (ipv4 ()) in
|
let start _random _clock =
|
||||||
let dns = Ipaddr.V4.of_string_exn (ipv4_dns ()) in
|
let start_time = Clock.elapsed_ns () in
|
||||||
let dns2 = Ipaddr.V4.of_string_exn (ipv4_dns2 ()) in
|
(* Start qrexec agent, GUI agent and QubesDB agent in parallel *)
|
||||||
|
let qrexec = RExec.connect ~domid:0 () in
|
||||||
|
GUI.connect ~domid:0 () |> watch_gui;
|
||||||
|
let qubesDB = DB.connect ~domid:0 () in
|
||||||
|
|
||||||
let zero_ip = Ipaddr.V4.any in
|
(* Wait for clients to connect *)
|
||||||
|
qrexec >>= fun qrexec ->
|
||||||
|
let agent_listener = RExec.listen qrexec Command.handler in
|
||||||
|
qubesDB >>= fun qubesDB ->
|
||||||
|
let startup_time =
|
||||||
|
let (-) = Int64.sub in
|
||||||
|
let time_in_ns = Clock.elapsed_ns () - start_time in
|
||||||
|
Int64.to_float time_in_ns /. 1e9
|
||||||
|
in
|
||||||
|
Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time);
|
||||||
|
(* Watch for shutdown requests from Qubes *)
|
||||||
|
let shutdown_rq =
|
||||||
|
OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
|
||||||
|
Lwt.return_unit in
|
||||||
|
(* Set up networking *)
|
||||||
|
let max_entries = Key_gen.nat_table_size () in
|
||||||
|
My_nat.create ~max_entries >>= fun nat ->
|
||||||
|
|
||||||
let network_config =
|
(* Read network configuration from QubesDB *)
|
||||||
if netvm_ip = zero_ip && our_ip = zero_ip then (
|
Dao.read_network_config qubesDB >>= fun config ->
|
||||||
(* Read network configuration from QubesDB *)
|
|
||||||
Dao.read_network_config qubesDB
|
|
||||||
>>= fun config ->
|
|
||||||
if config.netvm_ip = zero_ip || config.our_ip = zero_ip then
|
|
||||||
Log.info (fun f ->
|
|
||||||
f
|
|
||||||
"We currently have no netvm nor command line for setting it up, \
|
|
||||||
aborting...");
|
|
||||||
assert (config.netvm_ip <> zero_ip && config.our_ip <> zero_ip);
|
|
||||||
Lwt.return config)
|
|
||||||
else
|
|
||||||
let config : Dao.network_config =
|
|
||||||
{ from_cmdline = true; netvm_ip; our_ip; dns; dns2 }
|
|
||||||
in
|
|
||||||
Lwt.return config
|
|
||||||
in
|
|
||||||
network_config >>= fun config ->
|
|
||||||
(* We now must have a valid netvm IP address and our IP address or crash *)
|
|
||||||
Dao.print_network_config config;
|
|
||||||
|
|
||||||
(* Set up client-side networking *)
|
Uplink.connect config >>= fun uplink ->
|
||||||
let* clients = Client_eth.create config in
|
(* Set up client-side networking *)
|
||||||
|
let client_eth = Client_eth.create
|
||||||
|
~client_gw:config.Dao.clients_our_ip in
|
||||||
|
(* Set up routing between networks and hosts *)
|
||||||
|
let router = Router.create
|
||||||
|
~client_eth
|
||||||
|
~uplink:(Uplink.interface uplink)
|
||||||
|
~nat
|
||||||
|
in
|
||||||
|
|
||||||
(* Set up routing between networks and hosts *)
|
let send_dns_query = Uplink.send_dns_client_query uplink in
|
||||||
let router = Dispatcher.create ~config ~clients ~nat ~uplink:None in
|
let dns_mvar = Lwt_mvar.create_empty () in
|
||||||
|
let dns_client = Dns_client.create (router, send_dns_query, dns_mvar) in
|
||||||
|
|
||||||
let send_dns_query = Dispatcher.send_dns_client_query router in
|
let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar uplink qubesDB router in
|
||||||
let dns_mvar = Lwt_mvar.create_empty () in
|
|
||||||
let nameservers = (`Udp, [ (config.Dao.dns, 53); (config.Dao.dns2, 53) ]) in
|
|
||||||
let dns_client =
|
|
||||||
Dns_client.create ~nameservers (router, send_dns_query, dns_mvar)
|
|
||||||
in
|
|
||||||
|
|
||||||
let dns_servers = [ config.Dao.dns; config.Dao.dns2 ] in
|
(* Report memory usage to XenStore *)
|
||||||
let net_listener =
|
Memory_pressure.init ();
|
||||||
network
|
(* Run until something fails or we get a shutdown request. *)
|
||||||
(Dns_client.getaddrinfo dns_client Dns.Rr_map.A)
|
Lwt.choose [agent_listener; net_listener; shutdown_rq] >>= fun () ->
|
||||||
dns_mvar dns_servers qubesDB router
|
(* Give the console daemon time to show any final log messages. *)
|
||||||
in
|
OS.Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float)
|
||||||
|
end
|
||||||
(* Report memory usage to XenStore *)
|
|
||||||
Memory_pressure.init ();
|
|
||||||
(* Run until something fails or we get a shutdown request. *)
|
|
||||||
Lwt.choose [ agent_listener; net_listener; shutdown_rq ] >>= fun () ->
|
|
||||||
(* Give the console daemon time to show any final log messages. *)
|
|
||||||
Mirage_sleep.ns (1.0 *. 1e9 |> Int64.of_float)
|
|
||||||
|
|
|
||||||
97
uplink.ml
Normal file
97
uplink.ml
Normal file
|
|
@ -0,0 +1,97 @@
|
||||||
|
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
|
See the README file for details. *)
|
||||||
|
|
||||||
|
open Lwt.Infix
|
||||||
|
open Fw_utils
|
||||||
|
|
||||||
|
module Eth = Ethernet.Make(Netif)
|
||||||
|
|
||||||
|
let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM"
|
||||||
|
module Log = (val Logs.src_log src : Logs.LOG)
|
||||||
|
|
||||||
|
module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) = struct
|
||||||
|
module Arp = Arp.Make(Eth)(OS.Time)
|
||||||
|
module I = Static_ipv4.Make(R)(Clock)(Eth)(Arp)
|
||||||
|
module U = Udp.Make(I)(R)
|
||||||
|
|
||||||
|
type t = {
|
||||||
|
net : Netif.t;
|
||||||
|
eth : Eth.t;
|
||||||
|
arp : Arp.t;
|
||||||
|
interface : interface;
|
||||||
|
mutable fragments : Fragments.Cache.t;
|
||||||
|
ip : I.t;
|
||||||
|
udp: U.t;
|
||||||
|
}
|
||||||
|
|
||||||
|
class netvm_iface eth mac ~my_ip ~other_ip : interface = object
|
||||||
|
val queue = FrameQ.create (Ipaddr.V4.to_string other_ip)
|
||||||
|
method my_mac = Eth.mac eth
|
||||||
|
method my_ip = my_ip
|
||||||
|
method other_ip = other_ip
|
||||||
|
method writev ethertype fillfn =
|
||||||
|
FrameQ.send queue (fun () ->
|
||||||
|
mac >>= fun dst ->
|
||||||
|
Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error
|
||||||
|
)
|
||||||
|
end
|
||||||
|
|
||||||
|
let send_dns_client_query t ~src_port ~dst ~dst_port buf =
|
||||||
|
U.write ~src_port ~dst ~dst_port t.udp buf >|= function
|
||||||
|
| Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure")
|
||||||
|
| Ok () -> Ok ()
|
||||||
|
|
||||||
|
let listen t get_ts dns_responses router =
|
||||||
|
let handle_packet ip_header ip_packet =
|
||||||
|
let open Udp_packet in
|
||||||
|
|
||||||
|
Log.debug (fun f -> f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp ip_header.Ipv4_packet.src);
|
||||||
|
match ip_packet with
|
||||||
|
| `UDP (header, packet) when Ports.mem header.dst_port !(router.Router.ports.My_nat.dns_udp) ->
|
||||||
|
Log.debug (fun f -> f "found a DNS packet whose dst_port (%d) was in the list of dns_client ports" header.dst_port);
|
||||||
|
Lwt_mvar.put dns_responses (header, packet)
|
||||||
|
| _ ->
|
||||||
|
Firewall.ipv4_from_netvm router (`IPv4 (ip_header, ip_packet))
|
||||||
|
in
|
||||||
|
Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame ->
|
||||||
|
(* Handle one Ethernet frame from NetVM *)
|
||||||
|
Eth.input t.eth
|
||||||
|
~arpv4:(Arp.input t.arp)
|
||||||
|
~ipv4:(fun ip ->
|
||||||
|
let cache, r =
|
||||||
|
Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip
|
||||||
|
in
|
||||||
|
t.fragments <- cache;
|
||||||
|
match r with
|
||||||
|
| Error e ->
|
||||||
|
Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e);
|
||||||
|
Lwt.return ()
|
||||||
|
| Ok None -> Lwt.return_unit
|
||||||
|
| Ok (Some (`IPv4 (header, packet))) -> handle_packet header packet
|
||||||
|
)
|
||||||
|
~ipv6:(fun _ip -> Lwt.return_unit)
|
||||||
|
frame
|
||||||
|
) >|= or_raise "Uplink listen loop" Netif.pp_error
|
||||||
|
|
||||||
|
|
||||||
|
let interface t = t.interface
|
||||||
|
|
||||||
|
let connect config =
|
||||||
|
let my_ip = config.Dao.uplink_our_ip in
|
||||||
|
let gateway = config.Dao.uplink_netvm_ip in
|
||||||
|
Netif.connect "0" >>= fun net ->
|
||||||
|
Eth.connect net >>= fun eth ->
|
||||||
|
Arp.connect eth >>= fun arp ->
|
||||||
|
Arp.add_ip arp my_ip >>= fun () ->
|
||||||
|
let network = Ipaddr.V4.Prefix.make 0 Ipaddr.V4.any in
|
||||||
|
I.connect ~ip:(network, my_ip) ~gateway eth arp >>= fun ip ->
|
||||||
|
U.connect ip >>= fun udp ->
|
||||||
|
let netvm_mac =
|
||||||
|
Arp.query arp gateway
|
||||||
|
>|= or_raise "Getting MAC of our NetVM" Arp.pp_error in
|
||||||
|
let interface = new netvm_iface eth netvm_mac
|
||||||
|
~my_ip
|
||||||
|
~other_ip:config.Dao.uplink_netvm_ip in
|
||||||
|
let fragments = Fragments.Cache.empty (256 * 1024) in
|
||||||
|
Lwt.return { net; eth; arp; interface ; fragments ; ip ; udp }
|
||||||
|
end
|
||||||
22
uplink.mli
Normal file
22
uplink.mli
Normal file
|
|
@ -0,0 +1,22 @@
|
||||||
|
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||||
|
See the README file for details. *)
|
||||||
|
|
||||||
|
(** The link from us to NetVM (and, through that, to the outside world). *)
|
||||||
|
|
||||||
|
open Fw_utils
|
||||||
|
|
||||||
|
[@@@ocaml.warning "-67"]
|
||||||
|
module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK) : sig
|
||||||
|
type t
|
||||||
|
|
||||||
|
val connect : Dao.network_config -> t Lwt.t
|
||||||
|
(** Connect to our NetVM (gateway). *)
|
||||||
|
|
||||||
|
val interface : t -> interface
|
||||||
|
(** The network interface to NetVM. *)
|
||||||
|
|
||||||
|
val listen : t -> (unit -> int64) -> (Udp_packet.t * Cstruct.t) Lwt_mvar.t -> Router.t -> unit Lwt.t
|
||||||
|
(** Handle incoming frames from NetVM. *)
|
||||||
|
|
||||||
|
val send_dns_client_query: t -> src_port:int-> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [`Msg of string]) result Lwt.t
|
||||||
|
end
|
||||||
Loading…
Add table
Add a link
Reference in a new issue