github/linuxkit
1
0
Fork 0
mirror of https://github.com/linuxkit/linuxkit.git synced 2025-07-27 12:38:11 +00:00
Code Issues Projects Releases Wiki Activity

Merge pull request #2040 from samoht/dhcp-rpc

Browse Source 
sdk: replace custom transport protocol by Capnproto
This commit is contained in:
Rolf Neugebauer 2017-06-14 09:35:33 -07:00 committed by GitHub
commit dfb4f292d3
30 changed files with 220 additions and 2035 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
projects/miragesdk/examples/mirage-dhcp.yml
View File

@ -1,19 +1,15 @@
kernel: kernel:
image: "mobylinux/kernel:4.9.x" image: "linuxkit/kernel:4.9.x"
cmdline: "console=ttyS0 page_poison=1" cmdline: "console=ttyS0 page_poison=1"
init: init:
- mobylinux/init:61a72fa20b9b9be269fe6b2b6360031f2cb897a7 # base init + strace + git - linuxkit/init:2599bcd5013ce5962aa155ee8929c26160de13bd
- mobylinux/runc:b0fb122e10dbb7e4e45115177a61a3f8d68c19a9 - linuxkit/runc:3a4e6cbf15470f62501b019b55e1caac5ee7689f
- mobylinux/containerd:18eaf72f3f4f9a9f29ca1951f66df701f873060b - linuxkit/containerd:b50181bc6e0084e5fcd6b6ad3cf433c4f66cae5a
- mobylinux/ca-certificates:eabc5a6e59f05aa91529d80e9a595b85b046f935
onboot: onboot:
- name: sysctl - name: sysctl
image: "linuxkit/sysctl:3aa6bc663c2849ef239be7d941d3eaf3e6fcc018" image: linuxkit/sysctl:3aa6bc663c2849ef239be7d941d3eaf3e6fcc018
services:
- name: rngd
image: mobylinux/rngd:3dad6dd43270fa632ac031e99d1947f20b22eec9
- name: dhcp-client - name: dhcp-client
image: linuxkitprojects/dhcp-client:6c231135a88d42e7d18d2ba952f0798910550cbd image: miragesdk/dhcp-client:22aa9d527820534295a8cd59901c0c5197af6585
net: host net: host
capabilities: capabilities:
- CAP_NET_ADMIN # to bring eth0 up - CAP_NET_ADMIN # to bring eth0 up
@ -30,6 +26,15 @@ services:
- /sbin:/sbin # for ifconfig - /sbin:/sbin # for ifconfig
- /bin:/bin # for ifconfig - /bin:/bin # for ifconfig
- /lib:/lib # for ifconfig - /lib:/lib # for ifconfig
services:
- name: sshd
image: "linuxkit/sshd:abc1f5e096982ebc3fb61c506aed3ac9c2ae4d55"
- name: getty
image: "linuxkit/getty:ef9d667af71089326419fb08e9cc9d567cf15748"
env:
- INSECURE=true
files: files:
- path: /var/run/dhcp-client/README - path: var/run/dhcp-client/README
contents: 'data for dhcp-client' contents: 'data for dhcp-client'
- path: root/.ssh/authorized_keys
contents: '#your SSH key here'

2
projects/miragesdk/pkg/init/.gitignore vendored
View File

@ -1,2 +0,0 @@
sbin/
usr/

11
projects/miragesdk/pkg/init/Dockerfile
View File

@ -1,11 +0,0 @@
FROM alpine:3.5
RUN \
apk --no-cache update && \
apk --no-cache upgrade -a && \
apk --no-cache add \
strace \
git \
&& rm -rf /var/cache/apk/*
COPY . ./

38
projects/miragesdk/pkg/init/Makefile
View File

@ -1,38 +0,0 @@
C_COMPILE=linuxkit/c-compile:63b085bbaec1aa7c42a7bd22a4b1c350d900617d@sha256:286e3a729c7a0b1a605ae150235416190f9f430c29b00e65fa50ff73158998e5
START_STOP_DAEMON=sbin/start-stop-daemon
default: push
$(START_STOP_DAEMON): start-stop-daemon.c
mkdir -p $(dir $@)
tar cf - $^ | docker run --rm --net=none --log-driver=none -i $(C_COMPILE) -o $@ | tar xf -
.PHONY: tag push
BASE=alpine:3.5
IMAGE=init
ETC=$(shell find etc -type f)
hash: Dockerfile $(ETC) init $(START_STOP_DAEMON)
DOCKER_CONTENT_TRUST=1 docker pull $(BASE)
tar cf - $^ | docker build --no-cache -t $(IMAGE):build -
docker run --rm $(IMAGE):build sh -c 'cat $^ /lib/apk/db/installed | sha1sum' | sed 's/ .*//' > $@
push: hash
docker pull mobylinux/$(IMAGE):$(shell cat hash) || \
(docker tag $(IMAGE):build mobylinux/$(IMAGE):$(shell cat hash) && \
docker push mobylinux/$(IMAGE):$(shell cat hash))
docker rmi $(IMAGE):build
rm -f hash
tag: hash
docker pull mobylinux/$(IMAGE):$(shell cat hash) || \
docker tag $(IMAGE):build mobylinux/$(IMAGE):$(shell cat hash)
docker rmi $(IMAGE):build
rm -f hash
clean:
rm -rf hash sbin usr
.DELETE_ON_ERROR:

9
projects/miragesdk/pkg/init/etc/init.d/containerd
View File

@ -1,9 +0,0 @@
#!/bin/sh
# bring up containerd
ulimit -n 1048576
ulimit -p unlimited
printf "\nStarting containerd\n"
mkdir -p /var/log
exec /usr/bin/containerd

33
projects/miragesdk/pkg/init/etc/init.d/containers
View File

@ -1,33 +0,0 @@
#!/bin/sh
# start onboot containers, run to completion
if [ -d /containers/onboot ]
then
for f in $(find /containers/onboot -mindepth 1 -maxdepth 1 | sort)
do
base="$(basename $f)"
/bin/mount --bind "$f/rootfs" "$f/rootfs"
mount -o remount,rw "$f/rootfs"
/usr/bin/runc run --bundle "$f" "$(basename $f)"
printf " - $base\n"
done
fi
# start service containers
# temporarily using runc not containerd
if [ -d /containers/services ]
then
for f in $(find /containers/services -mindepth 1 -maxdepth 1 | sort)
do
base="$(basename $f)"
/bin/mount --bind "$f/rootfs" "$f/rootfs"
mount -o remount,rw "$f/rootfs"
log="/var/log/$base.log"
/sbin/start-stop-daemon --start --pidfile /run/$base.pid --exec /usr/bin/runc -- run --bundle "$f" --pid-file /run/$base.pid "$(basename $f)" </dev/null 2>$log >$log &
printf " - $base\n"
done
fi
wait

114
projects/miragesdk/pkg/init/etc/init.d/rcS
View File

@ -1,114 +0,0 @@
#!/bin/sh
# mount filesystems
mkdir -p -m 0755 /proc /run /tmp /sys /dev
mount -n -t proc proc /proc -o nodev,nosuid,noexec,relatime
mount -n -t tmpfs tmpfs /run -o nodev,nosuid,noexec,relatime,size=10%,mode=755
mount -n -t tmpfs tmpfs /tmp -o nodev,nosuid,noexec,relatime,size=10%,mode=1777
# mount devfs
mount -n -t devtmpfs dev /dev -o nosuid,noexec,relatime,size=10m,nr_inodes=248418,mode=755
# devices
[ -c /dev/console ] || mknod -m 600 /dev/console c 5 1
[ -c /dev/tty1 ] || mknod -m 620 /dev/tty1 c 4 1
[ -c /dev/tty ] || mknod -m 666 /dev/tty c 5 0
[ -c /dev/null ] || mknod -m 666 /dev/null c 1 3
[ -c /dev/kmsg ] || mknod -m 660 /dev/kmsg c 1 11
# extra symbolic links not provided by default
[ -e /dev/fd ] || ln -snf /proc/self/fd /dev/fd
[ -e /dev/stdin ] || ln -snf /proc/self/fd/0 /dev/stdin
[ -e /dev/stdout ] || ln -snf /proc/self/fd/1 /dev/stdout
[ -e /dev/stderr ] || ln -snf /proc/self/fd/2 /dev/stderr
[ -e /proc/kcore ] && ln -snf /proc/kcore /dev/core
# devfs filesystems
mkdir -p -m 1777 /dev/mqueue
mkdir -p -m 1777 /dev/shm
mkdir -p -m 0755 /dev/pts
mount -n -t mqueue -o noexec,nosuid,nodev mqueue /dev/mqueue
mount -n -t tmpfs -o noexec,nosuid,nodev,mode=1777 shm /dev/shm
mount -n -t devpts -o noexec,nosuid,gid=5,mode=0620 devpts /dev/pts
# mount sysfs
sysfs_opts=nodev,noexec,nosuid
mount -n -t sysfs -o ${sysfs_opts} sysfs /sys
[ -d /sys/kernel/security ] && mount -n -t securityfs -o ${sysfs_opts} securityfs /sys/kernel/security
[ -d /sys/kernel/debug ] && mount -n -t debugfs -o ${sysfs_opts} debugfs /sys/kernel/debug
[ -d /sys/kernel/config ] && mount -n -t configfs -o ${sysfs_opts} configfs /sys/kernel/config
[ -d /sys/fs/fuse/connections ] && mount -n -t fusectl -o ${sysfs_opts} fusectl /sys/fs/fuse/connections
[ -d /sys/fs/selinux ] && mount -n -t selinuxfs -o nosuid,noexec selinuxfs /sys/fs/selinux
[ -d /sys/fs/pstore ] && mount -n -t pstore pstore -o ${sysfs_opts} /sys/fs/pstore
[ -d /sys/firmware/efi/efivars ] && mount -n -t efivarfs -o ro,${sysfs_opts} efivarfs /sys/firmware/efi/efivars
# misc /proc mounted fs
[ -d /proc/sys/fs/binfmt_misc ] && mount -t binfmt_misc -o nodev,noexec,nosuid binfmt_misc /proc/sys/fs/binfmt_misc
# mount cgroups
mount -n -t tmpfs -o nodev,noexec,nosuid,mode=755,size=10m cgroup_root /sys/fs/cgroup
while read name hier groups enabled rest
do
case "${enabled}" in
1) mkdir -p /sys/fs/cgroup/${name}
mount -n -t cgroup -o ${sysfs_opts},${name} ${name} /sys/fs/cgroup/${name}
;;
esac
done < /proc/cgroups
# use hierarchy for memory
echo 1 > /sys/fs/cgroup/memory/memory.use_hierarchy
# for compatibility
mkdir -p /sys/fs/cgroup/systemd
mount -t cgroup -o none,name=systemd cgroup /sys/fs/cgroup/systemd
# start mdev for hotplug
echo "/sbin/mdev" > /proc/sys/kernel/hotplug
# mdev -s will not create /dev/usb[1-9] devices with recent kernels
# so we trigger hotplug events for usb for now
for i in $(find /sys/devices -name 'usb[0-9]*'); do
[ -e $i/uevent ] && echo add > $i/uevent
done
mdev -s
# set hostname
if [ -s /etc/hostname ]
then
hostname -F /etc/hostname
fi
if [ $(hostname) = "moby" -a -f /sys/class/net/eth0/address ]
then
mac=$(cat /sys/class/net/eth0/address)
hostname moby-$(echo $mac | sed 's/://g')
fi
# set system clock from hwclock
hwclock --hctosys --utc
# bring up loopback interface
ip addr add 127.0.0.1/8 dev lo brd + scope host
ip route add 127.0.0.0/8 dev lo scope host
ip link set lo up
# for containerising dhcpcd and other containers that need writable etc
mkdir /tmp/etc
mv /etc/resolv.conf /tmp/etc/resolv.conf
ln -snf /tmp/etc/resolv.conf /etc/resolv.conf
# remount rootfs as readonly
mount -o remount,ro /
# make /var writeable and shared
mount -o bind /var /var
mount -o remount,rw,nodev,nosuid,noexec,relatime /var /var
mount --make-rshared /var
# make / rshared
mount --make-rshared /

15
projects/miragesdk/pkg/init/etc/inittab
View File

@ -1,15 +0,0 @@
# /etc/inittab
::sysinit:/etc/init.d/rcS
::once:/etc/init.d/containerd
::once:/etc/init.d/containers
# Stuff to do for the 3-finger salute
::ctrlaltdel:/sbin/reboot
# Stuff to do before rebooting
::shutdown:/usr/sbin/killall5 -15
::shutdown:/bin/sleep 5
::shutdown:/usr/sbin/killall5 -9
::shutdown:/bin/echo "Unmounting filesystems"
::shutdown:/bin/umount -a -r

12
projects/miragesdk/pkg/init/etc/issue
View File

@ -1,12 +0,0 @@
Welcome to Moby
## .
## ## ## ==
## ## ## ## ## ===
/"""""""""""""""""\___/ ===
~~~ {~~ ~~~~ ~~~ ~~~~ ~~~ ~ / ===- ~~~
\______ o __/
\ \ __/
\____\_______/

45
projects/miragesdk/pkg/init/init
View File

@ -1,45 +0,0 @@
#!/bin/sh
setup_console() {
tty=${1%,*}
speed=${1#*,}
inittab="$2"
securetty="$3"
line=
term="linux"
[ "$speed" = "$1" ] && speed=115200
case "$tty" in
ttyS*|ttyAMA*|ttyUSB*|ttyMFD*)
line="-L"
term="vt100"
;;
tty?)
line=""
speed="38400"
term=""
;;
esac
# skip consoles already in inittab
grep -q "^$tty:" "$inittab" && return
echo "$tty::once:cat /etc/issue" >> "$inittab"
echo "$tty::respawn:/sbin/getty -n -l /bin/sh $line $speed $tty $term" >> "$inittab"
if ! grep -q -w "$tty" "$securetty"; then
echo "$tty" >> "$securetty"
fi
}
/bin/mount -t tmpfs tmpfs /mnt
/bin/cp -a / /mnt 2>/dev/null
/bin/mount -t proc -o noexec,nosuid,nodev proc /proc
for opt in $(cat /proc/cmdline); do
case "$opt" in
console=*)
setup_console ${opt#console=} /mnt/etc/inittab /mnt/etc/securetty;;
esac
done
exec /bin/busybox switch_root /mnt /sbin/init

1054
projects/miragesdk/pkg/init/start-stop-daemon.c
View File

File diff suppressed because it is too large Load Diff

3
projects/miragesdk/pkg/mirage-compile/.gitignore vendored
View File

@ -1,3 +0,0 @@
*.hash
functoria
mirage

18
projects/miragesdk/pkg/mirage-compile/Dockerfile
View File

@ -1,18 +0,0 @@
FROM ocaml/opam:alpine-3.5_ocaml-4.04.0
RUN git -C /home/opam/opam-repository pull origin master && opam update -u
RUN opam pin add -n functoria https://github.com/samoht/functoria.git#output
RUN opam pin add -n mirage https://github.com/samoht/mirage.git#static
RUN opam pin add -n mirage-net-fd https://github.com/mirage/mirage-net-fd.git
RUN opam pin add -n charrua-client https://github.com/yomimono/charrua-client.git#state-halfway
RUN opam depext -uiy ocamlfind topkg-care ocamlbuild lwt mirage-types-lwt mirage
RUN opam depext -uiy charrua-client cohttp conduit mirage-unix
RUN opam depext -uiy mirage-net-fd ptime mirage-logs
RUN sudo mkdir -p /src
RUN sudo chown -R opam /src
WORKDIR /src
COPY compile.sh /usr/bin/
ENTRYPOINT ["/usr/bin/compile.sh"]

33
projects/miragesdk/pkg/mirage-compile/Makefile
View File

@ -1,33 +0,0 @@
.PHONY: tag push
BASE=ocaml/opam:alpine-3.5_ocaml-4.04.0
IMAGE=mirage-compile
default: push
hash: Dockerfile compile.sh
docker pull $(BASE)
tar cf - $^ | docker build -t $(IMAGE):build -
docker run --rm --entrypoint=/bin/sh $(IMAGE):build -c \
'{ dpkg-query -W; \
opam list; \
cat /usr/bin/compile.sh; \
} | sha1sum' | sed 's/ .*//' > hash
push: hash
docker pull mobylinux/$(IMAGE):$(shell cat hash) || \
(docker tag $(IMAGE):build mobylinux/$(IMAGE):$(shell cat hash) && \
docker push mobylinux/$(IMAGE):$(shell cat hash))
docker rmi $(IMAGE):build
rm -f hash
tag: hash
docker pull mobylinux/$(IMAGE):$(shell cat hash) || \
docker tag $(IMAGE):build mobylinux/$(IMAGE):$(shell cat hash)
docker rmi $(IMAGE):build
rm -f hash
clean:
rm -f hash $(HASHES)
.DELETE_ON_ERROR:

48
projects/miragesdk/pkg/mirage-compile/compile.sh
View File

@ -1,48 +0,0 @@
#!/bin/sh
set -e
usage() {
echo "Usage: -o file"
exit 1
}
[ $# = 0 ] && usage
while [ $# -gt 0 ]
do
flag="$1"
case "$flag" in
-o)
[ $# -eq 1 ] && usage
out="$2"
mkdir -p "$(dirname $2)"
shift
;;
*)
echo "Unknown option $1"
exit 1
esac
shift
done
[ -z "$out" ] && usage
package=$(basename "$out")
dir="/src"
# untar input
tar xf - -C $dir
(
cd $dir
opam config exec -- mirage configure -o $out -t unix
opam config exec -- make depend
opam config exec -- make
mv $(readlink $out) $out
) > /src/logs 2>&1
cd $dir && tar -cf - $out
exit 0

53
projects/miragesdk/src/Dockerfile
View File

@ -5,7 +5,7 @@ FROM alpine:3.5 as capnp
RUN mkdir -p /src RUN mkdir -p /src
RUN apk update && apk add autoconf automake libtool linux-headers git g++ make RUN apk update && apk add autoconf automake libtool linux-headers git g++ make
RUN cd /src && git clone -b v0.6.0 https://github.com/sandstorm-io/capnproto.git RUN cd /src && git clone https://github.com/sandstorm-io/capnproto.git
WORKDIR /src/capnproto/c++ WORKDIR /src/capnproto/c++
RUN ./setup-autotools.sh RUN ./setup-autotools.sh
RUN autoreconf -i RUN autoreconf -i
@ -17,37 +17,45 @@ RUN which capnp
### SDK ### SDK
FROM ocaml/opam:alpine-3.5_ocaml-4.04.0 as sdk FROM ocaml/opam@sha256:1e1d7fafbfd461bf684b5e11213c85a71fec93577455285e5d82d902ffad91d2 as sdk
#FROM ocaml/opam:alpine-3.5_ocaml-4.04.0 as sdk
COPY --from=capnp /usr/local/bin/capnp /usr/local/bin/ COPY --from=capnp /usr/local/bin/capnp /usr/local/bin/
COPY --from=capnp /usr/local/lib/libcapnpc-0.6.0.so /usr/local/lib/ COPY --from=capnp /usr/local/bin/capnpc /usr/local/bin/
COPY --from=capnp /usr/local/lib/libcapnp-0.6.0.so /usr/local/lib/ COPY --from=capnp /usr/local/lib/libcapnpc-0.7-dev.so /usr/local/lib/
COPY --from=capnp /usr/local/lib/libkj-0.6.0.so /usr/local/lib/ COPY --from=capnp /usr/local/lib/libcapnp-0.7-dev.so /usr/local/lib/
COPY --from=capnp /usr/local/lib/libkj-0.7-dev.so /usr/local/lib/
RUN sudo mkdir -p /src RUN sudo mkdir -p /src
USER opam USER opam
WORKDIR /src WORKDIR /src
RUN git -C /home/opam/opam-repository pull && opam update -u RUN git -C /home/opam/opam-repository fetch origin && \
RUN opam pin add jbuilder 1.0+beta10 -n git -C /home/opam/opam-repository reset ad921dfa87c2e201ef54806d0367aaacce75bc62 --hard && \
opam update -u
RUN opam depext -uiy cstruct cstruct-lwt lwt lwt logs irmin-git rawlink tuntap astring rresult \ RUN opam pin add -n capnp.dev 'https://github.com/talex5/capnp-ocaml.git#interfaces'
mirage-flow-lwt mirage-channel-lwt io-page decompress capnp RUN opam pin add -n capnp-rpc.dev 'https://github.com/mirage/capnp-rpc.git'
RUN opam pin add -n capnp-rpc-lwt.dev 'https://github.com/mirage/capnp-rpc.git'
COPY sdk.opam /src
RUN sudo chown opam -R /src
RUN opam pin add sdk.local /src -n
RUN opam depext -y alcotest sdk
RUN opam install alcotest && opam install --deps sdk
RUN opam list RUN opam list
COPY ./sdk /src/ COPY ./sdk /src/
COPY ./sdk.opam /src/
RUN sudo chown opam -R /src RUN sudo chown opam -R /src
RUN opam config exec -- jbuilder build -p sdk @install RUN opam update sdk && opam install sdk -t
RUN opam config exec -- jbuilder install sdk
### Privileged Container ### Privileged Container
FROM sdk as priv FROM sdk as priv
RUN opam pin add tuntap 1.0.0 -n
RUN opam depext -iy bos cmdliner RUN opam depext -iy bos cmdliner
RUN opam list RUN opam list
@ -56,16 +64,17 @@ COPY ./dhcp-client /src/dhcp-client
RUN sudo chown opam -R /src RUN sudo chown opam -R /src
RUN opam config exec -- jbuilder build dhcp-client/main.exe RUN opam config exec -- jbuilder build dhcp-client/main.exe
RUN sudo mkdir -p /bin RUN sudo mkdir -p /out
RUN sudo cp /src/_build/default/dhcp-client/main.exe /bin/dhcp-client RUN sudo cp /src/_build/default/dhcp-client/main.exe /out/dhcp-client
### Calf Container ### Calf Container
FROM sdk as calf FROM sdk as calf
RUN opam pin add charrua-client https://github.com/yomimono/charrua-client.git#with-cdhcpc -n RUN opam pin add charrua-client.dev https://github.com/samoht/charrua-client.git#with-cdhcpc -n
RUN opam pin add mirage-net-fd 0.2.0 -n RUN opam pin add mirage-net-fd 0.2.0 -n
RUN opam list
RUN opam depext -iy mirage-net-fd charrua-client lwt mirage-types-lwt cmdliner RUN opam depext -iy mirage-net-fd charrua-client lwt mirage-types-lwt cmdliner
RUN opam list RUN opam list
@ -75,15 +84,15 @@ COPY ./dhcp-client-calf/jbuild /src/dhcp-client-calf/
RUN sudo chown opam -R /src RUN sudo chown opam -R /src
RUN opam config exec -- jbuilder build dhcp-client-calf/unikernel.exe RUN opam config exec -- jbuilder build dhcp-client-calf/unikernel.exe
RUN sudo mkdir -p /bin/calf RUN sudo mkdir -p /out/
RUN sudo cp /src/_build/default/dhcp-client-calf/unikernel.exe /bin/calf/dhcp-client-calf RUN sudo cp /src/_build/default/dhcp-client-calf/unikernel.exe /out/dhcp-client-calf
USER 0
### Final build ### Final build
FROM scratch FROM scratch
COPY --from=priv /bin / USER 0
COPY --from=calf /bin / COPY --from=priv /out /
COPY dhcp-client-calf/config.json /calf/ COPY --from=calf /out /calf/rootfs/
COPY dhcp-client-calf/config.json /calf
CMD ["/dhcp-client", "-vv"] CMD ["/dhcp-client", "-vv"]

52
projects/miragesdk/src/Makefile
View File

@ -1,39 +1,25 @@
BASE=ocaml/opam:alpine-3.5_ocaml-4.04.0 .PHONY: tag push
FILES=$(shell find . -name jbuild) \
$(shell find sdk/ -name '*.ml') \
$(shell find sdk/ -name '*.mli') \
dhcp-client/bpf/dhcp.c dhcp-client/main.ml \
dhcp-client-calf/unikernel.ml dhcp-client-calf/config.json
IMAGE=dhcp-client
default: push default: push
@
.build: Dockerfile $(FILES) ORG?=miragesdk
docker build $(NO_CACHE) -t $(IMAGE) -f Dockerfile . IMAGE=dhcp-client
docker build $(NO_CACHE) -t $(IMAGE) -f Dockerfile -q . > .build || \ NOCACHE?=
(rm -f $@ && exit 1)
hash: Makefile Dockerfile $(FILES) .build DEPS=Dockerfile \
{ cat $^; \ $(shell find . -name jbuild) \
docker run --rm --entrypoint sh $(IMAGE) -c 'cat /lib/apk/db/installed'; \ $(shell find . -name '*.ml') \
docker run --rm --entrypoint sh $(IMAGE) -c 'opam list'; } \ $(shell find . -name '*.mli') \
| sha1sum | sed 's/ .*//' > $@ $(shell find . -name '*.c') \
$(shell find . -name '*.json')
tag: .build HASH?=$(shell git ls-tree HEAD -- ../$(notdir $(CURDIR)) | awk '{print $$3}')
docker tag $(IMAGE) linuxkitprojects/$(IMAGE):$(shell cat hash)
push: hash .build tag: $(DEPS)
docker pull $(BASE) docker build --squash $(NOCACHE) -t $(ORG)/$(IMAGE):$(HASH) .
docker pull linuxkitprojects/$(IMAGE):$(shell cat hash) || \
(docker tag $(IMAGE) linuxkitprojects/$(IMAGE):$(shell cat hash) && \
docker push linuxkitprojects/$(IMAGE):$(shell cat hash))
clean:: push: tag
rm -rf hash .build DOCKER_CONTENT_TRUST=1 docker pull $(ORG)/$(IMAGE):$(HASH) || \
(docker rmi -f $(IMAGE) || echo ok) DOCKER_CONTENT_TRUST=1 docker push $(ORG)/$(IMAGE):$(HASH)
#### DEV #### DEV
@ -42,11 +28,9 @@ clean::
test: test:
jbuilder runtest --dev jbuilder runtest --dev
dev-clean: clean:
rm -rf _build jbuilder clean
dev: dev:
jbuilder build dhcp-client/main.exe --dev jbuilder build dhcp-client/main.exe --dev
jbuilder build dhcp-client-calf/unikernel.exe --dev jbuilder build dhcp-client-calf/unikernel.exe --dev
.DELETE_ON_ERROR:

2
projects/miragesdk/src/dhcp-client-calf/config.json
View File

@ -17,7 +17,7 @@
} }
}, },
"root": { "root": {
"path": "calf", "path": "rootfs",
"readonly": true "readonly": true
}, },
"mounts": [ "mounts": [

4
projects/miragesdk/src/dhcp-client-calf/unikernel.ml
View File

@ -208,8 +208,10 @@ let flow (x: int) = Sdk.Init.file_descr (Lwt_unix.of_unix_file_descr @@ fd x)
let start () dhcp_codes net ctl = let start () dhcp_codes net ctl =
Lwt_main.run ( Lwt_main.run (
Lwt_switch.with_switch @@ fun switch ->
let net = fd net in let net = fd net in
let ctl = Sdk.Ctl.Client.v (flow ctl) in let client = Capnp_rpc_lwt.CapTP.of_endpoint ~switch (Capnp_rpc_lwt.Endpoint.of_flow ~switch (module Sdk.IO) (flow ctl)) in
let ctl = Capnp_rpc_lwt.CapTP.bootstrap client in
start () dhcp_codes net ctl start () dhcp_codes net ctl
) )

4
projects/miragesdk/src/dhcp-client/bpf/dhcp.c
View File

@ -28,6 +28,8 @@
#include <net/ethernet.h> #include <net/ethernet.h>
#ifdef __linux__
#include <linux/if_packet.h> #include <linux/if_packet.h>
#include <linux/filter.h> #include <linux/filter.h>
@ -87,3 +89,5 @@ CAMLprim value bpf_filter(value vunit)
memcpy(String_val(vfilter), bootp_bpf_filter, sizeof(bootp_bpf_filter)); memcpy(String_val(vfilter), bootp_bpf_filter, sizeof(bootp_bpf_filter));
CAMLreturn (vfilter); CAMLreturn (vfilter);
} }
#endif

9
projects/miragesdk/src/dhcp-client/main.ml
View File

@ -60,7 +60,7 @@ let default_cmd = [
*) *)
let default_cmd = [ let default_cmd = [
"/usr/bin/runc"; "run"; "--preserve-fds"; "2"; "--bundle"; "."; "calf" "/usr/bin/runc"; "run"; "--preserve-fds"; "2"; "--bundle"; "calf"; "calf"
] ]
let read_cmd file = let read_cmd file =
@ -83,13 +83,18 @@ let run () cmd ethif path =
| Some f -> read_cmd f | Some f -> read_cmd f
in in
Lwt_main.run ( Lwt_main.run (
Lwt_switch.with_switch @@ fun switch ->
let routes = [ let routes = [
["ip"] , [`Write]; ["ip"] , [`Write];
["mac"] , [`Read ]; ["mac"] , [`Read ];
["gateway"], [`Write]; ["gateway"], [`Write];
] in ] in
Ctl.v path >>= fun db -> Ctl.v path >>= fun db ->
let ctl fd = Ctl.Server.listen ~routes db fd in let ctl fd =
let service = Ctl.Server.service ~routes db in
let endpoint = Capnp_rpc_lwt.Endpoint.of_flow ~switch (module Sdk.IO) fd in
ignore (Capnp_rpc_lwt.CapTP.of_endpoint ~switch ~offer:service endpoint)
in
let handlers () = Handlers.watch ~ethif db in let handlers () = Handlers.watch ~ethif db in
let net = Init.rawlink ~filter:(dhcp_filter ()) ethif in let net = Init.rawlink ~filter:(dhcp_filter ()) ethif in
Net.mac ethif >>= fun mac -> Net.mac ethif >>= fun mac ->

7
projects/miragesdk/src/sdk.opam
View File

@ -13,6 +13,7 @@ depends: [
"jbuilder" {build & >= "1.0+beta7"} "jbuilder" {build & >= "1.0+beta7"}
"ocamlfind" {build} "ocamlfind" {build}
"cstruct" "cstruct"
"cstruct-lwt"
"lwt" "lwt"
"logs" "astring" "rresult" "logs" "astring" "rresult"
"mirage-flow-lwt" "mirage-flow-lwt"
@ -20,5 +21,9 @@ depends: [
"io-page" "io-page"
"irmin-git" "irmin-git"
"decompress" "decompress"
"capnp" "capnp-rpc-lwt"
"rawlink"
"tuntap" {= "1.0.0"}
"ipaddr"
"alcotest" {test}
] ]

409
projects/miragesdk/src/sdk/ctl.ml
View File

@ -1,4 +1,5 @@
open Lwt.Infix open Lwt.Infix
open Capnp_rpc_lwt
let src = Logs.Src.create "init" ~doc:"Init steps" let src = Logs.Src.create "init" ~doc:"Init steps"
module Log = (val Logs.src_log src : Logs.LOG) module Log = (val Logs.src_log src : Logs.LOG)
@ -20,6 +21,8 @@ end
module Store = Irmin_git.FS.KV(No_IO)(Inflator)(Io_fs) module Store = Irmin_git.FS.KV(No_IO)(Inflator)(Io_fs)
module KV = Store(Irmin.Contents.String) module KV = Store(Irmin.Contents.String)
let pp_path = Fmt.(brackets (list ~sep:(const string "/") string))
let v path = let v path =
let config = Irmin_git.config path in let config = Irmin_git.config path in
KV.Repo.v config >>= fun repo -> KV.Repo.v config >>= fun repo ->
@ -33,282 +36,50 @@ let () =
module C = Mirage_channel_lwt.Make(IO) module C = Mirage_channel_lwt.Make(IO)
module P = Proto.Make(Capnp.BytesMessage)
exception Undefined_field of int exception Undefined_field of int
module Endpoint = struct let errorf fmt =
Fmt.kstrf (fun x -> Error (`Msg x)) fmt
let compression = `None
type t = {
output : IO.t;
input : C.t; (* reads are buffered *)
decoder: Capnp.Codecs.FramedStream.t;
}
type error = [
| `IO of IO.write_error
| `Channel of C.error
| `Msg of string
| `Undefined_field of int
]
let pp_error ppf (e:error) = match e with
| `IO e -> Fmt.pf ppf "IO: %a" IO.pp_write_error e
| `Channel e -> Fmt.pf ppf "channel: %a" C.pp_error e
| `Msg e -> Fmt.string ppf e
| `Undefined_field i -> Fmt.pf ppf "undefined field %d" i
let err_io e = Error (`IO e)
let err_channel e = Error (`Channel e)
let err_msg fmt = Fmt.kstrf (fun s -> Error (`Msg s)) fmt
let err_frame = err_msg "Unsupported Cap'n'Proto frame received"
let err_undefined_field i = Error (`Undefined_field i)
let v fd =
let output = fd in
let input = C.create fd in
let decoder = Capnp.Codecs.FramedStream.empty compression in
{ output; input; decoder }
let send t msg =
let buf = Capnp.Codecs.serialize ~compression msg in
(* FIXME: avoid copying *)
IO.write t.output (Cstruct.of_string buf) >|= function
| Error e -> err_io e
| Ok () -> Ok ()
let rec recv t =
match Capnp.Codecs.FramedStream.get_next_frame t.decoder with
| Ok msg -> Lwt.return (Ok (`Data msg))
| Error Capnp.Codecs.FramingError.Unsupported -> Lwt.return err_frame
| Error Capnp.Codecs.FramingError.Incomplete ->
Log.info (fun f -> f "Endpoint.recv: incomplete; waiting for more data");
C.read_some ~len:4096 t.input >>= function
| Ok `Eof -> Lwt.return (Ok `Eof)
| Error e -> Lwt.return (err_channel e)
| Ok (`Data data) ->
(* FIXME: avoid copying *)
let data = Cstruct.to_string data in
Log.info (fun f -> f "Got %S" data);
Capnp.Codecs.FramedStream.add_fragment t.decoder data;
recv t
end
module Request = struct
type action =
| Write of string
| Read
| Delete
let pp_action ppf = function
| Write s -> Fmt.pf ppf "write[%S]" s
| Read -> Fmt.pf ppf "read"
| Delete -> Fmt.pf ppf "delete"
type t = {
id : int32 Lazy.t;
path : string list Lazy.t;
action: action Lazy.t;
}
let id t = Lazy.force t.id
let path t = Lazy.force t.path
let action t = Lazy.force t.action
let pp_path = Fmt.(list ~sep:(unit "/") string)
let pp ppf t =
let id = id t and path = path t and action = action t in
match action with
| exception Undefined_field i -> Fmt.pf ppf "<undefined-field: %d>" i
| action -> Fmt.pf ppf "%ld:%a:%a" id pp_path path pp_action action
let equal x y =
id x = id y && path x = path y && match action x = action y with
| exception Undefined_field _ -> false
| b -> b
let v ~id ~path action =
{ id = lazy id; action = lazy action; path = lazy path }
let read e: (t, Endpoint.error) result Lwt.t =
Endpoint.recv e >|= function
| Error e -> Error e
| Ok `Eof -> Error (`IO `Closed)
| Ok (`Data x) ->
let open P.Reader in
let msg = Request.of_message x in
let id = lazy (Request.id_get msg) in
let path = lazy (Request.path_get_list msg) in
let action = lazy (match Request.get msg with
| Request.Write x -> Write x
| Request.Read -> Read
| Request.Delete -> Delete
| Request.Undefined i -> raise (Undefined_field i)
) in
Ok { id; path; action }
let write e t =
let open P.Builder in
match action t with
| exception Undefined_field i -> Lwt.return (Endpoint.err_undefined_field i)
| action ->
let msg =
let b = Request.init_root () in
Request.id_set b (id t);
ignore (Request.path_set_list b (path t));
(match action with
| Write x -> Request.write_set b x
| Read -> Request.read_set b
| Delete -> Request.delete_set b);
b
in
Endpoint.send e (Request.to_message msg)
end
module Response = struct
type status = (string, string) result
let pp_status ppf = function
| Ok ok -> Fmt.pf ppf "ok:%S" ok
| Error e -> Fmt.pf ppf "error:%S" e
type t = {
id : int32 Lazy.t;
status: status Lazy.t;
}
let v ~id status = { id = lazy id; status = lazy status }
let id t = Lazy.force t.id
let status t = Lazy.force t.status
let pp ppf t = match status t with
| exception Undefined_field i -> Fmt.pf ppf "<undefined-field %d>" i
| s -> Fmt.pf ppf "%ld:%a" (id t) pp_status s
let equal x y =
id x = id y && match status x = status y with
| exception Undefined_field _ -> false
| b -> b
let read e: (t, Endpoint.error) result Lwt.t =
Endpoint.recv e >|= function
| Error e -> Error e
| Ok `Eof -> Error (`IO `Closed)
| Ok (`Data x) ->
let open P.Reader in
let msg = Response.of_message x in
let id = lazy (Response.id_get msg) in
let status = lazy (match Response.get msg with
| Response.Ok x -> Ok x
| Response.Error x -> Error x
| Response.Undefined i -> raise (Undefined_field i)
) in
Ok { id; status }
let write e t =
let open P.Builder in
match status t with
| exception Undefined_field i -> Lwt.return (Endpoint.err_undefined_field i)
| s ->
let msg =
let b = Response.init_root () in
Response.id_set b (id t);
(match s with
| Error s -> Response.error_set b s
| Ok s -> Response.ok_set b s);
b
in
Endpoint.send e (Response.to_message msg)
end
let err_not_found = "err-not-found"
module Client = struct module Client = struct
let new_id = module C = Ctl_api.Reader.Ctl
let n = ref 0l in
fun () -> n := Int32.succ !n; !n
type error = [`Msg of string] type error = [`Msg of string]
let pp_error ppf (`Msg s) = Fmt.string ppf s let pp_error ppf (`Msg s) = Fmt.string ppf s
module K = struct type t = C.t Capability.t
type t = int32
let equal = Int32.equal
let hash = Hashtbl.hash
end
module Cache = Hashtbl.Make(K)
type t = {
e : Endpoint.t;
replies: Response.t Cache.t;
}
let v fd = { e = Endpoint.v fd; replies = Cache.create 12 }
let err e = Fmt.kstrf (fun e -> Error (`Msg e)) "%a" Endpoint.pp_error e
let call t r =
let id = Request.id r in
Request.write t.e r >>= function
| Error e -> Lwt.return (err e)
| Ok () ->
let rec loop () =
try
let r = Cache.find t.replies id in
Cache.remove t.replies id;
Lwt.return r
with Not_found ->
Response.read t.e >>= function
| Error e ->
Log.err (fun l -> l "Got %a while waiting for a reply to %ld"
Endpoint.pp_error e id);
loop ()
| Ok r ->
let rid = Response.id r in
if rid = id then Lwt.return r
else (
(* FIXME: maybe we want to check if id is not already
allocated *)
Cache.add t.replies rid r;
loop ()
)
in
loop () >|= fun r ->
assert (Response.id r = id);
match Response.status r with
| Ok s -> Ok s
| Error s -> Error (`Msg s)
let request path action =
let id = new_id () in
Request.v ~id ~path action
let read t path = let read t path =
call t (request path Read) >|= function let module P = Ctl_api.Builder.Ctl.Read_params in
| Ok x -> Ok (Some x) let module R = Ctl_api.Reader.Response in
| Error e -> let req, p = Capability.Request.create P.init_pointer in
if e = `Msg err_not_found then Ok None P.path_set_list p path |> ignore;
else Error e Capability.call_for_value t C.read_method req >|= function
| Error e -> errorf "error: read(%a) -> %a" pp_path path Capnp_rpc.Error.pp e
| Ok r ->
let r = R.of_payload r in
match R.get r with
| R.Ok data -> Ok (Some data)
| R.NotFound -> Ok None
| R.Undefined _ -> Error (`Msg "invalid return")
let write t path v = let write t path data =
call t (request path @@ Write v) >|= function let module P = Ctl_api.Builder.Ctl.Write_params in
| Ok "" -> Ok () let req, p = Capability.Request.create P.init_pointer in
| Ok _ -> Error (`Msg "invalid return") P.path_set_list p path |> ignore;
| Error _ as e -> e P.data_set p data;
Capability.call_for_value t C.write_method req >|= function
| Ok _ -> Ok ()
| Error e -> errorf "error: write(%a) -> %a" pp_path path Capnp_rpc.Error.pp e
let delete t path = let delete t path =
call t (request path Delete) >|= function let module P = Ctl_api.Builder.Ctl.Delete_params in
| Ok "" -> Ok () let req, p = Capability.Request.create P.init_pointer in
| Ok _ -> Error (`Msg "invalid return") P.path_set_list p path |> ignore;
| Error _ as e -> e Capability.call_for_value t C.delete_method req >|= function
| Ok _ -> Ok ()
| Error e -> errorf "error: delete(%a) -> %a" pp_path path Capnp_rpc.Error.pp e
end end
@ -316,80 +87,68 @@ module Server = struct
type op = [ `Read | `Write | `Delete ] type op = [ `Read | `Write | `Delete ]
let ok q s = Response.v ~id:(Request.id q) (Ok s)
let error q s = Response.v ~id:(Request.id q) (Error s)
let with_key q f = f (Request.path q)
let infof fmt = let infof fmt =
Fmt.kstrf (fun msg () -> Fmt.kstrf (fun msg () ->
let date = Int64.of_float (Unix.gettimeofday ()) in let date = Int64.of_float (Unix.gettimeofday ()) in
Irmin.Info.v ~date ~author:"calf" msg Irmin.Info.v ~date ~author:"calf" msg
) fmt ) fmt
let not_allowed q = let not_allowed path =
let path = Request.path q in let err = Fmt.strf "%a is not an allowed path" pp_path path in
let err = Fmt.strf "%a is not an allowed path" Request.pp_path path in Log.err (fun l -> l "%s" err);
Log.err (fun l -> l "%ld: %a" (Request.id q) Request.pp_path path); err
error q err
let dispatch db op q = let write db key value =
with_key q (fun key ->
let can x = List.mem x op in
match Request.action q with
| exception Undefined_field i ->
Fmt.kstrf (fun e -> Lwt.return (error q e)) "undefined field %i" i
| Write s when can `Write ->
let info = infof "Updating %a" KV.Key.pp key in let info = infof "Updating %a" KV.Key.pp key in
KV.set db ~info key s >|= fun () -> KV.set db ~info key value
ok q ""
| Delete when can `Delete -> let delete db key =
let info = infof "Removing %a" KV.Key.pp key in let info = infof "Removing %a" KV.Key.pp key in
KV.remove db ~info key >|= fun () -> KV.remove db ~info key
ok q ""
| Read when can `Read -> let with_permission_check ~routes op key fn =
match List.assoc key routes with
| perms when List.mem op perms -> fn ()
| _ -> Service.fail "%s" (not_allowed key)
| exception Not_found -> Service.fail "%s" (not_allowed key)
let service ~routes db =
Ctl_api.Builder.Ctl.local @@
object (_ : Ctl_api.Builder.Ctl.service)
method read req =
let module P = Ctl_api.Reader.Ctl.Read_params in
let module R = Ctl_api.Builder.Response in
let params = P.of_payload req in
let key = P.path_get_list params in
with_permission_check ~routes `Read key @@ fun () ->
Service.return_lwt (fun () ->
let resp, r = Service.Response.create R.init_pointer in
(KV.find db key >|= function (KV.find db key >|= function
| None -> error q err_not_found | None -> R.not_found_set r
| Some v -> ok q v) | Some x -> R.ok_set r x
| _ -> Lwt.return (not_allowed q) ) >|= fun () ->
Ok resp
) )
let listen ~routes db fd = method write req =
Log.debug (fun l -> l "Serving the control state over %a" IO.pp fd); let module P = Ctl_api.Reader.Ctl.Write_params in
let queries = Queue.create () in let params = P.of_payload req in
let cond = Lwt_condition.create () in let key = P.path_get_list params in
let e = Endpoint.v fd in let value = P.data_get params in
let rec listen () = with_permission_check ~routes `Write key @@ fun () ->
Request.read e >>= function Service.return_lwt (fun () ->
| Error (`Channel _ | `IO _ as e) -> write db key value >|= fun () ->
Log.err (fun l -> l "fatal error: %a" Endpoint.pp_error e); Ok (Service.Response.create_empty ())
Lwt.return_unit )
| Error (`Msg _ | `Undefined_field _ as e) ->
Log.err (fun l -> l "transient error: %a" Endpoint.pp_error e);
listen ()
| Ok q ->
Queue.add q queries;
Lwt_condition.signal cond ();
listen ()
in
let rec process () =
Lwt_condition.wait cond >>= fun () ->
let q = Queue.pop queries in
let path = Request.path q in
(if List.mem_assoc path routes then (
let op = List.assoc path routes in
dispatch db op q >>= fun r ->
Response.write e r
) else (
Response.write e (not_allowed q)
)) >>= function
| Ok () -> process ()
| Error e ->
Log.err (fun l -> l "%a" Endpoint.pp_error e);
process ()
in
Lwt.pick [
listen ();
process ();
]
method delete req =
let module P = Ctl_api.Reader.Ctl.Delete_params in
let params = P.of_payload req in
let key = P.path_get_list params in
with_permission_check ~routes `Delete key @@ fun () ->
Service.return_lwt (fun () ->
delete db key >|= fun () ->
Ok (Service.Response.create_empty ())
)
end
end end

108
projects/miragesdk/src/sdk/ctl.mli
View File

@ -4,103 +4,6 @@
exception Undefined_field of int exception Undefined_field of int
module Endpoint: sig
type t
(** The type for SDK endpoints. *)
val v: IO.t ->t
(** [v f] is a fresh endpoint state built on top of the flow [f]. *)
(** The type for endpoint errors. *)
type error = private [>
| `IO of IO.write_error
| `Msg of string
| `Undefined_field of int
]
val pp_error: error Fmt.t
(** [pp_error] is the pretty-printer for errors. *)
end
module Request: sig
type t
(** The type for SDK requests. *)
(** The type for request actions. *)
type action =
| Write of string
| Read
| Delete
val pp: t Fmt.t
(** [pp] is the pretty-printer for requests. *)
val equal: t -> t -> bool
(** [equal] is the equality function for requests. *)
val pp_action: action Fmt.t
(** [pp_action] is the pretty-printer for request actions. *)
val action: t -> action
(** [action t] is [t]'s requested operation. Can raise
[Endpoint.Undefined_field]. *)
val path: t -> string list
(** [path t] is the [t]'s request path. *)
val id: t -> int32
(** [id t] it [t]'s request id. *)
val v: id:int32 -> path:string list -> action -> t
(** [v ~id ~path action] is a new request. *)
val write: Endpoint.t -> t -> (unit, Endpoint.error) result Lwt.t
(** [write e t] writes a request message for the
action [action] and the path [path] using the unique ID [id]. *)
val read: Endpoint.t -> (t, Endpoint.error) result Lwt.t
(** [read e] reads a query message. *)
end
module Response: sig
type t
(** The type for responses. *)
(** The type for response status. *)
type status = (string, string) result
val pp: t Fmt.t
(** [pp] is the pretty-printer for responses. *)
val equal: t -> t -> bool
(** [equal] is the equality function for responses. *)
val pp_status: status Fmt.t
(** [pp_status] is the pretty-printer for response statuses. *)
val status: t -> status
(** [status t] is [t]'s response status. Can raise
[Endpoint.Undefined_field]. *)
val id: t -> int32
(** [id t] is [t]'s response ID. *)
val v: id:int32 -> status -> t
(** [v ~id status] is a new response. *)
val write: Endpoint.t -> t -> (unit, Endpoint.error) result Lwt.t
(** [write fd t] writes a reply message. *)
val read: Endpoint.t -> (t, Endpoint.error) result Lwt.t
(** [read fd] reads a reply message. *)
end
module Client: sig module Client: sig
(** Client-side of the control plane. The control plane state is a (** Client-side of the control plane. The control plane state is a
@ -110,7 +13,7 @@ module Client: sig
TODO: decide if we want to support test_and_set (instead of TODO: decide if we want to support test_and_set (instead of
write) and some kind of watches. *) write) and some kind of watches. *)
type t type t = Ctl_api.Reader.Ctl.t Capnp_rpc_lwt.Capability.t
(** The type for client state. *) (** The type for client state. *)
type error type error
@ -119,11 +22,6 @@ module Client: sig
val pp_error: error Fmt.t val pp_error: error Fmt.t
(** [pp_error] is the pretty-printer for client errors. *) (** [pp_error] is the pretty-printer for client errors. *)
val v: IO.t -> t
(** [v fd] is the client state using [fd] to send requests to the
server. A client state also stores some state for all the
incomplete client queries. *)
val read: t -> string list -> (string option, error) result Lwt.t val read: t -> string list -> (string option, error) result Lwt.t
(** [read t k] is the value associated with the key [k] in the (** [read t k] is the value associated with the key [k] in the
control plane state. Return [None] if no value is associated to control plane state. Return [None] if no value is associated to
@ -150,8 +48,8 @@ module Server: sig
type op = [ `Read | `Write | `Delete ] type op = [ `Read | `Write | `Delete ]
(** The type for operations to perform on routes. *) (** The type for operations to perform on routes. *)
val listen: routes:(string list * op list) list -> KV.t -> IO.t -> unit Lwt.t val service: routes:(string list * op list) list -> KV.t -> Ctl_api.Reader.Ctl.t Capnp_rpc_lwt.Capability.t
(** [listen ~routes kv fd] is the thread exposing the KV store [kv], (** [service ~routes kv] is the thread exposing the KV store [kv],
holding control plane state, running inside the privileged holding control plane state, running inside the privileged
container. [routes] are the routes exposed by the server to the container. [routes] are the routes exposed by the server to the
calf and [kv] is the control plane state. *) calf and [kv] is the control plane state. *)

3
projects/miragesdk/src/sdk/init.ml
View File

@ -288,6 +288,8 @@ let exec_and_forward ?(handlers=block_for_ever) ~pid ~cmd ~net ~ctl t =
let priv_stdout = Fd.flow Pipe.(priv t.stdout) in let priv_stdout = Fd.flow Pipe.(priv t.stdout) in
let priv_stderr = Fd.flow Pipe.(priv t.stderr) in let priv_stderr = Fd.flow Pipe.(priv t.stderr) in
ctl priv_ctl;
Lwt.pick ([ Lwt.pick ([
wait (); wait ();
(* data *) (* data *)
@ -298,7 +300,6 @@ let exec_and_forward ?(handlers=block_for_ever) ~pid ~cmd ~net ~ctl t =
IO.forward ~verbose:false ~src:priv_stderr ~dst:Fd.(flow stderr); IO.forward ~verbose:false ~src:priv_stderr ~dst:Fd.(flow stderr);
(* TODO: Init.Fd.forward ~src:Init.Pipe.(priv metrics) (* TODO: Init.Fd.forward ~src:Init.Pipe.(priv metrics)
~dst:Init.Fd.metric; *) ~dst:Init.Fd.metric; *)
ctl priv_ctl;
handlers (); handlers ();
]) ])

4
projects/miragesdk/src/sdk/init.mli
View File

@ -110,11 +110,11 @@ val exec: Pipe.monitor -> string list -> (int -> unit Lwt.t) -> unit Lwt.t
(* FIXME(samoht): not very happy with that signatue *) (* FIXME(samoht): not very happy with that signatue *)
val run: Pipe.monitor -> val run: Pipe.monitor ->
net:IO.t -> ctl:(IO.t -> unit Lwt.t) -> net:IO.t -> ctl:(IO.t -> unit) ->
?handlers:(unit -> unit Lwt.t) -> ?handlers:(unit -> unit Lwt.t) ->
string list -> unit Lwt.t string list -> unit Lwt.t
(** [run m ~net ~ctl ?handlers cmd] runs [cmd] in a unprivileged calf (** [run m ~net ~ctl ?handlers cmd] runs [cmd] in a unprivileged calf
process. [net] is the network interface flow. [ctl] is the control process. [net] is the network interface flow. [ctl] runs the control
thread connected to the {Pipe.ctl} pipe. [handlers] are the system thread connected to the {Pipe.ctl} pipe. [handlers] are the system
handler thread which will react to control data to perform handler thread which will react to control data to perform
privileged system actions. *) privileged system actions. *)

12
projects/miragesdk/src/sdk/jbuild
View File

@ -3,16 +3,12 @@
(library (library
((name sdk) ((name sdk)
(public_name sdk) (public_name sdk)
(flags (:standard -w -53-55))
(libraries (cstruct.lwt decompress irmin irmin-git lwt.unix rawlink (libraries (cstruct.lwt decompress irmin irmin-git lwt.unix rawlink
tuntap astring rresult mirage-flow-lwt capnp tuntap astring rresult mirage-flow-lwt capnp capnp-rpc-lwt
mirage-channel-lwt io-page.unix ipaddr)) mirage-channel-lwt io-page.unix ipaddr))))
))
(rule (rule
((targets (proto.ml proto.mli)) ((targets (proto.ml proto.mli))
(deps (proto.capnp)) (deps (proto.capnp))
(action (progn (action (run capnp compile -o ocaml ${<}))))
(run capnp compile -o ocaml ${<})
(system "mv proto.ml proto.ml.in")
(system "echo '[@@@ocaml.warning \"-A\"]\n' > proto.ml")
(system "cat proto.ml.in >> proto.ml")))))

4
projects/miragesdk/src/sdk/net.ml
View File

@ -2,8 +2,12 @@
open Lwt.Infix open Lwt.Infix
let src = Logs.Src.create "net" ~doc:"Network Configuration"
module Log = (val Logs.src_log src : Logs.LOG)
let run fmt = let run fmt =
Fmt.kstrf (fun str -> Fmt.kstrf (fun str ->
Log.info (fun l -> l "run: %S" str);
match Sys.command str with match Sys.command str with
| 0 -> Lwt.return () | 0 -> Lwt.return ()
| i -> Fmt.kstrf Lwt.fail_with "%S exited with code %d" str i | i -> Fmt.kstrf Lwt.fail_with "%S exited with code %d" str i

19
projects/miragesdk/src/sdk/proto.capnp
View File

@ -1,19 +1,14 @@
@0x9e83562906de8259; @0x9e83562906de8259;
struct Request { struct Response {
id @0 :Int32;
path @1 :List(Text);
union { union {
write @2 :Data; ok @0 :Data;
read @3 :Void; notFound @1 :Void;
delete @4 :Void;
} }
} }
struct Response { interface Ctl {
id @0: Int32; write @0 (path :List(Text), data: Data) -> ();
union { read @1 (path :List(Text)) -> Response;
ok @1 :Data; delete @2 (path :List(Text)) -> ();
error @2 :Data;
}
} }

61
projects/miragesdk/src/test/test.ml
View File

@ -93,50 +93,6 @@ let test_socketpair pipe () =
Lwt.return_unit Lwt.return_unit
let request = Alcotest.testable Ctl.Request.pp Ctl.Request.equal
let response = Alcotest.testable Ctl.Response.pp Ctl.Response.equal
let queries =
let open Ctl.Request in
[
v ~id:0l ~path:["foo";"bar"] Read;
v ~id:Int32.max_int ~path:[] (Write "foo");
v ~id:0l ~path:[] Delete;
v ~id:(-3l) ~path:["foo"] Delete;
]
let replies =
let open Ctl.Response in
[
v ~id:0l (Ok "");
v ~id:Int32.max_int (Ok "foo");
v ~id:0l (Error "");
v ~id:(-3l) (Error "foo");
]
let failf fmt = Fmt.kstrf Alcotest.fail fmt
let test_send t write read message messages =
let calf = Ctl.Endpoint.v @@ calf Init.Pipe.(ctl t) in
let priv = Ctl.Endpoint.v @@ priv Init.Pipe.(ctl t) in
let test m =
write calf m >>= function
| Error e -> failf "Message.write: %a" Ctl.Endpoint.pp_error e
| Ok () ->
read priv >|= function
| Ok m' -> Alcotest.(check message) "write/read" m m'
| Error e -> failf "Message.read: %a" Ctl.Endpoint.pp_error e
in
Lwt_list.iter_s test messages
let test_request_send t () =
let open Ctl.Request in
test_send t write read request queries
let test_response_send t () =
let open Ctl.Response in
test_send t write read response replies
let failf fmt = Fmt.kstrf Alcotest.fail fmt let failf fmt = Fmt.kstrf Alcotest.fail fmt
(* read ops *) (* read ops *)
@ -188,6 +144,7 @@ let delete_should_work t k =
| Error e -> failf "write(%a) -> error: %a" pp_path k pp_error e | Error e -> failf "write(%a) -> error: %a" pp_path k pp_error e
let test_ctl t () = let test_ctl t () =
Lwt_switch.with_switch @@ fun switch ->
let calf = calf Init.Pipe.(ctl t) in let calf = calf Init.Pipe.(ctl t) in
let priv = priv Init.Pipe.(ctl t) in let priv = priv Init.Pipe.(ctl t) in
let k1 = ["foo"; "bar"] in let k1 = ["foo"; "bar"] in
@ -199,9 +156,12 @@ let test_ctl t () =
let git_root = "/tmp/sdk/ctl" in let git_root = "/tmp/sdk/ctl" in
let _ = Sys.command (Fmt.strf "rm -rf %s" git_root) in let _ = Sys.command (Fmt.strf "rm -rf %s" git_root) in
Ctl.v git_root >>= fun ctl -> Ctl.v git_root >>= fun ctl ->
let server () = Ctl.Server.listen ~routes ctl priv in let _server =
let client () = let service = Ctl.Server.service ~routes ctl in
let t = Ctl.Client.v calf in Capnp_rpc_lwt.CapTP.of_endpoint ~switch ~offer:service (Capnp_rpc_lwt.Endpoint.of_flow ~switch (module IO) priv)
in
let client = Capnp_rpc_lwt.CapTP.of_endpoint ~switch (Capnp_rpc_lwt.Endpoint.of_flow ~switch (module IO) calf) in
let t = Capnp_rpc_lwt.CapTP.bootstrap client in
let allowed k v = let allowed k v =
delete_should_work t k >>= fun () -> delete_should_work t k >>= fun () ->
read_should_none t k >>= fun () -> read_should_none t k >>= fun () ->
@ -220,11 +180,6 @@ let test_ctl t () =
allowed k3 (random_string (255 * 1024)) >>= fun () -> allowed k3 (random_string (255 * 1024)) >>= fun () ->
disallowed k4 "" >>= fun () -> disallowed k4 "" >>= fun () ->
Lwt.return_unit Lwt.return_unit
in
Lwt.pick [
client ();
server ();
]
let in_memory_flow () = let in_memory_flow () =
let flow = Mirage_flow_lwt.F.string () in let flow = Mirage_flow_lwt.F.string () in
@ -268,8 +223,6 @@ let test = [
"stdout is a pipe" , `Quick, run (test_pipe Init.Pipe.(stderr t)); "stdout is a pipe" , `Quick, run (test_pipe Init.Pipe.(stderr t));
"net is a socket pair", `Quick, run (test_socketpair Init.Pipe.(net t)); "net is a socket pair", `Quick, run (test_socketpair Init.Pipe.(net t));
"ctl is a socket pair", `Quick, run (test_socketpair Init.Pipe.(ctl t)); "ctl is a socket pair", `Quick, run (test_socketpair Init.Pipe.(ctl t));
"send requests" , `Quick, run (test_request_send t);
"send responses" , `Quick, run (test_response_send t);
"ctl" , `Quick, run (test_ctl t); "ctl" , `Quick, run (test_ctl t);
"exec" , `Quick, run test_exec; "exec" , `Quick, run test_exec;
] ]