miragesdk: move files around

The new hiearchy is:
- pkg/{init,mirage-compile}: additional Moby packages
- src/sdk -> the begining of the MirageOS SDK for Moby
- src/dhcp-client -> the code for the MirageOS dhcp-client service

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

projects/miragesdk/src/.gitignore

@@ -0,0 +1,31 @@
+.build
+.pkg
+.dev
+obj/
+hash
+
+# Generated by jbuilder
+dhcp-client/bpf/.merlin
+dhcp-client/.merlin
+sdk/.merlin
+
+# Generated by `make dev`
+_build/
+main.native
+calf/dhcp_client
+src/bpf/.merlin
+
+# Generated by the mirage tool
+dhcp-client/calf/_build
+dhcp-client/calf/Makefile
+dhcp-client/calf/myocamlbuild.ml
+dhcp-client/calf/*.opam
+dhcp-client/calf/key_gen.ml
+dhcp-client/calf/main.ml
+dhcp-client/calf/.mirage.config
+
+# Trash files
+\#*
+.#*
+*~
+.*~

projects/miragesdk/src/Dockerfile.build

@@ -0,0 +1,19 @@
+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 tuntap.1.0.0 jbuilder irmin-watcher inotify
+
+RUN sudo mkdir -p /src
+COPY ./sdk /src/sdk
+COPY ./dhcp-client /src/dhcp-client
+RUN sudo chown opam -R /src
+
+USER opam
+WORKDIR /src
+
+RUN opam config exec -- jbuilder build dhcp-client/main.exe
+RUN sudo cp /src/_build/default/dhcp-client/main.exe /dhcp-client

projects/miragesdk/src/Dockerfile.dev

@@ -0,0 +1,23 @@
+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 tuntap.1.0.0 jbuilder
+
+RUN opam pin add tuntap 1.0.0
+
+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"]

projects/miragesdk/src/Dockerfile.pkg

@@ -0,0 +1,4 @@
+#FROM ocaml/opam:alpine-3.5_ocaml-4.04.0
+FROM scratch
+COPY obj ./
+CMD ["/dhcp-client"]

projects/miragesdk/src/Makefile

@@ -0,0 +1,75 @@
+BASE=ocaml/opam:alpine-3.5_ocaml-4.04.0
+FILES=$(shell find . -name jbuild) \
+	$(shell find sdk/ -regex '.*\.mli?') \
+	dhcp-client/bpf/dhcp.c dhcp-client/main.ml
+IMAGE=dhcp-client
+OBJS=obj/dhcp-client
+
+MIRAGE_COMPILE=mobylinux/mirage-compile:f903b0e1b4328271364cc63f123ac49d56739cef@sha256:a54d9ca84d3f5998dba92ce83d60d49289cee8908a8b0f6ec280d30ab8edf46c
+CALF_OBJS=obj/dhcp-client-calf
+CALF_FILES=dhcp-client/calf/config.ml dhcp-client/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
+	jbuilder build src/main.exe
+#	_build/default/src/main.exe -vv \
+#	  --cmd 'calf/_build/main.native -l debug --store 10 --net 12' \
+#	  --ethif eno1
+
+.DELETE_ON_ERROR:

projects/miragesdk/src/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).

projects/miragesdk/src/dhcp-client/bpf/dhcp.c

@@ -0,0 +1,89 @@
+/* dhcp_bpf_filter taken from bpf.c in dhcp-3.1.0
+ *
+ * Copyright (c) 2004,2007 by Internet Systems Consortium, Inc. ("ISC")
+ * Copyright (c) 1996-2003 by Internet Software Consortium
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND ISC DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS.  IN NO EVENT SHALL ISC BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
+ * OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *   Internet Systems Consortium, Inc.
+ *   950 Charter Street
+ *   Redwood City, CA 94063
+ *   <info@isc.org>
+ *   http://www.isc.org/
+ */
+
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <sys/ioctl.h>
+
+#include <net/ethernet.h>
+
+#include <linux/if_packet.h>
+#include <linux/filter.h>
+
+#include <net/if.h>
+
+#include <arpa/inet.h>
+
+#include <errno.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <fcntl.h>
+
+#include "caml/memory.h"
+#include "caml/fail.h"
+#include "caml/unixsupport.h"
+#include "caml/signals.h"
+#include "caml/alloc.h"
+#include "caml/custom.h"
+#include "caml/bigarray.h"
+
+#define BOOTPC          68
+#define BPF_WHOLEPACKET 0x0fffffff
+
+#ifndef BPF_ETHCOOK
+# define BPF_ETHCOOK 0
+#endif
+
+static const struct sock_filter bootp_bpf_filter [] = {
+  /* Make sure this is an IP packet... */
+  BPF_STMT(BPF_LD + BPF_H + BPF_ABS, 12),
+  BPF_JUMP(BPF_JMP + BPF_JEQ + BPF_K, ETHERTYPE_IP, 0, 8),
+  /* Make sure it's a UDP packet... */
+  BPF_STMT(BPF_LD + BPF_B + BPF_ABS, 23 + BPF_ETHCOOK),
+  BPF_JUMP(BPF_JMP + BPF_JEQ + BPF_K, IPPROTO_UDP, 0, 6),
+  /* Make sure this isn't a fragment... */
+  BPF_STMT(BPF_LD + BPF_H + BPF_ABS, 20 + BPF_ETHCOOK),
+  BPF_JUMP(BPF_JMP + BPF_JSET + BPF_K, 0x1fff, 4, 0),
+  /* Get the IP header length... */
+  BPF_STMT(BPF_LDX + BPF_B + BPF_MSH, 14 + BPF_ETHCOOK),
+  /* Make sure it's to the right port... */
+  BPF_STMT(BPF_LD + BPF_H + BPF_IND, 16 + BPF_ETHCOOK),
+  BPF_JUMP(BPF_JMP + BPF_JEQ + BPF_K, BOOTPC, 0, 1),
+  /* If we passed all the tests, ask for the whole packet. */
+  BPF_STMT(BPF_RET + BPF_K, BPF_WHOLEPACKET),
+  /* Otherwise, drop it. */
+  BPF_STMT(BPF_RET + BPF_K, 0),
+};
+
+/* Filters */
+CAMLprim value bpf_filter(value vunit)
+{
+  CAMLparam0();
+  CAMLlocal1(vfilter);
+  vfilter = caml_alloc_string(sizeof(bootp_bpf_filter));
+  memcpy(String_val(vfilter), bootp_bpf_filter, sizeof(bootp_bpf_filter));
+  CAMLreturn (vfilter);
+}

projects/miragesdk/src/dhcp-client/bpf/jbuild

@@ -0,0 +1,6 @@
+(jbuild_version 1)
+
+(library
+ ((name            bpf_dhcp)
+  (c_names         (dhcp))
+))

projects/miragesdk/src/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 .

projects/miragesdk/src/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 ctl =
+  let doc =
+    Key.Arg.info ~docv:"FD" ~doc:"Control interface" ["ctl"]
+  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 $ ctl]

projects/miragesdk/src/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)
+    (Ctl  : Mirage_net_lwt.S) =
+struct
+
+  module API = API(Ctl)
+  module Dhcp_client = Dhcp_client_mirage.Make(Time)(Net)
+
+  let start () net ctl =
+    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 ctl result.address
+
+end

projects/miragesdk/src/dhcp-client/jbuild

@@ -0,0 +1,7 @@
+(jbuild_version 1)
+
+(executables
+ ((names (main))
+  (libraries (sdk bpf_dhcp))
+  (flags (-cclib -static))
+ ))

projects/miragesdk/src/dhcp-client/main.ml

@@ -0,0 +1,114 @@
+open Lwt.Infix
+open Sdk
+
+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
+
+
+module Handlers = struct
+
+  (* System handlers *)
+
+  let contents_of_diff = function
+    | `Added (_, `Contents (v, _))
+    | `Updated (_, (_, `Contents (v, _))) -> Some v
+    | _ -> None
+
+  let ip t =
+    Ctl.KV.watch_key t ["ip"] (fun diff ->
+        match contents_of_diff diff with
+        | Some ip ->
+          Log.info (fun l -> l "SET IP to %s" ip);
+          Lwt.return ()
+        | _ ->
+          Lwt.return ()
+      )
+
+  let handlers = [
+    ip;
+  ]
+
+  let watch path =
+    Ctl.v path >>= fun db ->
+    Lwt_list.map_p (fun f -> f db) handlers >>= fun _ ->
+    let t, _ = Lwt.task () in
+    t
+
+end
+
+external bpf_filter: unit -> string = "bpf_filter"
+
+let run () cmd ethif path =
+  Lwt_main.run (
+    let net = Init.rawlink ~filter:(bpf_filter ()) ethif in
+    let routes = [
+      "/ip";
+      "/domain";
+      "/search";
+      "/mtu";
+      "/nameservers/*"
+    ] in
+    Ctl.v "/data" >>= fun ctl ->
+    let fd = Init.(Fd.fd @@ Pipe.(priv ctl)) in
+    let ctl () = Ctl.serve ~routes ctl fd in
+    let handlers () = Handlers.watch path in
+    Init.run ~net ~ctl ~handlers cmd
+  )
+
+(* 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 ctl = string_of_int Init.(Fd.to_int Pipe.(calf ctl))
+let net = string_of_int Init.(Fd.to_int Pipe.(calf net))
+
+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"; "--ctl="^ctl; "--net="^net
+  ] 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 ethif =
+  let doc =
+    Arg.info ~docv:"NAME" ~doc:"The interface to listen too." ["ethif"]
+  in
+  Arg.(value & opt string "eth0" & doc)
+
+let path =
+  let doc =
+    Arg.info ~docv:"DIR"
+      ~doc:"The directory where control state will be stored." ["path"]
+  in
+  Arg.(value & opt string "/data" & doc)
+
+let run =
+  Term.(const run $ setup_log $ cmd $ ethif $ path),
+  Term.info "dhcp-client" ~version:"0.0"
+
+let () = match Term.eval run with
+  | `Error _ -> exit 1
+  | `Ok () |`Help |`Version -> exit 0

projects/miragesdk/src/init-dev.sh

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

projects/miragesdk/src/sdk/jbuild

@@ -6,5 +6,4 @@
               cmdliner fmt.cli logs.fmt logs.cli fmt.tty decompress
               irmin irmin-git irmin-http lwt.unix rawlink tuntap
               irmin-watcher inotify))
-  (preprocess (per_file ((pps (cstruct.ppx)) (ctl))))
  ))