miragesdk: shell out to ifconfig and ip to set the IP and routes

This forces us to bind mount /lib but will be replaced by calling the proper
bindings later on.

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

projects/miragesdk/examples/mirage-dhcp.yml

@@ -24,14 +24,16 @@ daemon:
     oomScoreAdj: -800
     readonly: true
   - name: dhcp-client
+    image: "mobylinux/dhcp-client:99ecd3304172eb7570aa5c7f527cec2577b48a84"
     net: host
-    image: "mobylinux/dhcp-client:f40cafe2ade4b115704750a85d21eb35b1116b91"
     capabilities:
      - CAP_NET_ADMIN # to bring eth0 up
      - CAP_NET_RAW   # to read /dev/eth0
     binds:
      - /var/run/dhcp-client:/data
-    command: [/dhcp-client, -vv]
+     - /sbin:/sbin   # for ifconfig
+     - /bin:/bin     # for ifconfig
+     - /lib:/lib     # for ifconfig
     readonly: true
 files:
   - path: /var/run/dhcp-client/README

projects/miragesdk/src/Dockerfile.build

@@ -1,13 +1,11 @@
 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 info mirage-net-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 opam install rresult
-RUN opam pin add cstruct --dev # for ppx/jbuilder
 RUN opam pin add tuntap 1.0.0
 
 # TMP: to compile the calf

projects/miragesdk/src/dhcp-client/calf/unikernel.ml

@@ -3,8 +3,11 @@ open Lwt.Infix
 let src = Logs.Src.create "charrua"
 module Log = (val Logs.src_log src : Logs.LOG)
 
+let failf fmt = Fmt.kstrf Lwt.fail_with fmt
+
 type t = {
   address: Ipaddr.V4.t;
+  gateway: Ipaddr.V4.t option;
   domain: string option;
   search: string option;
   nameservers: Ipaddr.V4.t list;
@@ -13,8 +16,9 @@ type t = {
 (* 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;
+    gateway = t.Mirage_protocols_lwt.gateway;
+    domain  = None;
+    search  = None;
     nameservers = [] }
 
 let pp ppf t =
@@ -33,10 +37,14 @@ let of_pkt lease =
   (* 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 gateway = match Dhcp_wire.collect_routers lease.options with
+    |  []  -> None
+    | h::_ -> Some h
+  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 }
+  { address; gateway; domain; search; nameservers }
 
 let of_pkt_opt = function
   | None       -> None
@@ -167,6 +175,16 @@ let setup_log =
 
 module Dhcp_client = Dhcp_client_mirage.Make(Time)(Net)
 
+let set_ip ctl k ip =
+  let str = Ipaddr.V4.to_string ip ^ "\n" in
+  Sdk.Ctl.Client.write ctl k str >>= function
+  | Ok ()           -> Lwt.return_unit
+  | Error (`Msg e) -> failf "error while writing %s: %s" k e
+
+let set_ip_opt ctl k = function
+  | None    -> Lwt.return_unit
+  | Some ip -> set_ip ctl k ip
+
 let start () dhcp_codes net ctl =
   Netif_fd.connect net >>= fun net ->
   let ctl = Sdk.Ctl.Client.v (Lwt_unix.of_unix_file_descr ctl) in
@@ -184,7 +202,8 @@ let start () dhcp_codes net ctl =
   Lwt_stream.last_new stream >>= fun result ->
   let result = of_ipv4_config result in
   Log.info (fun l -> l "found lease: %a" pp result);
-  Sdk.Ctl.Client.write ctl "/ip" (Ipaddr.V4.to_string result.address ^ "\n")
+  set_ip ctl "/ip" result.address >>= fun () ->
+  set_ip_opt ctl "/gateway" result.gateway
 
 (* FIXME: Main end *)
 let magic (x: int) = (Obj.magic x: Unix.file_descr)
@@ -202,7 +221,4 @@ let run =
 
 let () = match Term.eval run with
   | `Error _ -> exit 1
-  | `Ok (Ok ()) |`Help |`Version -> exit 0
-  | `Ok (Error (`Msg e)) ->
-    Printf.eprintf "%s\n%!" e;
-    exit 1
+  | `Ok () |`Help |`Version -> exit 0

projects/miragesdk/src/dhcp-client/jbuild

@@ -2,6 +2,6 @@
 
 (executables
  ((names (main))
-  (libraries (sdk bpf_dhcp))
+  (libraries (sdk bpf_dhcp bos))
   (flags (-cclib -static))
  ))

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

@@ -7,6 +7,12 @@ module Log = (val Logs.src_log src : Logs.LOG)
 
 let failf fmt = Fmt.kstrf Lwt.fail_with fmt
 
+let run fmt =
+  Fmt.kstrf (fun str ->
+      match Sys.command str with
+      | 0 -> Lwt.return ()
+      | i -> Fmt.kstrf Lwt.fail_with "%S exited with code %d" str i
+    ) fmt
 
 module Handlers = struct
 
@@ -17,23 +23,37 @@ module Handlers = struct
     | `Updated (_, (_, `Contents (v, _))) -> Some v
     | _ -> None
 
-  let ip t =
+  let ip ~ethif t =
     Ctl.KV.watch_key t ["ip"] (fun diff ->
         match contents_of_diff diff with
+        | None    -> Lwt.return_unit
         | Some ip ->
+          let ip = String.trim ip in
           Log.info (fun l -> l "SET IP to %s" ip);
-          Lwt.return ()
-        | _ ->
-          Lwt.return ()
+          (* FIXME: use language bindings to netlink instead *)
+          run "ifconfig %s %s netmask 255.255.255.0" ethif ip
+          (* run "ip addr add %s/24 dev %s" ip ethif *)
       )
 
-  let handlers = [
-    ip;
+  let gateway t =
+    Ctl.KV.watch_key t ["gateway"] (fun diff ->
+        match contents_of_diff diff with
+        | None    -> Lwt.return_unit
+        | Some gw ->
+          let gw = String.trim gw in
+          Log.info (fun l -> l "SET GATEWAY to %s" gw);
+          (* FIXME: use language bindings to netlink instead *)
+          run "ip route add default via %s" gw
+      )
+
+  let handlers ~ethif = [
+    ip ~ethif;
+    gateway;
   ]
 
-  let watch path =
+  let watch ~ethif path =
     Ctl.v path >>= fun db ->
-    Lwt_list.map_p (fun f -> f db) handlers >>= fun _ ->
+    Lwt_list.map_p (fun f -> f db) (handlers ethif) >>= fun _ ->
     let t, _ = Lwt.task () in
     t
 
@@ -74,6 +94,7 @@ let read_cmd file =
     let net = Init.rawlink ~filter:(bpf_filter ()) ethif in
     let routes = [
       "/ip";
+      "/gateway";
       "/domain";
       "/search";
       "/mtu";
@@ -82,7 +103,7 @@ let read_cmd file =
     Ctl.v "/data" >>= fun ctl ->
     let fd = Init.(Fd.fd @@ Pipe.(priv @@ ctl t)) in
     let ctl () = Ctl.Server.listen ~routes ctl fd in
-    let handlers () = Handlers.watch path in
+    let handlers () = Handlers.watch ~ethif path in
     Init.run t ~net ~ctl ~handlers cmd
   )