Split the DHCP client into three components communicating via named pipes

3 components:

- network: read eht0 and proxy only DHCP traffic
- engine: read DHCP traffic, handle DHCP client state machine, and call the
  host actuator to change the host config when a lease is obtained
  host system configuration.
- actuator: perform the acutall net syscalls, read and write host configuration
  files, etc

These three components can either be linked together in a single binary
(see src/dhcp-client/main.ml) or can be used as 3 binaries communicating
over cap-n-proto.

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

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

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

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

@@ -28,15 +28,6 @@
 
 #include <net/ethernet.h>
 
-#ifdef __linux__
-
-#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>
@@ -52,6 +43,15 @@
 #include "caml/custom.h"
 #include "caml/bigarray.h"
 
+#ifdef __linux__
+
+#include <linux/if_packet.h>
+#include <linux/filter.h>
+
+#include <net/if.h>
+
+#include <arpa/inet.h>
+
 #define BOOTPC          68
 #define BPF_WHOLEPACKET 0x0fffffff
 
@@ -80,6 +80,13 @@ static const struct sock_filter bootp_bpf_filter [] = {
   BPF_STMT(BPF_RET + BPF_K, 0),
 };
 
+#else
+
+struct sock_filter {};
+static const struct sock_filter bootp_bpf_filter [] = {};
+
+#endif
+
 /* Filters */
 CAMLprim value bpf_filter(value vunit)
 {
@@ -89,5 +96,3 @@ CAMLprim value bpf_filter(value vunit)
   memcpy(String_val(vfilter), bootp_bpf_filter, sizeof(bootp_bpf_filter));
   CAMLreturn (vfilter);
 }
-
-#endif

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

@@ -0,0 +1,56 @@
+open Lwt.Infix
+
+let src = Logs.Src.create "dhcp-client/engine"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+type t = {
+  address: Ipaddr.V4.t;
+  gateway: Ipaddr.V4.t option;
+  domain: string option;
+  search: string option;
+  nameservers: Ipaddr.V4.t list;
+}
+
+(* FIXME: we (still) lose lots of info here *)
+let of_lease (t: Dhcp_wire.pkt) =
+  let gateway = match Dhcp_wire.collect_routers t.Dhcp_wire.options with
+  | [] -> None
+  | n::_ -> Some n
+  in
+  { address = t.Dhcp_wire.yiaddr;
+    gateway;
+    domain = Dhcp_wire.find_domain_name t.Dhcp_wire.options;
+    search = Dhcp_wire.find_domain_search t.Dhcp_wire.options;
+    nameservers = Dhcp_wire.collect_dns_servers t.Dhcp_wire.options }
+
+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
+
+module Make
+    (Time: Sdk.Time.S)
+    (Net : Sdk.Net.S)
+    (Host: Sdk.Host.S) =
+struct
+
+  module Dhcp_client = Dhcp_client_lwt.Make(Time)(Net)
+
+  let start _ net host =
+    Host.dhcp_options host >>= fun requests ->
+    Dhcp_client.connect ~requests net >>= fun stream ->
+    Lwt_stream.last_new stream >>= fun result ->
+    let result = of_lease result in
+    Log.info (fun l -> l "found lease: %a" pp result);
+    Host.set_ip host result.address >>= fun () ->
+    (match result.gateway with
+     | None -> Lwt.return_unit
+     | Some ip -> Host.set_gateway host ip)
+
+end

projects/miragesdk/src/dhcp-client/engine.mli

@@ -0,0 +1,11 @@
+(** [Engine] is the DHCP client engine. It access network traffic via
+    the [Net] MirageOS's network interface, and use [Act] to modify IP
+    tables and other low-level caches. *)
+
+module Make
+    (Time: Sdk.Time.S)
+    (Net : Sdk.Net.S)
+    (Act : Sdk.Host.S):
+sig
+  val start: Time.t -> Net.t -> Act.t -> unit Lwt.t
+end

projects/miragesdk/src/dhcp-client/jbuild

@@ -1,7 +1,13 @@
 (jbuild_version 1)
 
+(library
+  ((name    dhcp_filter)
+   (modules ())
+   (c_names (dhcp))))
+
 (executables
- ((names (main))
-  (libraries (sdk bpf_dhcp bos cmdliner fmt.cli logs.fmt logs.cli fmt.tty))
-  (flags (-cclib -static))
- ))
+  ((names        (main main_eng main_act main_net))
+   (public_names (dhcp-client dhcp-client-eng dhcp-client-act dhcp-client-net))
+   (package      dhcp-client)
+   (libraries    (sdk charrua-client charrua-client-mirage dhcp_filter
+                  cmdliner fmt.cli logs.fmt logs.cli fmt.tty))))

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

@@ -1,112 +1,26 @@
 open Lwt.Infix
-open Sdk
-open Astring
 
-let src = Logs.Src.create "dhcp-client" ~doc:"DHCP client"
-module Log = (val Logs.src_log src : Logs.LOG)
+module Act = Sdk.Host.Local
+module Net = Network.Make(Act)
+module Eng = Engine.Make(Sdk.Time.Local)(Net)(Act)
 
-module Handlers = struct
+let main intf =
+  Act.connect intf >>= fun act ->
+  Net.connect act >>= fun net ->
+  Eng.start () net act
 
-  (* System handlers *)
-
-  let contents_of_diff = function
-    | `Added (_, `Contents (v, _))
-    | `Updated (_, (_, `Contents (v, _))) -> Some v
-    | _ -> None
-
-  let with_ip str f =
-    match Ipaddr.V4.of_string (String.trim str) with
-    | Some ip ->
-      Log.info (fun l -> l "SET IP to %a" Ipaddr.V4.pp_hum ip);
-      f ip
-    | None ->
-      Log.err (fun l -> l "%s is not a valid IP" str);
-      Lwt.return_unit
-
-  let ip ~ethif t =
-    Ctl.KV.watch_key t ["ip"] (fun diff ->
-        match contents_of_diff diff with
-        | None    -> Lwt.return_unit
-        | Some ip -> with_ip ip (fun ip -> Net.set_ip ethif ip)
-      )
-
-  let gateway t =
-    Ctl.KV.watch_key t ["gateway"] (fun diff ->
-        match contents_of_diff diff with
-        | None    -> Lwt.return_unit
-        | Some gw -> with_ip gw (fun gw -> Net.set_gateway gw)
-      )
-
-  let handlers ~ethif = [
-    ip ~ethif;
-    gateway;
-  ]
-
-  let watch ~ethif db =
-    Lwt_list.map_p (fun f -> f db) (handlers ~ethif) >>= fun _ ->
-    let t, _ = Lwt.task () in
-    t
-
-end
-
-external dhcp_filter: unit -> string = "bpf_filter"
-
-let t = Init.Pipe.v ()
-
-(*
-let default_cmd = [
-  "/calf/dhcp-client-calf"; "--net=3"; "--ctl=4"; "-vv";
-]
-*)
-
-let default_cmd = [
-  "/usr/bin/runc"; "run"; "--preserve-fds"; "2"; "--bundle"; "calf";  "calf"
-]
-
-let read_cmd file =
-  if Sys.file_exists file then
-    let ic = open_in_bin file in
-    let line = input_line ic in
-    String.cuts ~sep:" " line
-  else
-    failwith ("Cannot read " ^ file)
-
-let infof fmt =
-  Fmt.kstrf (fun msg () ->
-      let date = Int64.of_float (Unix.gettimeofday ()) in
-      Irmin.Info.v ~date ~author:"priv" msg
-    ) fmt
-
-let run () cmd ethif path =
-  let cmd = match cmd with
-    | None   -> default_cmd
-    | Some f -> read_cmd f
-  in
-  Lwt_main.run (
-    Lwt_switch.with_switch @@ fun switch ->
-    let routes = [
-      ["ip"]     , [`Write];
-      ["mac"]    , [`Read ];
-      ["gateway"], [`Write];
-    ] in
-    Ctl.v path >>= fun db ->
-    let ctl fd =
-      let service = Ctl.Server.service ~routes db in
-      let endpoint = Capnp_rpc_lwt.Endpoint.of_flow ~switch (module Mirage_flow_lwt) fd in
-      ignore (Capnp_rpc_lwt.CapTP.of_endpoint ~switch ~offer:service endpoint)
-    in
-    let handlers () = Handlers.watch ~ethif db in
-    let net = Init.rawlink ~filter:(dhcp_filter ()) ethif in
-    Net.mac ethif >>= fun mac ->
-    let mac = Macaddr.to_string mac ^ "\n" in
-    Ctl.KV.set db ~info:(infof "Add mac") ["mac"] mac >>= fun () ->
-    Init.run t ~net ~ctl ~handlers cmd
-  )
-
-(* CLI *)
+let run () intf = Lwt_main.run (main intf)
 
 open Cmdliner
 
+let intf =
+  let doc =
+    Arg.info ~docv:"INTF" ~doc:"The interface to listen too."
+      ["e"; "ethif"]
+  in
+  Arg.(value & opt string "eth0" doc)
+
+(* FIXME: use SDK to write logs *)
 let setup_log style_renderer level =
   Fmt_tty.setup_std_outputs ?style_renderer ();
   Logs.set_level level;
@@ -119,28 +33,9 @@ let setup_log style_renderer level =
 let setup_log =
   Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ())
 
-let cmd =
-  let doc =
-    Arg.info ~docv:"CMD" ~doc:"Command to run the calf process." ["cmd"]
-  in
-  Arg.(value & opt (some string) None & 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"
+  Term.(const run $ setup_log $ intf),
+  Term.info "dhcp-client" ~version:"%%VERSION%%"
 
 let () = match Term.eval run with
   | `Error _ -> exit 1

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

@@ -1 +1,3 @@
-(* empty *)
+(* FIXME *)
+
+(* Link everything together! *)

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

@@ -0,0 +1,67 @@
+open Lwt.Infix
+
+let src = Logs.Src.create "dhcp-client/actuator"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module Flow = Sdk.Flow.Fd
+module Host = Sdk.Host.Local
+module N = Sdk.Host.Server(Flow)(Host)
+module E = Sdk.Host.Server(Flow)(Host)
+
+let start ~intf ~net ~eng =
+  Lwt_switch.with_switch @@ fun switch ->
+  Flow.connect net >>= fun net ->
+  Flow.connect eng >>= fun eng ->
+  Host.connect intf >>= fun host ->
+  N.listen ~switch (N.service host) net;
+  E.listen ~switch (E.service host) eng;
+  fst (Lwt.task ())
+
+let run () intf net eng = Lwt_main.run (start ~intf ~net ~eng)
+
+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 intf =
+  let doc =
+    Arg.info ~docv:"INTF" ~doc:"The interface to listen too."
+      ["e"; "ethif"]
+  in
+  Arg.(value & opt string "eth0" doc)
+
+let eng =
+  let doc =
+    Arg.info
+      ~docv:"FD"
+      ~doc:"The file descriptor to use to connect to the DHCP client engine."
+      ["e"; "engine"]
+  in
+  Arg.(value & opt int 3 & doc)
+
+let net =
+  let doc =
+    Arg.info
+      ~docv:"FD"
+      ~doc:"The file descriptor to use to connect to the network proxy."
+      ["n"; "network"]
+  in
+  Arg.(value & opt int 4 & doc)
+
+let run =
+  Term.(const run $ setup_log $ intf $ net $ eng),
+  Term.info "dhcp-client-actuator" ~version:"%%VERSION%%"
+
+let () = match Term.eval run with
+  | `Error _ -> exit 1
+  | `Ok () |`Help |`Version -> exit 0

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

@@ -0,0 +1,58 @@
+open Lwt.Infix
+
+module Flow = Sdk.Flow.Fd
+module Time = Sdk.Time.Local
+module Net = Sdk.Net.Client(Flow)
+module Act = Sdk.Host.Client(Flow)
+
+module Main = Engine.Make(Time)(Net)(Act)
+
+let start ~net ~act =
+  Lwt_switch.with_switch @@ fun switch ->
+  Flow.connect net >>= fun net ->
+  Net.connect ~switch net >>= fun net ->
+  Flow.connect act >>= fun act ->
+  Act.connect ~switch act >>= fun act ->
+  Main.start () net act
+
+let run () net act = Lwt_main.run (start ~net ~act)
+
+open Cmdliner
+
+let net =
+  let doc =
+    Arg.info
+      ~docv:"FD"
+      ~doc:"The file descriptor to use to connect to the network proxy."
+      ["e"; "engine"]
+  in
+  Arg.(value & opt int 3 & doc)
+
+let act =
+  let doc =
+    Arg.info
+      ~docv:"FD"
+      ~doc:"The file descriptor to use to connect to the host actuator."
+      ["a"; "actuator"]
+  in
+  Arg.(value & opt int 4 & doc)
+
+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 run =
+  Term.(const run $ setup_log $ net $ act),
+  Term.info "dhcp-client-engine" ~version:"%%VERSION%%"
+
+let () = match Term.eval run with
+  | `Error _ -> exit 1
+  | `Ok () |`Help |`Version -> exit 0

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

@@ -0,0 +1,58 @@
+open Lwt.Infix
+
+module Flow = Sdk.Flow.Fd
+module Act = Sdk.Host.Client(Flow)
+module Net = Network.Make(Act)
+
+module Main = Sdk.Net.Server(Flow)(Net)
+
+let start ~eng ~act =
+  Lwt_switch.with_switch @@ fun switch ->
+  Flow.connect act >>= fun act ->
+  Act.connect ~switch act >>= fun act ->
+  Flow.connect eng >>= fun eng ->
+  Net.connect act >>= fun net ->
+  Main.listen ~switch (Main.service net) eng;
+  fst (Lwt.task ())
+
+let run () eng act = Lwt_main.run (start ~eng ~act)
+
+open Cmdliner
+
+let eng =
+  let doc =
+    Arg.info
+      ~docv:"FD"
+      ~doc:"The file descriptor to use to connect to the DHCP client engine."
+      ["e"; "engine"]
+  in
+  Arg.(value & opt int 3 & doc)
+
+let act =
+  let doc =
+    Arg.info
+      ~docv:"FD"
+      ~doc:"The file descriptor to use to connect to the host actuator."
+      ["a"; "actuator"]
+  in
+  Arg.(value & opt int 4 & doc)
+
+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 run =
+  Term.(const run $ setup_log $ eng $ act),
+  Term.info "dhcp-client-network" ~version:"%%VERSION%%"
+
+let () = match Term.eval run with
+  | `Error _ -> exit 1
+  | `Ok () |`Help |`Version -> exit 0

projects/miragesdk/src/dhcp-client/main_net.mli

@@ -0,0 +1 @@
+

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

@@ -0,0 +1,15 @@
+open Lwt.Infix
+
+external dhcp_filter: unit -> string = "bpf_filter"
+
+module Make (Act: Sdk.Host.S) = struct
+
+  include Sdk.Net.Rawlink
+
+  let connect act =
+    let filter = dhcp_filter () in
+    Act.mac act >>= fun mac ->
+    Act.interface act >>= fun intf ->
+    Sdk.Net.Rawlink.connect ~filter ~mac intf
+
+end

projects/miragesdk/src/dhcp-client/network.mli

@@ -0,0 +1,7 @@
+(** [Network] provides a MirageOS's network interface with only DHCP
+    traffic. It uses [Act] to get the host's MAC address. *)
+
+module Make (Act: Sdk.Host.S): sig
+  include Sdk.Net.S
+  val connect: Act.t -> t Lwt.t
+end