Add an initial PoC for a DHCP client unikernel system container

Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>

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
+\#*
+.#*
+*~
+.*~

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

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"]

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"]

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:

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).

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 .

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]

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

base/dhcp-client/init-dev.sh

@@ -0,0 +1,5 @@
+#!/bin/sh
+
+set -eu
+
+opam config exec -- /bin/sh

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/

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)

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

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
+    )

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 ->
+  )
+*)