miragesdk: use the interface's MAC address instead of using a random one

The priv container populate the `/mac` key on startup, that the calf can
then read.

Also add more fine-grained control over read/write delete capabilities attached
to the routes, e.g. the calf can read /mac but not write to it.

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

projects/miragesdk/examples/mirage-dhcp.yml

@@ -25,7 +25,7 @@ services:
     oomScoreAdj: -800
     readonly: true
   - name: dhcp-client
-    image: "mobylinux/dhcp-client:9e7009ae469ddd4d37f9cffaad2cf612114a3fb0@sha256:4421e05a0082b56c4ef83ca652e1da1a5af3a24e5baec61e7ba5b981f3b94a09"
+    image: "mobylinux/dhcp-client:aadc4b05ef53cc75befcf60963d4b273f34267bd"
     net: host
     capabilities:
      - CAP_NET_ADMIN # to bring eth0 up

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

@@ -185,8 +185,15 @@ let set_ip_opt ctl k = function
   | None    -> Lwt.return_unit
   | Some ip -> set_ip ctl k ip
 
+let get_mac ctl =
+  Sdk.Ctl.Client.read ctl "/mac" >>= function
+  | Ok None   -> Lwt.return None
+  | Ok Some s -> Lwt.return @@ Macaddr.of_string (String.trim s)
+  | Error e   -> failf "get_mac: %a" Sdk.Ctl.Client.pp_error e
+
 let start () dhcp_codes net ctl =
-  Netif_fd.connect net >>= fun net ->
+  get_mac ctl >>= fun mac ->
+  Netif_fd.connect ?mac net >>= fun net ->
   let requests = match dhcp_codes with
     | [] -> default_options
     | l  ->

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

@@ -71,24 +71,30 @@ let read_cmd file =
   else
     failwith ("Cannot read " ^ file)
 
- let run () cmd ethif path =
+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 (
     let routes = [
-      "/ip";
+      "/ip"     , [`Write];
-      "/gateway";
+      "/mac"    , [`Read ];
-      "/domain";
+      "/gateway", [`Write];
-      "/search";
-      "/mtu";
-      "/nameservers/*"
     ] in
     Ctl.v path >>= fun db ->
     let ctl fd = Ctl.Server.listen ~routes db fd 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
   )
 

projects/miragesdk/src/sdk/ctl.ml

@@ -330,6 +330,8 @@ end
 
 module Server = struct
 
+  type op = [ `Read | `Write | `Delete ]
+
   let ok q payload =
     { Reply.id = q.Query.id; status = Reply.Ok; payload }
 
@@ -348,21 +350,29 @@ module Server = struct
         Irmin.Info.v ~date ~author:"calf" msg
       ) fmt
 
-  let dispatch db q =
+  let not_allowed q =
+    let path = q.Query.path in
+    let err = Fmt.strf "%s is not an allowed path" path in
+    Log.err (fun l -> l "%ld: %s" q.Query.id path);
+    error q err
+
+  let dispatch db op q =
     with_key q (fun key ->
+        let can x = List.mem x op in
         match q.Query.operation with
-        | Write ->
+        | Write when can `Write ->
           let info = infof "Updating %a" KV.Key.pp key in
           KV.set db ~info key q.payload >|= fun () ->
           ok q ""
-        | Delete ->
+        | Delete when can `Delete ->
           let info = infof "Removing %a" KV.Key.pp key in
           KV.remove db ~info key >|= fun () ->
           ok q ""
-        | Read ->
+        | Read when can `Read ->
-          KV.find db key >|= function
+          (KV.find db key >|= function
           | None   -> error q err_not_found
-          | Some v -> ok q v
+          | Some v -> ok q v)
+        | _ -> Lwt.return (not_allowed q)
       )
 
   let listen ~routes db fd =
@@ -384,13 +394,12 @@ module Server = struct
       Lwt_condition.wait cond >>= fun () ->
       let q = Queue.pop queries in
       let path = q.Query.path in
-      (if List.mem path routes then (
+      (if List.mem_assoc path routes then (
-          dispatch db q >>= fun r ->
+          let op = List.assoc path routes in
+          dispatch db op q >>= fun r ->
           Reply.write fd r
         ) else (
-         let err = Fmt.strf "%s is not an allowed path" path in
+         Reply.write fd (not_allowed q)
-         Log.err (fun l -> l "%ld: %s" q.Query.id path);
-         Reply.write fd (error q err)
        )) >>= fun () ->
       process ()
     in

projects/miragesdk/src/sdk/ctl.mli

@@ -126,7 +126,10 @@ val v: string -> KV.t Lwt.t
 
 module Server: sig
 
-  val listen: routes:string list -> KV.t -> IO.t -> unit Lwt.t
+  type op = [ `Read | `Write | `Delete ]
+  (** The type for operations to perform on routes. *)
+
+  val listen: routes:(string * op list) list -> KV.t -> IO.t -> unit Lwt.t
   (** [listen ~routes kv fd] is the thread exposing the KV store [kv],
       holding control plane state, running inside the privileged
       container. [routes] are the routes exposed by the server to the

projects/miragesdk/src/sdk/jbuild

@@ -5,6 +5,6 @@
   (libraries (threads cstruct.lwt cmdliner fmt.cli logs.fmt logs.cli fmt.tty
               decompress irmin irmin-git lwt.unix rawlink tuntap dispatch
               irmin-watcher inotify astring rresult mirage-flow-lwt
-              mirage-channel-lwt io-page.unix))
+              mirage-channel-lwt io-page.unix ipaddr))
   (preprocess (per_file ((pps (cstruct.ppx)) (ctl))))
  ))

projects/miragesdk/src/test/test.ml

@@ -206,7 +206,8 @@ let test_ctl t () =
   let k2 = "a" in
   let k3 = "b/c" in
   let k4 = "xxxxxx" in
-  let routes = [k1; k2; k3] in
+  let all = [`Read; `Write; `Delete] in
+  let routes = [k1,all; k2,all; k3,all ] in
   let git_root = "/tmp/sdk/ctl" in
   let _ = Sys.command (Fmt.strf "rm -rf %s" git_root) in
   Ctl.v git_root >>= fun ctl ->