From f2c64f448271cb1dbaed9136a2fa54dccfe30774 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 10 Mar 2017 17:50:01 +0100 Subject: [PATCH 1/6] Add a basic architecture doc for unikernel integration Signed-off-by: Thomas Gazagnaire --- docs/unikernels.md | 121 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 121 insertions(+) create mode 100644 docs/unikernels.md diff --git a/docs/unikernels.md b/docs/unikernels.md new file mode 100644 index 000000000..bf51a5985 --- /dev/null +++ b/docs/unikernels.md @@ -0,0 +1,121 @@ +## Unikernel System Containers + +### General Architecture + +``` + |=================| |================| + | privileged shim | | calf | + |=================| |================| + | | | | + eth0 ----> | eBPF rules | <--- network IO ---> | type-safe | + | | (data path) | network stack | + | | | | + |-----------------| |----------------| + | | | | +<-- logs ----- | | <------- logs ------ | type-safe | + | | | protocol logic | +<-- metrics -- | | <----- metrics ----- | | + | | | | + |-----------------| |----------------| + | | | | +<-- audit --- | config store | <----- KV store ---> | config store | + diagnostic | deamon | (control path) | client | + | | | | + |_________________| |________________| + | | +<-- sycalls -- | | + | | + | system handlers | +<-- config --- | | + files | | + |_________________| +``` + +1. privileged shim (privileged system service) + - run in a privileged container + - can read all network traffic + - can set-up eBPF rules (or a dumb forwarder to start with) + - exposes an easily auditable KV store for configuration values + (over a simple REST/HTTP API to start with). + Expose a scoped "view" of the config store to the + calf (a different branch in a datakit store for instance) and another + unscoped "view" to the host (could be a Git log if using datakit). + - has a set of system handlers who watches for changes in the KV + store and perform privileged operations inside moby (syscalls, edit + global config files, etc). System handlers use the config store CLI + to wait for events and react. + +2. calf (sandboxed system service) + - run in a fully isolated container + - full sandbox (initially a normal Unix process, later on unielf/wasm) + - has a type-safe network stack to handle network IO + - has type-safe business logic to process network IO + - has a limited access read and write access to the config store where the + result of the business logic is output + +### DHCP client + +#### Shim + +- forward DHCP traffic only (in both directions) +- expose a simple store to the calf, with the following keys: + +``` +/ip (mandatory) +/mtu (optional) +/domain (optional) +/search (optional) +/nameserver/001 (optional) +... +/nameserver/xxx (optional) +``` + +If runs a small webserver where it exposes a simple CRUD interface +over these keys -- only the calf can see it (e.g. it opens a pipe and +share it with the calf on startup). + +- system handlers: + - if /ip change -> set IP address on moby host + - if /domain change -> set moby domain name + - if /search -> set search domain on moby host + - if /nameserver/xxx -> set DNS servers on moby + +#### Calf + +- MirageOS unikernel using charrua-client (or a fork of it). +- Has access to a Mirage_net.S interface for network traffic +- Has access to a a simple KV interface + +Internally, it might use something more typed than a KV store: + +``` +module Shim: sig + val set_ip: Ipaddr.V4.t -> unit Lwt.t + val set_domain: string -> unit Lwt.t + val set_search: string -> unit Lwt.t + val set_nameservers: Ipaddr.V4.t list Lwt.t +end +``` + +but this ends up being translated into REST/RPC calls to the shim. + +### SDK + +What the SDK should enable: +1. easily write a new calfs initially in OCaml, then Rust. + Probably not very useful on its own. +2. easily write a new shim by providing the basic blocks: + eBPF scripts, calf runner, KV store, system handlers. + Initially could be a standalone blob, but should aim for + independant and re-usable pieces that could run in a + container. +3. (later) generate shim/caft containers from a single (API?) + description. + +### Roadmap + +- first PoC +- ipv6 support +- gracefully handle expiration +- tests, tests, tests (especially against non compliant RFC servers) +- second iteration: NTP \ No newline at end of file From 1715e0b4648b3bb1c8fb123b669b3e704ca4397a Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 10 Mar 2017 14:25:11 +0100 Subject: [PATCH 2/6] Add container for MirageOS compiler Signed-off-by: Thomas Gazagnaire --- tools/mirage-compile/.gitignore | 3 +++ tools/mirage-compile/Dockerfile | 18 +++++++++++++ tools/mirage-compile/Makefile | 33 +++++++++++++++++++++++ tools/mirage-compile/compile.sh | 48 +++++++++++++++++++++++++++++++++ 4 files changed, 102 insertions(+) create mode 100644 tools/mirage-compile/.gitignore create mode 100644 tools/mirage-compile/Dockerfile create mode 100644 tools/mirage-compile/Makefile create mode 100755 tools/mirage-compile/compile.sh diff --git a/tools/mirage-compile/.gitignore b/tools/mirage-compile/.gitignore new file mode 100644 index 000000000..052e350ae --- /dev/null +++ b/tools/mirage-compile/.gitignore @@ -0,0 +1,3 @@ +*.hash +functoria +mirage diff --git a/tools/mirage-compile/Dockerfile b/tools/mirage-compile/Dockerfile new file mode 100644 index 000000000..6ebfa314b --- /dev/null +++ b/tools/mirage-compile/Dockerfile @@ -0,0 +1,18 @@ +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"] diff --git a/tools/mirage-compile/Makefile b/tools/mirage-compile/Makefile new file mode 100644 index 000000000..2e463671a --- /dev/null +++ b/tools/mirage-compile/Makefile @@ -0,0 +1,33 @@ +.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: diff --git a/tools/mirage-compile/compile.sh b/tools/mirage-compile/compile.sh new file mode 100755 index 000000000..fdfcadc03 --- /dev/null +++ b/tools/mirage-compile/compile.sh @@ -0,0 +1,48 @@ +#!/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 From 7bfd78a3b36f61bc1624ae9f72cb63f174011d4b Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 10 Mar 2017 14:26:32 +0100 Subject: [PATCH 3/6] Add an initial PoC for a DHCP client unikernel system container Signed-off-by: Thomas Gazagnaire --- base/dhcp-client/.gitignore | 23 ++ base/dhcp-client/Dockerfile.build | 18 ++ base/dhcp-client/Dockerfile.dev | 21 ++ base/dhcp-client/Dockerfile.pkg | 4 + base/dhcp-client/Makefile | 71 ++++++ base/dhcp-client/README.md | 14 ++ base/dhcp-client/calf/.merlin | 3 + base/dhcp-client/calf/config.ml | 57 +++++ base/dhcp-client/calf/unikernel.ml | 225 +++++++++++++++++ base/dhcp-client/init-dev.sh | 5 + base/dhcp-client/src/.merlin | 4 + base/dhcp-client/src/_tags | 6 + base/dhcp-client/src/inflator.ml | 47 ++++ base/dhcp-client/src/io_fs.ml | 325 ++++++++++++++++++++++++ base/dhcp-client/src/main.ml | 392 +++++++++++++++++++++++++++++ 15 files changed, 1215 insertions(+) create mode 100644 base/dhcp-client/.gitignore create mode 100644 base/dhcp-client/Dockerfile.build create mode 100644 base/dhcp-client/Dockerfile.dev create mode 100644 base/dhcp-client/Dockerfile.pkg create mode 100644 base/dhcp-client/Makefile create mode 100644 base/dhcp-client/README.md create mode 100644 base/dhcp-client/calf/.merlin create mode 100644 base/dhcp-client/calf/config.ml create mode 100644 base/dhcp-client/calf/unikernel.ml create mode 100644 base/dhcp-client/init-dev.sh create mode 100644 base/dhcp-client/src/.merlin create mode 100644 base/dhcp-client/src/_tags create mode 100644 base/dhcp-client/src/inflator.ml create mode 100644 base/dhcp-client/src/io_fs.ml create mode 100644 base/dhcp-client/src/main.ml diff --git a/base/dhcp-client/.gitignore b/base/dhcp-client/.gitignore new file mode 100644 index 000000000..820517ae9 --- /dev/null +++ b/base/dhcp-client/.gitignore @@ -0,0 +1,23 @@ +.build +.pkg +.dev +obj/ + +# Generated by `make dev` +_build/ +main.native + +# Generated by the mirage tool +calf/_build +calf/Makefile +calf/myocamlbuild.ml +calf/*.opam +calf/key_gen.ml +calf/main.ml +calf/.mirage.config + +# Trash files +\#* +.#* +*~ +.*~ \ No newline at end of file diff --git a/base/dhcp-client/Dockerfile.build b/base/dhcp-client/Dockerfile.build new file mode 100644 index 000000000..2a68a417b --- /dev/null +++ b/base/dhcp-client/Dockerfile.build @@ -0,0 +1,18 @@ +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 -n add conduit https://github.com/samoht/ocaml-conduit.git#fd +RUN opam pin -n add mirage-net-unix https://github.com/samoht/mirage-net-unix.git#fd + +RUN opam depext -iy mirage-net-unix logs-syslog irmin-unix cohttp decompress +RUN opam depext -iy rawlink + +RUN sudo mkdir -p /src /bin +COPY ./src /src +RUN sudo chown opam -R /src + +USER opam +WORKDIR /src + +RUN opam config exec -- ocamlbuild -use-ocamlfind -lflags -cclib,-static main.native +RUN sudo cp /src/_build/main.native /dhcp-client diff --git a/base/dhcp-client/Dockerfile.dev b/base/dhcp-client/Dockerfile.dev new file mode 100644 index 000000000..98e7d8962 --- /dev/null +++ b/base/dhcp-client/Dockerfile.dev @@ -0,0 +1,21 @@ +FROM mobylinux/mirage-compile:4e4686b60909d88a75f3f24c0429d0a8e415faa3 +RUN cd /home/opam/opam-repository && git pull && opam update -u + +RUN opam pin -n add conduit https://github.com/samoht/ocaml-conduit.git#fd +RUN opam pin -n add mirage-net-unix https://github.com/samoht/mirage-net-unix.git#fd + +RUN opam depext -iy mirage-net-unix logs-syslog cohttp decompress +RUN opam depext -iy rawlink + +RUN sudo mkdir -p /src /bin + +COPY calf /src/calf +RUN sudo chown opam -R /src +RUN cd /src/calf && opam config exec -- mirage configure && make depend + +COPY . /src +COPY init-dev.sh /home/opam/init-dev.sh + +USER opam +WORKDIR /src +ENTRYPOINT ["/bin/sh", "/home/opam/init-dev.sh"] \ No newline at end of file diff --git a/base/dhcp-client/Dockerfile.pkg b/base/dhcp-client/Dockerfile.pkg new file mode 100644 index 000000000..bfe815767 --- /dev/null +++ b/base/dhcp-client/Dockerfile.pkg @@ -0,0 +1,4 @@ +#FROM ocaml/opam:alpine-3.5_ocaml-4.04.0 +FROM scratch +COPY obj ./ +CMD ["/dhcp-client"] \ No newline at end of file diff --git a/base/dhcp-client/Makefile b/base/dhcp-client/Makefile new file mode 100644 index 000000000..e2b6885b2 --- /dev/null +++ b/base/dhcp-client/Makefile @@ -0,0 +1,71 @@ +BASE=ocaml/opam:alpine-3.5_ocaml-4.04.0 +FILES=src/main.ml src/inflator.ml src/io_fs.ml src/_tags +IMAGE=dhcp-client +OBJS=obj/dhcp-client + +MIRAGE_COMPILE=mobylinux/mirage-compile:f903b0e1b4328271364cc63f123ac49d56739cef@sha256:a54d9ca84d3f5998dba92ce83d60d49289cee8908a8b0f6ec280d30ab8edf46c +CALF_OBJS=obj/dhcp-client-calf +CALF_FILES=calf/config.ml calf/unikernel.ml + +default: push + @ + +.build: Dockerfile.build $(FILES) + docker build -t $(IMAGE):build -f Dockerfile.build -q . > .build || \ + (rm -f $@ && exit 1) + +.pkg: Dockerfile.pkg $(OBJS) $(CALF_OBJS) + docker build -t $(IMAGE):pkg -f Dockerfile.pkg -q . > .pkg || \ + (rm -f $@ && exit 1) + +.dev: Dockerfile.dev init-dev.sh + docker build -t $(IMAGE):dev -f Dockerfile.dev -q . > .dev || \ + (rm -f $@ && exit 1) + +enter-pkg: .pkg + docker run -v /bin/sh:/bin/sh -it --rm --entrypoint=/bin/sh $(shell cat .pkg) + +enter-build: .build + docker run -it --rm $(shell cat .build) + +enter-dev: .dev + docker run --privileged -it -v `pwd`:/src $(shell cat .dev) + +$(CALF_OBJS): $(CALF_FILES) + mkdir -p obj/bin + ( cd obj && \ + tar -C ../calf -cf - $(CALF_FILES:calf/%=%) | \ + docker run --rm -i --log-driver=none $(MIRAGE_COMPILE) -o dhcp-client-calf | \ + tar xf - ) && \ + touch $@ + +$(OBJS): .build $(FILES) + mkdir -p obj/usr/lib obj/bin + ( cd obj && \ + docker run --rm --net=none --log-driver=none -i $(IMAGE):build tar -cf - $(OBJS:obj/%=/%) | tar xf - ) && \ + touch $@ + +hash: Dockerfile.build Dockerfile.pkg $(FILES) $(CALF_FILES) .build + { cat $^; \ + docker run --rm --entrypoint sh $(IMAGE):build -c 'cat /lib/apk/db/installed'; \ + docker run --rm --entrypoint sh $(IMAGE):build -c 'opam list'; } \ + | sha1sum | sed 's/ .*//' > $@ + +push: hash .pkg + docker pull $(BASE) + docker pull mobylinux/$(IMAGE):$(shell cat hash) || \ + (docker tag $(IMAGE):pkg mobylinux/$(IMAGE):$(shell cat hash) && \ + docker push mobylinux/$(IMAGE):$(shell cat hash)) + +clean:: + rm -rf hash obj .build .pkg .dev + (docker rmi -f $(IMAGE):build || echo ok) + (docker rmi -f $(IMAGE):pkg || echo ok) + (docker rmi -f $(IMAGE):dev || echo ok) + +dev: + cd calf && mirage configure && make + ocamlbuild -use-ocamlfind -lflags -cclib,-static src/main.native + sudo ./_build/src/main.native -vv --cmd 'calf/_build/main.native -l debug --store 10 --net 12' + +.DELETE_ON_ERROR: diff --git a/base/dhcp-client/README.md b/base/dhcp-client/README.md new file mode 100644 index 000000000..9640b090c --- /dev/null +++ b/base/dhcp-client/README.md @@ -0,0 +1,14 @@ +## DHCP client using MirageOS + +To debug/build, the `enter-dev` target will create a dev container where +`make dev` will build and run the current state of the prototype: + +``` +make enter-dev +# now in the dev container +make dev +``` + +### Documentation + +See the [general architecture document](../../doc/unikernel.md). \ No newline at end of file diff --git a/base/dhcp-client/calf/.merlin b/base/dhcp-client/calf/.merlin new file mode 100644 index 000000000..ada5d1966 --- /dev/null +++ b/base/dhcp-client/calf/.merlin @@ -0,0 +1,3 @@ +PKG mirage mirage-time-lwt mirage-net-lwt jsonm duration charrua-client mirage-http +B _build +S . \ No newline at end of file diff --git a/base/dhcp-client/calf/config.ml b/base/dhcp-client/calf/config.ml new file mode 100644 index 000000000..18127b5e4 --- /dev/null +++ b/base/dhcp-client/calf/config.ml @@ -0,0 +1,57 @@ +open Mirage + +(* create a new device for mirage-net-fd *) +(* FIXME: should check it is invoked only with the unix backend *) +(* FIXME: this is a temporary solution, this should be exposed + as a ukvm/virtio device *) +let netif_of_fd id = impl @@ + let key = Key.abstract id in + object + inherit base_configurable + method ty = network + val name = Functoria_app.Name.create "net" ~prefix:"net" + method name = name + method module_name = "Netif_fd" + method keys = [ key ] + method packages = Key.pure [ package "mirage-net-fd" ] + method connect _ modname _ = + Fmt.strf "@[let (key: int) = %a in@, + %s.connect (Obj.magic key: Unix.file_descr)@]" + Key.serialize_call key modname + method configure i = + Ok () + end + +let dhcp_codes = + let doc = Key.Arg.info ~docv:"OPT" ~doc:"DHCP options." ["c";"codes"] in + Key.(abstract @@ create "codes" Arg.(opt (list string) [] doc)) + +let net = + let doc = + Key.Arg.info ~docv:"FD" ~doc:"Network interface" ["net"] + in + let key = Key.(create "input" Arg.(opt int 3 doc)) in + netif_of_fd key + +let store = + let doc = + Key.Arg.info ~docv:"FD" ~doc:"Store interface" ["store"] + in + let key = Key.(create "output" Arg.(opt int 4 doc)) in + netif_of_fd key + +let keys = [dhcp_codes] + +let packages = [ + package "jsonm"; + package "charrua-client"; + package "duration"; + package "charrua-client" ~sublibs:["mirage"]; + package "cohttp" ~sublibs:["lwt"] +] + +let main = + foreign ~keys ~packages "Unikernel.Main" + (time @-> network @-> network @-> job) + +let () = register "dhcp-client" [main $ default_time $ net $ store] diff --git a/base/dhcp-client/calf/unikernel.ml b/base/dhcp-client/calf/unikernel.ml new file mode 100644 index 000000000..7d677f93b --- /dev/null +++ b/base/dhcp-client/calf/unikernel.ml @@ -0,0 +1,225 @@ +open Lwt.Infix + +let src = Logs.Src.create "charrua" +module Log = (val Logs.src_log src : Logs.LOG) + +type t = { + address: Ipaddr.V4.t; + domain: string option; + search: string option; + nameservers: Ipaddr.V4.t list; +} + +(* FIXME: we loose lots of info here *) +let of_ipv4_config (t: Mirage_protocols_lwt.ipv4_config) = + { address = t.Mirage_protocols_lwt.address; + domain = None; + search = None; + nameservers = [] } + +let pp ppf t = + Fmt.pf ppf "\n\ + address : %a\n\ + domain : %a\n\ + search : %a\n\ + nameservers: %a\n" + Ipaddr.V4.pp_hum t.address + Fmt.(option ~none:(unit "--") string) t.domain + Fmt.(option ~none:(unit "--") string) t.search + Fmt.(list ~sep:(unit " ") Ipaddr.V4.pp_hum) t.nameservers + +let of_pkt lease = + let open Dhcp_wire in + (* ipv4_config expects a single IP address and the information + * needed to construct a prefix. It can optionally use one router. *) + let address = lease.yiaddr in + let domain = Dhcp_wire.find_domain_name lease.options in + let search = Dhcp_wire.find_domain_search lease.options in + let nameservers = Dhcp_wire.collect_name_servers lease.options in + { address; domain; search; nameservers } + +let of_pkt_opt = function + | None -> None + | Some lease -> Some (of_pkt lease) + +let parse_option_code str = + match Dhcp_wire.string_to_option_code str with + | Some x -> Ok x + | None -> Error (Fmt.strf "%s is not a valid DHCP option code" str) + +let default_options = + let open Dhcp_wire in + [ + RAPID_COMMIT; + DOMAIN_NAME; + DOMAIN_SEARCH; + HOSTNAME; + CLASSLESS_STATIC_ROUTE; + NTP_SERVERS; + INTERFACE_MTU; + ] + +(* Build a raw flow from a network interface *) +module Raw (Net: Mirage_net_lwt.S): sig + include Mirage_flow_lwt.S + val connect: Net.t -> flow Lwt.t +end = struct + + type 'a io = 'a Net.io + type error = Net.error + let pp_error = Net.pp_error + type write_error = [ Mirage_flow.write_error | `Net of Net.error ] + + let pp_write_error ppf = function + | #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e + | `Net e -> Net.pp_error ppf e + + type flow = { + netif: Net.t; + mutable closed: bool; + listener: unit Lwt.t; + bufs: Cstruct.t Queue.t; + cond: [`Eof | `Data] Lwt_condition.t; + } + + type buffer = Cstruct.t + + let connect netif = + let cond = Lwt_condition.create () in + let bufs = Queue.create () in + let listener = + Net.listen netif (fun buf -> + Queue.add buf bufs; + Lwt_condition.signal cond `Data; + Lwt.return_unit) + >|= function + | Ok () -> () + | Error e -> + Log.debug (fun l -> l "net->flow listen: %a" Net.pp_error e); + Lwt_condition.broadcast cond `Eof + in + Lwt.return { netif; bufs; cond; closed = false; listener } + + let read flow = + if flow.closed then Lwt.return (Error `Disconnected) + else if Queue.is_empty flow.bufs then + Lwt_condition.wait flow.cond >|= function + | `Eof -> Ok `Eof + | `Data -> Ok (`Data (Queue.pop flow.bufs)) + else + Lwt.return (Ok (`Data (Queue.pop flow.bufs))) + + let close flow = + flow.closed <- true; + Lwt.cancel flow.listener; + Lwt.return_unit + + let writev t bufs = + if t.closed then Lwt.return (Error `Closed) + else Net.writev t.netif bufs >|= function + | Ok () -> Ok () + | Error e -> Error (`Net e) + + let write t buf = + if t.closed then Lwt.return (Error `Closed) + else Net.write t.netif buf >|= function + | Ok () -> Ok () + | Error e -> Error (`Net e) + +end + +(* FIXME: this code is way too much complex *) +module HTTP (Net: Mirage_net_lwt.S) = struct + module Flow = Raw(Net) + module Channel = Mirage_channel_lwt.Make(Flow) + (* FIXME: copy/pasted from mirage-http to avoid the dependency chain: + mirage-http -> mirage-conduit -> nocrypto -> gmp -> .so needed *) + module HTTP_IO = struct + type 'a t = 'a Lwt.t + type ic = Channel.t + type oc = Channel.t + type conn = Channel.flow + let failf fmt = Fmt.kstrf Lwt.fail_with fmt + let read_line ic = + Channel.read_line ic >>= function + | Ok (`Data []) -> Lwt.return_none + | Ok `Eof -> Lwt.return_none + | Ok (`Data bufs) -> Lwt.return (Some (Cstruct.copyv bufs)) + | Error e -> failf "Flow error: %a" Channel.pp_error e + let read ic len = + Channel.read_some ~len ic >>= function + | Ok (`Data buf) -> Lwt.return (Cstruct.to_string buf) + | Ok `Eof -> Lwt.return "" + | Error e -> failf "Flow error: %a" Channel.pp_error e + let write oc buf = + Channel.write_string oc buf 0 (String.length buf); + Channel.flush oc >>= function + | Ok () -> Lwt.return_unit + | Error `Closed -> Lwt.fail_with "Trying to write on closed channel" + | Error e -> failf "Flow error: %a" Channel.pp_write_error e + let flush _ = Lwt.return_unit + let (>>= ) = Lwt.( >>= ) + let return = Lwt.return + end + module Net_IO = struct + module IO = HTTP_IO + type ctx = Net.t option + let default_ctx = None + let sexp_of_ctx _ = Sexplib.Sexp.Atom "netif" + let connect_uri ~ctx _uri = + match ctx with + | None -> Lwt.fail_with "No context" + | Some ctx -> + Flow.connect ctx >|= fun flow -> + let ch = Channel.create flow in + flow, ch, ch + let close_in _ic = () + let close_out _oc = () + let close ic _oc = Lwt.ignore_result (Channel.close ic) + end + include Cohttp_lwt.Make_client(HTTP_IO)(Net_IO) +end + +module API (Store: Mirage_net_lwt.S) = struct + + module HTTP = HTTP(Store) + + let http_post t uri ~body = + HTTP.post ~ctx:(Some t) ~body:(`String body) uri >|= fun (response, _) -> + (* FIXME check that response is ok *) + Log.info + (fun l -> l "POST %a: %a" Uri.pp_hum uri Cohttp.Response.pp_hum response) + + let set_ip t ip = + http_post t (Uri.of_string "/ip") ~body:(Ipaddr.V4.to_string ip) + +end + + +module Main + (Time :Mirage_time_lwt.S) + (Net : Mirage_net_lwt.S) + (Store: Mirage_net_lwt.S) = +struct + + module API = API(Store) + module Dhcp_client = Dhcp_client_mirage.Make(Time)(Net) + + let start () net store = + let requests = match Key_gen.codes () with + | [] -> default_options + | l -> + List.fold_left (fun acc c -> match parse_option_code c with + | Ok x -> x :: acc + | Error e -> + Log.err (fun l -> l "error: %s" e); + acc + ) [] l + in + Dhcp_client.connect ~requests net >>= fun stream -> + Lwt_stream.last_new stream >>= fun result -> + let result = of_ipv4_config result in + Log.info (fun l -> l "found lease: %a" pp result); + API.set_ip store result.address + +end diff --git a/base/dhcp-client/init-dev.sh b/base/dhcp-client/init-dev.sh new file mode 100644 index 000000000..079892bb9 --- /dev/null +++ b/base/dhcp-client/init-dev.sh @@ -0,0 +1,5 @@ +#!/bin/sh + +set -eu + +opam config exec -- /bin/sh diff --git a/base/dhcp-client/src/.merlin b/base/dhcp-client/src/.merlin new file mode 100644 index 000000000..559e0c1b7 --- /dev/null +++ b/base/dhcp-client/src/.merlin @@ -0,0 +1,4 @@ +PKG mirage-net-unix logs-syslog.lwt irmin-unix webmachine cmdliner decompress +PKG rawlink +S . +B _build/ \ No newline at end of file diff --git a/base/dhcp-client/src/_tags b/base/dhcp-client/src/_tags new file mode 100644 index 000000000..92f097bf8 --- /dev/null +++ b/base/dhcp-client/src/_tags @@ -0,0 +1,6 @@ +true: bin_annot, debug, strict_sequence +true: warn_error(+1..49+60), warn(A-4-41-44-7) +true: thread +true: package(mirage-net-unix,logs-syslog.lwt,threads,cohttp.lwt) +true: package(cmdliner,fmt.cli,logs.fmt,logs.cli,fmt.tty,decompress) +true: package(irmin,irmin-git,irmin-http,lwt.unix,rawlink) diff --git a/base/dhcp-client/src/inflator.ml b/base/dhcp-client/src/inflator.ml new file mode 100644 index 000000000..4554f32a4 --- /dev/null +++ b/base/dhcp-client/src/inflator.ml @@ -0,0 +1,47 @@ +(* https://github.com/Engil/Canopy/blob/3b5573ad0be0fa729b6d4e1ca8b9bb348e164960/inflator.ml *) + +let input_buffer = Bytes.create 0xFFFF +let output_buffer = Bytes.create 0xFFFF +let window = Decompress.Window.create ~proof:Decompress.B.proof_bytes + +let deflate ?(level = 4) buff = + let pos = ref 0 in + let res = Buffer.create (Cstruct.len buff) in + Decompress.Deflate.bytes input_buffer output_buffer + (fun input_buffer -> function + | Some _ -> + let n = min 0xFFFF (Cstruct.len buff - !pos) in + Cstruct.blit_to_bytes buff !pos input_buffer 0 n; + pos := !pos + n; + n + | None -> + let n = min 0xFFFF (Cstruct.len buff - !pos) in + Cstruct.blit_to_bytes buff !pos input_buffer 0 n; + pos := !pos + n; + n) + (fun output_buffer len -> + Buffer.add_subbytes res output_buffer 0 len; + 0xFFFF) + (Decompress.Deflate.default ~proof:Decompress.B.proof_bytes level) + |> function + | Ok _ -> Cstruct.of_string (Buffer.contents res) + | Error _ -> failwith "Deflate.deflate" + +let inflate ?output_size orig = + let res = Buffer.create (match output_size with + | Some len -> len + | None -> Mstruct.length orig) + in + Decompress.Inflate.bytes input_buffer output_buffer + (fun input_buffer -> + let n = min 0xFFFF (Mstruct.length orig) in + let s = Mstruct.get_string orig n in + Bytes.blit_string s 0 input_buffer 0 n; + n) + (fun output_buffer len -> + Buffer.add_subbytes res output_buffer 0 len; + 0xFFFF) + (Decompress.Inflate.default (Decompress.Window.reset window)) + |> function + | Ok _ -> Some (Mstruct.of_string (Buffer.contents res)) + | Error _ -> None diff --git a/base/dhcp-client/src/io_fs.ml b/base/dhcp-client/src/io_fs.ml new file mode 100644 index 000000000..6e2ac43c0 --- /dev/null +++ b/base/dhcp-client/src/io_fs.ml @@ -0,0 +1,325 @@ +(* from irmin-unix, to avoid linking with gmp ... *) + +module Log = struct + let src = Logs.Src.create "git.unix" ~doc:"logs git's unix events" + include (val Logs.src_log src : Logs.LOG) +end + +open Lwt.Infix + +let mkdir_pool = Lwt_pool.create 1 (fun () -> Lwt.return_unit) + +let protect_unix_exn = function + | Unix.Unix_error _ as e -> Lwt.fail (Failure (Printexc.to_string e)) + | e -> Lwt.fail e + +let ignore_enoent = function + | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_unit + | e -> Lwt.fail e + +let protect f x = Lwt.catch (fun () -> f x) protect_unix_exn +let safe f x = Lwt.catch (fun () -> f x) ignore_enoent + +let mkdir dirname = + let rec aux dir = + if Sys.file_exists dir && Sys.is_directory dir then Lwt.return_unit + else ( + let clear = + if Sys.file_exists dir then ( + Log.debug (fun l -> + l "%s already exists but is a file, removing." dir); + safe Lwt_unix.unlink dir + ) else + Lwt.return_unit + in + clear >>= fun () -> + aux (Filename.dirname dir) >>= fun () -> + Log.debug (fun l -> l "mkdir %s" dir); + protect (Lwt_unix.mkdir dir) 0o755; + ) in + Lwt_pool.use mkdir_pool (fun () -> aux dirname) + +let file_exists f = + Lwt.catch (fun () -> Lwt_unix.file_exists f) (function + (* See https://github.com/ocsigen/lwt/issues/316 *) + | Unix.Unix_error (Unix.ENOTDIR, _, _) -> Lwt.return_false + | e -> Lwt.fail e) + +module Lock = struct + + let is_stale max_age file = + file_exists file >>= fun exists -> + if exists then ( + Lwt.catch (fun () -> + Lwt_unix.stat file >>= fun s -> + let stale = Unix.gettimeofday () -. s.Unix.st_mtime > max_age in + Lwt.return stale) + (function + | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return false + | e -> Lwt.fail e) + ) else + Lwt.return false + + let unlock file = + Lwt_unix.unlink file + + let lock ?(max_age = 10. *. 60. (* 10 minutes *)) ?(sleep = 0.001) file = + let rec aux i = + Log.debug (fun f -> f "lock %s %d" file i); + is_stale max_age file >>= fun is_stale -> + if is_stale then ( + Log.err (fun f -> f "%s is stale, removing it." file); + unlock file >>= fun () -> + aux 1 + ) else + let create () = + let pid = Unix.getpid () in + mkdir (Filename.dirname file) >>= fun () -> + Lwt_unix.openfile file [Unix.O_CREAT; Unix.O_RDWR; Unix.O_EXCL] 0o600 + >>= fun fd -> + let oc = Lwt_io.of_fd ~mode:Lwt_io.Output fd in + Lwt_io.write_int oc pid >>= fun () -> + Lwt_unix.close fd + in + Lwt.catch create (function + | Unix.Unix_error(Unix.EEXIST, _, _) -> + let backoff = 1. +. Random.float (let i = float i in i *. i) in + Lwt_unix.sleep (sleep *. backoff) >>= fun () -> + aux (i+1) + | e -> Lwt.fail e) + in + aux 1 + + let with_lock file fn = + match file with + | None -> fn () + | Some f -> lock f >>= fun () -> Lwt.finalize fn (fun () -> unlock f) + +end + +let mmap_threshold = 4096 +let openfile_pool = Lwt_pool.create 200 (fun () -> Lwt.return_unit) + +let mkdir = mkdir + +type path = string + +(* we use file locking *) +type lock = path +let lock_file x = x + +let file_exists = file_exists + +let list_files kind dir = + if Sys.file_exists dir && Sys.is_directory dir then + let d = Sys.readdir dir in + let d = Array.to_list d in + let d = List.map (Filename.concat dir) d in + let d = List.filter kind d in + let d = List.sort String.compare d in + Lwt.return d + else + Lwt.return_nil + +let directories dir = + list_files (fun f -> + try Sys.is_directory f with Sys_error _ -> false + ) dir + +let files dir = + list_files (fun f -> + try not (Sys.is_directory f) with Sys_error _ -> false + ) dir + +let write_cstruct fd b = + let rec rwrite fd buf ofs len = + Lwt_bytes.write fd buf ofs len >>= fun n -> + if len = 0 then Lwt.fail End_of_file + else if n < len then rwrite fd buf (ofs + n) (len - n) + else Lwt.return_unit in + match Cstruct.len b with + | 0 -> Lwt.return_unit + | len -> rwrite fd (Cstruct.to_bigarray b) 0 len + +let delays = Array.init 20 (fun i -> 0.1 *. (float i) ** 2.) + +let command fmt = + Printf.ksprintf (fun str -> + Log.debug (fun l -> l "[exec] %s" str); + let i = Sys.command str in + if i <> 0 then Log.debug (fun l -> l "[exec] error %d" i); + Lwt.return_unit + ) fmt + +let remove_dir dir = + if Sys.os_type = "Win32" then + command "cmd /d /v:off /c rd /s /q %S" dir + else + command "rm -rf %S" dir + +let remove_file ?lock file = + Lock.with_lock lock (fun () -> + Lwt.catch + (fun () -> Lwt_unix.unlink file) + (function + (* On Windows, [EACCES] can also occur in an attempt to + rename a file or directory or to remove an existing + directory. *) + | Unix.Unix_error (Unix.EACCES, _, _) + | Unix.Unix_error (Unix.EISDIR, _, _) -> remove_dir file + | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_unit + | e -> Lwt.fail e) + ) + +let rename = + if Sys.os_type <> "Win32" then Lwt_unix.rename + else + fun tmp file -> + let rec aux i = + Lwt.catch + (fun () -> Lwt_unix.rename tmp file) + (function + (* On Windows, [EACCES] can also occur in an attempt to + rename a file or directory or to remove an existing + directory. *) + | Unix.Unix_error (Unix.EACCES, _, _) as e -> + if i >= Array.length delays then Lwt.fail e + else ( + file_exists file >>= fun exists -> + if exists && Sys.is_directory file then ( + remove_dir file >>= fun () -> aux (i+1) + ) else ( + Log.debug (fun l -> + l "Got EACCES, retrying in %.1fs" delays.(i)); + Lwt_unix.sleep delays.(i) >>= fun () -> aux (i+1) + )) + | e -> Lwt.fail e) + in + aux 0 + +let with_write_file ?temp_dir file fn = + begin match temp_dir with + | None -> Lwt.return_unit + | Some d -> mkdir d + end >>= fun () -> + let dir = Filename.dirname file in + mkdir dir >>= fun () -> + let tmp = Filename.temp_file ?temp_dir (Filename.basename file) "write" in + Lwt_pool.use openfile_pool (fun () -> + Log.debug (fun l -> l "Writing %s (%s)" file tmp); + Lwt_unix.(openfile tmp [O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC] 0o644) + >>= fun fd -> + Lwt.finalize (fun () -> protect fn fd) (fun () -> Lwt_unix.close fd) + >>= fun () -> + rename tmp file + ) + +let read_file_with_read file size = + let chunk_size = max 4096 (min size 0x100000) in + let buf = Cstruct.create size in + let flags = [Unix.O_RDONLY] in + let perm = 0o0 in + Lwt_unix.openfile file flags perm >>= fun fd -> + let rec aux off = + let read_size = min chunk_size (size - off) in + Lwt_bytes.read fd buf.Cstruct.buffer off read_size >>= fun read -> + (* It should test for read = 0 in case size is larger than the + real size of the file. This may happen for instance if the + file was truncated while reading. *) + let off = off + read in + if off >= size then + Lwt.return buf + else + aux off + in + Lwt.finalize (fun () -> aux 0) + (fun () -> Lwt_unix.close fd) + +let read_file_with_mmap file = + let fd = Unix.(openfile file [O_RDONLY; O_NONBLOCK] 0o644) in + let ba = Lwt_bytes.map_file ~fd ~shared:false () in + Unix.close fd; + Lwt.return (Cstruct.of_bigarray ba) + +let read_file file = + Lwt.catch (fun () -> + Lwt_pool.use openfile_pool (fun () -> + Log.debug (fun l -> l "Reading %s" file); + Lwt_unix.stat file >>= fun stats -> + let size = stats.Lwt_unix.st_size in + (if size >= mmap_threshold then read_file_with_mmap file + else read_file_with_read file size + ) >|= fun buf -> + Some buf + ) + ) (function + | Unix.Unix_error _ | Sys_error _ -> Lwt.return_none + | e -> Lwt.fail e) + +let stat_info_unsafe path = + let open Git.Index in + let stats = Unix.stat path in + let ctime = { lsb32 = Int32.of_float stats.Unix.st_ctime; nsec = 0l } in + let mtime = { lsb32 = Int32.of_float stats.Unix.st_mtime; nsec = 0l } in + let dev = Int32.of_int stats.Unix.st_dev in + let inode = Int32.of_int stats.Unix.st_ino in + let mode = match stats.Unix.st_kind, stats.Unix.st_perm with + | Unix.S_REG, p -> if p land 0o100 = 0o100 then `Exec else `Normal + | Unix.S_LNK, _ -> `Link + | k, p -> + let kind = match k with + | Unix.S_REG -> "REG" + | Unix.S_DIR -> "DIR" + | Unix.S_CHR -> "CHR" + | Unix.S_BLK -> "BLK" + | Unix.S_LNK -> "LNK" + | Unix.S_FIFO -> "FIFO" + | Unix.S_SOCK -> "SOCK" + in + let perm = Printf.sprintf "%o" p in + let error = + Printf.sprintf "%s: not supported kind of file [%s, %s]." + path kind perm + in + failwith error + in + let uid = Int32.of_int stats.Unix.st_uid in + let gid = Int32.of_int stats.Unix.st_gid in + let size = Int32.of_int stats.Unix.st_size in + { ctime; mtime; dev; inode; uid; gid; mode; size } + +let stat_info path = + Lwt.catch (fun () -> Lwt.return (Some (stat_info_unsafe path))) (function + | Sys_error _ | Unix.Unix_error _ -> Lwt.return_none + | e -> Lwt.fail e) + +let chmod ?lock f `Exec = + Lock.with_lock lock (fun () -> Lwt_unix.chmod f 0o755) + +let write_file ?temp_dir ?lock file b = + let write () = + with_write_file file ?temp_dir (fun fd -> write_cstruct fd b) + in + Lock.with_lock lock (fun () -> + Lwt.catch write (function + | Unix.Unix_error (Unix.EISDIR, _, _) -> remove_dir file >>= write + | e -> Lwt.fail e + ) + ) + +let test_and_set_file ?temp_dir ~lock file ~test ~set = + Lock.with_lock (Some lock) (fun () -> + read_file file >>= fun v -> + let equal = match test, v with + | None , None -> true + | Some x, Some y -> Cstruct.equal x y + | _ -> false + in + if not equal then Lwt.return false + else + (match set with + | None -> remove_file file + | Some v -> write_file ?temp_dir file v) + >|= fun () -> + true + ) diff --git a/base/dhcp-client/src/main.ml b/base/dhcp-client/src/main.ml new file mode 100644 index 000000000..7a42a144a --- /dev/null +++ b/base/dhcp-client/src/main.ml @@ -0,0 +1,392 @@ +open Lwt.Infix + +let src = Logs.Src.create "dhcp-client" ~doc:"DHCP client" +module Log = (val Logs.src_log src : Logs.LOG) + +let failf fmt = Fmt.kstrf Lwt.fail_with fmt + +type fd = { + name: string; + fd : Lwt_unix.file_descr; +} + +let stdout = { name = "stdout"; fd = Lwt_unix.stdout } +let stderr = { name = "stderr"; fd = Lwt_unix.stderr } +let stdin = { name = "stdin" ; fd = Lwt_unix.stdin } + +let int_of_fd (fd:Lwt_unix.file_descr) = + (Obj.magic (Lwt_unix.unix_file_descr fd): int) + +let pp_fd ppf fd = Fmt.pf ppf "%s:%d" fd.name (int_of_fd fd.fd) + +let close fd = + Log.debug (fun l -> l "close %a" pp_fd fd); + Lwt_unix.close fd.fd + +let dev_null = + Lwt_unix.of_unix_file_descr ~blocking:false + (Unix.openfile "/dev/null" [Unix.O_RDWR] 0) + +let close_and_dup fd = + Log.debug (fun l -> l "close-and-dup %a" pp_fd fd); + Lwt_unix.close fd.fd >>= fun () -> + Lwt_unix.dup2 dev_null fd.fd; + Lwt_unix.close dev_null + +let dup2 ~src ~dst = + Log.debug (fun l -> l "dup2 %a => %a" pp_fd src pp_fd dst); + Lwt_unix.dup2 src.fd dst.fd; + close src + +let proxy_rawlink ~rawlink ~fd = + Log.debug (fun l -> l "proxy-netif tap0 <=> %a" pp_fd fd); + let rec listen_rawlink () = + Lwt_rawlink.read_packet rawlink >>= fun buf -> + Log.debug (fun l -> l "PROXY-NETIF: => %a" Cstruct.hexdump_pp buf); + Log.debug (fun l -> l "PROXY-NETIF: => %S" (Cstruct.to_string buf)); + let rec write buf = + Lwt_cstruct.write fd.fd buf >>= function + | 0 -> Lwt.return_unit + | n -> write (Cstruct.shift buf n) + in + write buf >>= fun () -> + listen_rawlink () + in + let listen_socket () = + let len = 16 * 1024 in + let buf = Cstruct.create len in + let rec loop () = + Lwt_cstruct.read fd.fd buf >>= fun len -> + let buf = Cstruct.sub buf 0 len in + Log.debug (fun l -> l "PROXY-NETIF: <= %a" Cstruct.hexdump_pp buf); + Lwt_rawlink.send_packet rawlink buf >>= fun () -> + loop () + in + loop () + in + Lwt.pick [ + listen_rawlink (); + listen_socket (); + ] + +let rec really_write dst buf off len = + match len with + | 0 -> Lwt.return_unit + | len -> + Lwt_unix.write dst.fd buf off len >>= fun n -> + really_write dst buf (off+n) (len-n) + +let forward ~src ~dst = + Log.debug (fun l -> l "forward %a => %a" pp_fd src pp_fd dst); + let len = 16 * 1024 in + let buf = Bytes.create len in + let rec loop () = + Lwt_unix.read src.fd buf 0 len >>= fun len -> + if len = 0 then + (* FIXME: why this ever happen *) + Fmt.kstrf Lwt.fail_with "FORWARD[%a => %a]: EOF" pp_fd src pp_fd dst + else ( + Log.debug (fun l -> + l "FORWARD[%a => %a]: %S (%d)" + pp_fd src pp_fd dst (Bytes.sub buf 0 len) len); + really_write dst buf 0 len >>= fun () -> + loop () + ) + in + loop () + +let proxy x y = + Lwt.pick [ + forward ~src:x ~dst:y; + forward ~src:y ~dst:x; + ] + +(* Prepare the fd space before we fork to run the calf *) + +let socketpair name = + let priv, calf = Lwt_unix.(socketpair PF_UNIX SOCK_STREAM 0) in + Lwt_unix.clear_close_on_exec priv; + Lwt_unix.clear_close_on_exec calf; + { name = name; fd = priv }, { name = name ^ "-calf"; fd = calf } + +let pipe name = + let priv, calf = Lwt_unix.pipe () in + Lwt_unix.clear_close_on_exec priv; + Lwt_unix.clear_close_on_exec calf; + { name = name; fd = priv }, { name = name ^ "-calf"; fd = calf } + +(* logs pipe *) +let logs_out = pipe "logs-out" +let logs_err = pipe "logs-err" + +(* store pipe *) +let store = socketpair "store" + +(* network pipe *) +let net = socketpair "net" + +(* metrics pipe *) +(* let metrics = make "metrics" *) + +let child cmd = + close_and_dup stdin >>= fun () -> + + (* close parent fds *) + close (fst logs_out) >>= fun () -> + close (fst logs_err) >>= fun () -> + close (fst store) >>= fun () -> + close (fst net) >>= fun () -> + (* + close (fst metrics) >>= fun () -> + *) + + let cmds = String.concat " " cmd in + Log.info (fun l -> l "Executing %s" cmds); + Log.debug (fun l -> + l "net-fd=%a store-fd=%a" pp_fd (snd net) pp_fd (snd store)); + + dup2 ~src:(snd logs_out) ~dst:stdout >>= fun () -> + dup2 ~src:(snd logs_err) ~dst:stderr >>= fun () -> + + (* exec the calf *) + Unix.execve (List.hd cmd) (Array.of_list cmd) [||] + +module Store = struct + + (* FIXME: to avoid linking with gmp *) + module IO = struct + type ic = unit + type oc = unit + type ctx = unit + let with_connection ?ctx:_ _uri ?init:_ _f = Lwt.fail_with "not allowed" + let read_all _ic = Lwt.fail_with "not allowed" + let read_exactly _ic _n = Lwt.fail_with "not allowed" + let write _oc _buf = Lwt.fail_with "not allowed" + let flush _oc = Lwt.fail_with "not allowed" + let ctx () = Lwt.return_none + end + + (* FIXME: we don't use Irmin_unix.Git.FS.KV to avoid linking with gmp *) + module Store = Irmin_git.FS.KV(IO)(Inflator)(Io_fs) + module KV = Store(Irmin.Contents.String) + + let client () = + let config = Irmin_git.config "/data/git" in + KV.Repo.v config >>= fun repo -> + KV.of_branch repo "calf" + + module HTTP = struct + + module Wm = struct + module Rd = Webmachine.Rd + include Webmachine.Make(Cohttp_lwt_unix.Server.IO) + end + + let with_key rd f = + match KV.Key.of_string rd.Wm.Rd.dispatch_path with + | Ok x -> f x + | Error _ -> Wm.respond 404 rd + + let infof fmt = + Fmt.kstrf (fun msg () -> + let date = Int64.of_float (Unix.gettimeofday ()) in + Irmin.Info.v ~date ~author:"calf" msg + ) fmt + + let ok = "{\"status\": \"ok\"}" + + class item db = object(self) + + inherit [Cohttp_lwt_body.t] Wm.resource + + method private of_string rd = + Cohttp_lwt_body.to_string rd.Wm.Rd.req_body >>= fun value -> + with_key rd (fun key -> + let info = infof "Updating %a" KV.Key.pp key in + KV.set db ~info key value >>= fun () -> + let resp_body = `String ok in + let rd = { rd with Wm.Rd.resp_body } in + Wm.continue true rd + ) + + method private to_string rd = + with_key rd (fun key -> + KV.find db key >>= function + | Some value -> Wm.continue (`String value) rd + | None -> assert false + ) + + method resource_exists rd = + with_key rd (fun key -> + KV.mem db key >>= fun mem -> + Wm.continue mem rd + ) + + method allowed_methods rd = + Wm.continue [`GET; `HEAD; `PUT; `DELETE] rd + + method content_types_provided rd = + Wm.continue [ + "plain", self#to_string + ] rd + + method content_types_accepted rd = + Wm.continue [ + "plain", self#of_string + ] rd + + method delete_resource rd = + with_key rd (fun key -> + let info = infof "Deleting %a" KV.Key.pp key in + KV.remove db ~info key >>= fun () -> + let resp_body = `String ok in + Wm.continue true { rd with Wm.Rd.resp_body } + ) + end + + let v db = + let routes = [ + ("/ip" , fun () -> new item db); + ("/domain" , fun () -> new item db); + ("/search" , fun () -> new item db); + ("/mtu" , fun () -> new item db); + ("/nameserver/*", fun () -> new item db); + ] in + let callback (_ch, _conn) request body = + let open Cohttp in + (Wm.dispatch' routes ~body ~request >|= function + | None -> (`Not_found, Header.init (), `String "Not found", []) + | Some result -> result) + >>= fun (status, headers, body, path) -> + Log.info (fun l -> + l "%d - %s %s" + (Code.code_of_status status) + (Code.string_of_method (Request.meth request)) + (Uri.path (Request.uri request))); + Log.debug (fun l -> l "path=%a" Fmt.(Dump.list string) path); + (* Finally, send the response to the client *) + Cohttp_lwt_unix.Server.respond ~headers ~body ~status () + in + (* create the server and handle requests with the function defined above *) + let conn_closed (_, conn) = + Log.info (fun l -> + l "connection %s closed\n%!" (Cohttp.Connection.to_string conn)) + in + Cohttp_lwt_unix.Server.make ~callback ~conn_closed () + + end + + let start () = + client () >>= fun db -> + let http = HTTP.v db in + let fd = fst store in + Log.info (fun l -> l "serving KV store on %a" pp_fd fd); + Cohttp_lwt_unix.Server.create ~mode:(`Fd fd.fd) http + +end + +let rawlink () = + (* FIXME: enable DHCP filtering via eBPF *) + Lwt_rawlink.open_link (* ~filter:(Rawlink.dhcp_filter ())*) "eth0" + +let check_exit_status cmd status = + let cmds = String.concat " " cmd in + match status with + | Unix.WEXITED 0 -> Lwt.return_unit + | Unix.WEXITED i -> failf "%s: exit %d" cmds i + | Unix.WSIGNALED i -> failf "%s: signal %d" cmds i + | Unix.WSTOPPED i -> failf "%s: stopped %d" cmds i + +let parent cmd pid = + (* network traffic *) + let rawlink = rawlink () in + + (* close child fds *) + close_and_dup stdin >>= fun () -> + close (snd logs_out) >>= fun () -> + close (snd logs_err) >>= fun () -> + close (snd net) >>= fun () -> + close (snd store) >>= fun () -> + (* + close (snd metrics) >>= fun () -> + *) + let wait () = + Lwt_unix.waitpid [] pid >>= fun (_pid, w) -> + Lwt_io.flush_all () >>= fun () -> + + check_exit_status cmd w + in + Lwt.pick [ + wait (); + (* data *) + proxy_rawlink ~rawlink ~fd:(fst net); + + (* redirect the calf stdout to the shim stdout *) + forward ~src:(fst logs_out) ~dst:stdout; + forward ~src:(fst logs_err) ~dst:stderr; + (* metrics: TODO *) + (* store: TODO *) + ] + +let run () cmd = + Lwt_main.run ( + Lwt_io.flush_all () >>= fun () -> + match Lwt_unix.fork () with + | 0 -> child cmd + | pid -> parent cmd pid + ) + +(* CLI *) + +open Cmdliner + +let setup_log style_renderer level = + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + let pp_header ppf x = + Fmt.pf ppf "%5d: %a " (Unix.getpid ()) Logs_fmt.pp_header x + in + Logs.set_reporter (Logs_fmt.reporter ~pp_header ()); + () + +let setup_log = + Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) + +let cmd = + (* FIXME: use runc isolation + let default_cmd = [ + "/usr/bin/runc"; "--"; "run"; + "--bundle"; "/containers/images/000-dhcp-client"; + "dhcp-client" + ] in + *) + let default_cmd = [ + "/dhcp-client-calf"; "--store=10"; "--net=12" + ] in + let doc = + Arg.info ~docv:"CMD" ~doc:"Command to run the calf process." ["cmd"] + in + Arg.(value & opt (list ~sep:' ' string) default_cmd & doc) + +let run = + Term.(const run $ setup_log $ cmd), + Term.info "dhcp-client" ~version:"0.0" + +let () = match Term.eval run with + | `Error _ -> exit 1 + | _ -> exit 0 + +(* + +let kv_store = Unix.pipe () + +let install_logger () = + Logs_syslog_lwt.udp_reporter (Unix.inet_addr_of_string "127.0.0.1") () + >|= fun r -> + Logs.set_reporter r + +let () = Lwt_main.run ( + install_logger () >>= fun () -> + fd_of_tap0 >>= fun fd -> + ) +*) From 82db231f8260495578b17ae5ac2ae3eab37705e9 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Thu, 16 Mar 2017 18:53:34 +0100 Subject: [PATCH 4/6] Use the new DHCP client container in moby.yaml Signed-off-by: Thomas Gazagnaire --- moby.yaml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/moby.yaml b/moby.yaml index 971539382..1b1830323 100644 --- a/moby.yaml +++ b/moby.yaml @@ -17,6 +17,13 @@ system: - /proc/sys/fs/binfmt_misc:/binfmt_misc read_only: true command: [/usr/bin/binfmt, -dir, /etc/binfmt.d/, -mount, /binfmt_misc] + - name: dhcp-client + network_mode: host + image: "mobylinux/dhcp-client:dc3fd177a588ca9a850cfc75dd9083fb26d278dc" + capabilities: + - CAP_NET_RAW + command: [/dhcp-client] + read_only: true daemon: - name: rngd image: "mobylinux/rngd:3dad6dd43270fa632ac031e99d1947f20b22eec9@sha256:1c93c1db7196f6f71f8e300bc1d15f0376dd18e8891c8789d77c8ff19f3a9a92" From 0a2cf858d8f70a925bc6f71268f195ef7dff8c8e Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Thu, 16 Mar 2017 19:05:35 +0100 Subject: [PATCH 5/6] dhcp-client: add a very basic roadmap Signed-off-by: Thomas Gazagnaire --- base/dhcp-client/ROADMAP.md | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 base/dhcp-client/ROADMAP.md diff --git a/base/dhcp-client/ROADMAP.md b/base/dhcp-client/ROADMAP.md new file mode 100644 index 000000000..fd0e1ba1f --- /dev/null +++ b/base/dhcp-client/ROADMAP.md @@ -0,0 +1,22 @@ +## Roadmap + +Very basic roadmap, to be improved shortly. + +### Done + +- use 2 static binaries privileged + unikernel (calf) in the container, + connected via socketpairs and pipes. +- use eBPF to filter DHCP traffic +- redirect the calf's sterr/stdout to the priv container +- the priv exposes a simple HTTP interface to the calf, and read/write + are stored into a local Datakit/Git repo. +- use upstream MirageOS's charrua-core. + +### TODO + +- current: make the packets flow in both directions +- use runc to isolate the calf +- use seccomp to isolate the privileged container +- use the DHCP results to actually update the system +- add metrics aggregation (using prometheus) +- better logging aggregation (using syslog) From 30be4647ad5326bdb77f02c0091411775c1e5fb9 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 17 Mar 2017 17:39:57 +0100 Subject: [PATCH 6/6] Restructure the mirage/dhcp container into the new project structure Signed-off-by: Thomas Gazagnaire --- base/dhcp-client/ROADMAP.md | 22 -------- moby.yaml | 7 --- .../miragesdk/README.md | 29 ++++++++--- .../miragesdk}/dhcp-client/.gitignore | 0 .../miragesdk}/dhcp-client/Dockerfile.build | 0 .../miragesdk}/dhcp-client/Dockerfile.dev | 0 .../miragesdk}/dhcp-client/Dockerfile.pkg | 0 .../miragesdk}/dhcp-client/Makefile | 0 .../miragesdk}/dhcp-client/README.md | 0 .../miragesdk}/dhcp-client/calf/.merlin | 0 .../miragesdk}/dhcp-client/calf/config.ml | 0 .../miragesdk}/dhcp-client/calf/unikernel.ml | 0 .../miragesdk}/dhcp-client/init-dev.sh | 0 .../miragesdk}/dhcp-client/src/.merlin | 0 .../miragesdk}/dhcp-client/src/_tags | 0 .../miragesdk}/dhcp-client/src/inflator.ml | 0 .../miragesdk}/dhcp-client/src/io_fs.ml | 0 .../miragesdk}/dhcp-client/src/main.ml | 0 projects/miragesdk/examples/mirage-dhcp.yaml | 50 +++++++++++++++++++ .../miragesdk}/mirage-compile/.gitignore | 0 .../miragesdk}/mirage-compile/Dockerfile | 0 .../miragesdk}/mirage-compile/Makefile | 0 .../miragesdk}/mirage-compile/compile.sh | 0 23 files changed, 73 insertions(+), 35 deletions(-) delete mode 100644 base/dhcp-client/ROADMAP.md rename docs/unikernels.md => projects/miragesdk/README.md (84%) rename {base => projects/miragesdk}/dhcp-client/.gitignore (100%) rename {base => projects/miragesdk}/dhcp-client/Dockerfile.build (100%) rename {base => projects/miragesdk}/dhcp-client/Dockerfile.dev (100%) rename {base => projects/miragesdk}/dhcp-client/Dockerfile.pkg (100%) rename {base => projects/miragesdk}/dhcp-client/Makefile (100%) rename {base => projects/miragesdk}/dhcp-client/README.md (100%) rename {base => projects/miragesdk}/dhcp-client/calf/.merlin (100%) rename {base => projects/miragesdk}/dhcp-client/calf/config.ml (100%) rename {base => projects/miragesdk}/dhcp-client/calf/unikernel.ml (100%) rename {base => projects/miragesdk}/dhcp-client/init-dev.sh (100%) rename {base => projects/miragesdk}/dhcp-client/src/.merlin (100%) rename {base => projects/miragesdk}/dhcp-client/src/_tags (100%) rename {base => projects/miragesdk}/dhcp-client/src/inflator.ml (100%) rename {base => projects/miragesdk}/dhcp-client/src/io_fs.ml (100%) rename {base => projects/miragesdk}/dhcp-client/src/main.ml (100%) create mode 100644 projects/miragesdk/examples/mirage-dhcp.yaml rename {tools => projects/miragesdk}/mirage-compile/.gitignore (100%) rename {tools => projects/miragesdk}/mirage-compile/Dockerfile (100%) rename {tools => projects/miragesdk}/mirage-compile/Makefile (100%) rename {tools => projects/miragesdk}/mirage-compile/compile.sh (100%) diff --git a/base/dhcp-client/ROADMAP.md b/base/dhcp-client/ROADMAP.md deleted file mode 100644 index fd0e1ba1f..000000000 --- a/base/dhcp-client/ROADMAP.md +++ /dev/null @@ -1,22 +0,0 @@ -## Roadmap - -Very basic roadmap, to be improved shortly. - -### Done - -- use 2 static binaries privileged + unikernel (calf) in the container, - connected via socketpairs and pipes. -- use eBPF to filter DHCP traffic -- redirect the calf's sterr/stdout to the priv container -- the priv exposes a simple HTTP interface to the calf, and read/write - are stored into a local Datakit/Git repo. -- use upstream MirageOS's charrua-core. - -### TODO - -- current: make the packets flow in both directions -- use runc to isolate the calf -- use seccomp to isolate the privileged container -- use the DHCP results to actually update the system -- add metrics aggregation (using prometheus) -- better logging aggregation (using syslog) diff --git a/moby.yaml b/moby.yaml index 1b1830323..971539382 100644 --- a/moby.yaml +++ b/moby.yaml @@ -17,13 +17,6 @@ system: - /proc/sys/fs/binfmt_misc:/binfmt_misc read_only: true command: [/usr/bin/binfmt, -dir, /etc/binfmt.d/, -mount, /binfmt_misc] - - name: dhcp-client - network_mode: host - image: "mobylinux/dhcp-client:dc3fd177a588ca9a850cfc75dd9083fb26d278dc" - capabilities: - - CAP_NET_RAW - command: [/dhcp-client] - read_only: true daemon: - name: rngd image: "mobylinux/rngd:3dad6dd43270fa632ac031e99d1947f20b22eec9@sha256:1c93c1db7196f6f71f8e300bc1d15f0376dd18e8891c8789d77c8ff19f3a9a92" diff --git a/docs/unikernels.md b/projects/miragesdk/README.md similarity index 84% rename from docs/unikernels.md rename to projects/miragesdk/README.md index bf51a5985..d027e3a33 100644 --- a/docs/unikernels.md +++ b/projects/miragesdk/README.md @@ -7,7 +7,7 @@ | privileged shim | | calf | |=================| |================| | | | | - eth0 ----> | eBPF rules | <--- network IO ---> | type-safe | +<-- eth0 ---> | eBPF rules | <--- network IO ---> | type-safe | | | (data path) | network stack | | | | | |-----------------| |----------------| @@ -86,7 +86,7 @@ share it with the calf on startup). - Has access to a Mirage_net.S interface for network traffic - Has access to a a simple KV interface -Internally, it might use something more typed than a KV store: +Internally, it uses something more typed than a KV store: ``` module Shim: sig @@ -114,8 +114,25 @@ What the SDK should enable: ### Roadmap -- first PoC -- ipv6 support -- gracefully handle expiration +#### first PoC: DHCP client + +Current status: one container containing two static binaries (priv + calf), +private pipes open between the process for stdout/stderr aggregation + +raw sockets (data path). Control path is using a simple HTTP server running +in the priv container. The calf is using the dev version of mirage/charrua-core, +and is able to get a DHCP lease on boot. + +##### TODO + +- use runc to isolate the calf +- eBPF filtering +- use seccomp to isolate the privileged container +- use the DHCP results to actually update the system +- add metrics aggregation (using prometheus) +- better logging aggregation (using syslog) +- IPv6 support - tests, tests, tests (especially against non compliant RFC servers) -- second iteration: NTP \ No newline at end of file + +### Second iteration: NTP + +TODO \ No newline at end of file diff --git a/base/dhcp-client/.gitignore b/projects/miragesdk/dhcp-client/.gitignore similarity index 100% rename from base/dhcp-client/.gitignore rename to projects/miragesdk/dhcp-client/.gitignore diff --git a/base/dhcp-client/Dockerfile.build b/projects/miragesdk/dhcp-client/Dockerfile.build similarity index 100% rename from base/dhcp-client/Dockerfile.build rename to projects/miragesdk/dhcp-client/Dockerfile.build diff --git a/base/dhcp-client/Dockerfile.dev b/projects/miragesdk/dhcp-client/Dockerfile.dev similarity index 100% rename from base/dhcp-client/Dockerfile.dev rename to projects/miragesdk/dhcp-client/Dockerfile.dev diff --git a/base/dhcp-client/Dockerfile.pkg b/projects/miragesdk/dhcp-client/Dockerfile.pkg similarity index 100% rename from base/dhcp-client/Dockerfile.pkg rename to projects/miragesdk/dhcp-client/Dockerfile.pkg diff --git a/base/dhcp-client/Makefile b/projects/miragesdk/dhcp-client/Makefile similarity index 100% rename from base/dhcp-client/Makefile rename to projects/miragesdk/dhcp-client/Makefile diff --git a/base/dhcp-client/README.md b/projects/miragesdk/dhcp-client/README.md similarity index 100% rename from base/dhcp-client/README.md rename to projects/miragesdk/dhcp-client/README.md diff --git a/base/dhcp-client/calf/.merlin b/projects/miragesdk/dhcp-client/calf/.merlin similarity index 100% rename from base/dhcp-client/calf/.merlin rename to projects/miragesdk/dhcp-client/calf/.merlin diff --git a/base/dhcp-client/calf/config.ml b/projects/miragesdk/dhcp-client/calf/config.ml similarity index 100% rename from base/dhcp-client/calf/config.ml rename to projects/miragesdk/dhcp-client/calf/config.ml diff --git a/base/dhcp-client/calf/unikernel.ml b/projects/miragesdk/dhcp-client/calf/unikernel.ml similarity index 100% rename from base/dhcp-client/calf/unikernel.ml rename to projects/miragesdk/dhcp-client/calf/unikernel.ml diff --git a/base/dhcp-client/init-dev.sh b/projects/miragesdk/dhcp-client/init-dev.sh similarity index 100% rename from base/dhcp-client/init-dev.sh rename to projects/miragesdk/dhcp-client/init-dev.sh diff --git a/base/dhcp-client/src/.merlin b/projects/miragesdk/dhcp-client/src/.merlin similarity index 100% rename from base/dhcp-client/src/.merlin rename to projects/miragesdk/dhcp-client/src/.merlin diff --git a/base/dhcp-client/src/_tags b/projects/miragesdk/dhcp-client/src/_tags similarity index 100% rename from base/dhcp-client/src/_tags rename to projects/miragesdk/dhcp-client/src/_tags diff --git a/base/dhcp-client/src/inflator.ml b/projects/miragesdk/dhcp-client/src/inflator.ml similarity index 100% rename from base/dhcp-client/src/inflator.ml rename to projects/miragesdk/dhcp-client/src/inflator.ml diff --git a/base/dhcp-client/src/io_fs.ml b/projects/miragesdk/dhcp-client/src/io_fs.ml similarity index 100% rename from base/dhcp-client/src/io_fs.ml rename to projects/miragesdk/dhcp-client/src/io_fs.ml diff --git a/base/dhcp-client/src/main.ml b/projects/miragesdk/dhcp-client/src/main.ml similarity index 100% rename from base/dhcp-client/src/main.ml rename to projects/miragesdk/dhcp-client/src/main.ml diff --git a/projects/miragesdk/examples/mirage-dhcp.yaml b/projects/miragesdk/examples/mirage-dhcp.yaml new file mode 100644 index 000000000..1b1830323 --- /dev/null +++ b/projects/miragesdk/examples/mirage-dhcp.yaml @@ -0,0 +1,50 @@ +kernel: + image: "mobylinux/kernel:4.9.x" + cmdline: "console=ttyS0 page_poison=1" +init: "mobylinux/init:d6d115d601e78f7909d4a2ff7eb4caa3fff65271" +system: + - name: sysctl + image: "mobylinux/sysctl:2cf2f9d5b4d314ba1bfc22b2fe931924af666d8c" + network_mode: host + pid: host + ipc: host + capabilities: + - CAP_SYS_ADMIN + read_only: true + - name: binfmt + image: "mobylinux/binfmt:bdb754f25a5d851b4f5f8d185a43dfcbb3c22d01" + binds: + - /proc/sys/fs/binfmt_misc:/binfmt_misc + read_only: true + command: [/usr/bin/binfmt, -dir, /etc/binfmt.d/, -mount, /binfmt_misc] + - name: dhcp-client + network_mode: host + image: "mobylinux/dhcp-client:dc3fd177a588ca9a850cfc75dd9083fb26d278dc" + capabilities: + - CAP_NET_RAW + command: [/dhcp-client] + read_only: true +daemon: + - name: rngd + image: "mobylinux/rngd:3dad6dd43270fa632ac031e99d1947f20b22eec9@sha256:1c93c1db7196f6f71f8e300bc1d15f0376dd18e8891c8789d77c8ff19f3a9a92" + capabilities: + - CAP_SYS_ADMIN + oom_score_adj: -800 + read_only: true + command: [/bin/tini, /usr/sbin/rngd, -f] + - name: nginx + image: "nginx:alpine" + capabilities: + - CAP_NET_BIND_SERVICE + - CAP_CHOWN + - CAP_SETUID + - CAP_SETGID + - CAP_DAC_OVERRIDE + network_mode: host +files: + - path: etc/docker/daemon.json + contents: '{"debug": true}' +outputs: + - format: kernel+initrd + - format: iso-bios + - format: iso-efi diff --git a/tools/mirage-compile/.gitignore b/projects/miragesdk/mirage-compile/.gitignore similarity index 100% rename from tools/mirage-compile/.gitignore rename to projects/miragesdk/mirage-compile/.gitignore diff --git a/tools/mirage-compile/Dockerfile b/projects/miragesdk/mirage-compile/Dockerfile similarity index 100% rename from tools/mirage-compile/Dockerfile rename to projects/miragesdk/mirage-compile/Dockerfile diff --git a/tools/mirage-compile/Makefile b/projects/miragesdk/mirage-compile/Makefile similarity index 100% rename from tools/mirage-compile/Makefile rename to projects/miragesdk/mirage-compile/Makefile diff --git a/tools/mirage-compile/compile.sh b/projects/miragesdk/mirage-compile/compile.sh similarity index 100% rename from tools/mirage-compile/compile.sh rename to projects/miragesdk/mirage-compile/compile.sh