Merge pull request #1467 from samoht/better-init

mirage-sdk: better init

projects/miragesdk/src/README.md

@@ -1,7 +1,23 @@
-## DHCP client using MirageOS
+### SDK
 
-To debug/build, the `enter-dev` target will create a dev container where
+To build and test the SDK, run:
-`make dev` will build and run the current state of the prototype:
+
+```
+$ make test
+```
+
+This will work on any OS.
+
+### DHCP client using MirageOS
+
+To build the MirageOS DHCP client, run:
+
+```
+$ make dev
+```
+
+As this is using some BPF runes, this will work only on Linux. To debug/build
+on OSX, you can create a container and build from there:
 
 ```
 make enter-dev
@@ -11,4 +27,4 @@ make dev
 
 ### Documentation
 
-See the [general architecture document](../../doc/unikernel.md).
+See the [general architecture document](../../doc/unikernel.md).

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

@@ -41,8 +41,10 @@ end
 
 external bpf_filter: unit -> string = "bpf_filter"
 
-let ctl = string_of_int Init.(Fd.to_int Pipe.(calf ctl))
+let t = Init.Pipe.v ()
-let net = string_of_int Init.(Fd.to_int Pipe.(calf net))
+
+let ctl = string_of_int Init.(Fd.to_int Pipe.(calf @@ ctl t))
+let net = string_of_int Init.(Fd.to_int Pipe.(calf @@ net t))
 let default_cmd = [
   "/dhcp-client-calf"; "--ctl="^ctl; "--net="^net
 ]
@@ -78,10 +80,10 @@ let read_cmd file =
       "/nameservers/*"
     ] in
     Ctl.v "/data" >>= fun ctl ->
-    let fd = Init.(Fd.fd @@ Pipe.(priv ctl)) in
+    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
-    Init.run ~net ~ctl ~handlers cmd
+    Init.run t ~net ~ctl ~handlers cmd
   )
 
 (* CLI *)

projects/miragesdk/src/sdk/init.ml

@@ -95,6 +95,20 @@ module Pipe = struct
 
   type t = Fd.t * Fd.t
 
+  type monitor = {
+    stdout: t;
+    stderr: t;
+    metrics: t;
+    ctl: t;
+    net: t;
+  }
+
+  let stdout t = t.stdout
+  let stderr t = t.stderr
+  let metrics t = t.metrics
+  let ctl t = t.ctl
+  let net t = t.net
+
   let name (x, _) = x.Fd.name
 
   let priv = fst
@@ -112,37 +126,36 @@ module Pipe = struct
     Lwt_unix.clear_close_on_exec calf;
     { Fd.name = name; fd = priv }, { Fd.name = name ^ "-calf"; fd = calf }
 
-  (* logs pipe *)
+  let v () =
-  let stdout = pipe "stdout"
+    (* logs pipe *)
-  let stderr = pipe "stderr"
+    let stdout = pipe "stdout" in
-
+    let stderr = pipe "stderr" in
-  (* store pipe *)
+    (* store pipe *)
-  let ctl = socketpair "ctl"
+    let ctl = socketpair "ctl" in
-
+    (* network pipe *)
-  (* network pipe *)
+    let net = socketpair "net" in
-  let net = socketpair "net"
+    (* metrics pipe *)
-
+    let metrics = pipe "metrics" in
-  (* metrics pipe *)
+    { stdout; stderr; ctl; net; metrics }
-  let metrics = pipe "metrics"
 
 end
 
-let exec_calf cmd =
+let exec_calf t cmd =
   Fd.(redirect_to_dev_null stdin) >>= fun () ->
 
   (* close parent fds *)
-  Fd.close Pipe.(priv stdout)  >>= fun () ->
+  Fd.close Pipe.(priv t.stdout)  >>= fun () ->
-  Fd.close Pipe.(priv stderr)  >>= fun () ->
+  Fd.close Pipe.(priv t.stderr)  >>= fun () ->
-  Fd.close Pipe.(priv ctl)     >>= fun () ->
+  Fd.close Pipe.(priv t.ctl)     >>= fun () ->
-  Fd.close Pipe.(priv net)     >>= fun () ->
+  Fd.close Pipe.(priv t.net)     >>= fun () ->
-  Fd.close Pipe.(priv metrics) >>= fun () ->
+  Fd.close Pipe.(priv t.metrics) >>= fun () ->
 
   let cmds = String.concat " " cmd in
 
-  let calf_net = Pipe.(calf net) in
+  let calf_net = Pipe.(calf t.net) in
-  let calf_ctl = Pipe.(calf ctl) in
+  let calf_ctl = Pipe.(calf t.ctl) in
-  let calf_stdout = Pipe.(calf stdout) in
+  let calf_stdout = Pipe.(calf t.stdout) in
-  let calf_stderr = Pipe.(calf stderr) in
+  let calf_stderr = Pipe.(calf t.stderr) in
 
   Log.info (fun l -> l "Executing %s" cmds);
   Log.debug (fun l -> l "net-fd=%a store-fd=%a" Fd.pp calf_net Fd.pp calf_ctl);
@@ -167,16 +180,16 @@ let check_exit_status cmd status =
   | Unix.WSIGNALED i -> failf "%s: signal %d" cmds i
   | Unix.WSTOPPED i  -> failf "%s: stopped %d" cmds i
 
-let exec_priv ~pid ~cmd ~net ~ctl ~handlers =
+let exec_priv t ~pid ~cmd ~net ~ctl ~handlers =
 
   Fd.(redirect_to_dev_null stdin) >>= fun () ->
 
   (* close child fds *)
-  Fd.close Pipe.(calf stdout)  >>= fun () ->
+  Fd.close Pipe.(calf t.stdout)  >>= fun () ->
-  Fd.close Pipe.(calf stderr)  >>= fun () ->
+  Fd.close Pipe.(calf t.stderr)  >>= fun () ->
-  Fd.close Pipe.(calf net)     >>= fun () ->
+  Fd.close Pipe.(calf t.net)     >>= fun () ->
-  Fd.close Pipe.(calf ctl)     >>= fun () ->
+  Fd.close Pipe.(calf t.ctl)     >>= fun () ->
-  Fd.close Pipe.(calf metrics) >>= fun () ->
+  Fd.close Pipe.(calf t.metrics) >>= fun () ->
 
   let wait () =
     Lwt_unix.waitpid [] pid >>= fun (_pid, w) ->
@@ -187,18 +200,18 @@ let exec_priv ~pid ~cmd ~net ~ctl ~handlers =
   Lwt.pick ([
       wait ();
       (* data *)
-      Fd.proxy_net ~net Pipe.(priv net);
+      Fd.proxy_net ~net Pipe.(priv t.net);
 
       (* redirect the calf stdout to the shim stdout *)
-      Fd.forward ~src:Pipe.(priv stdout)  ~dst:Fd.stdout;
+      Fd.forward ~src:Pipe.(priv t.stdout)  ~dst:Fd.stdout;
-      Fd.forward ~src:Pipe.(priv stderr)  ~dst:Fd.stderr;
+      Fd.forward ~src:Pipe.(priv t.stderr)  ~dst:Fd.stderr;
       (* TODO: Init.Fd.forward ~src:Init.Pipe.(priv metrics) ~dst:Init.Fd.metric; *)
       ctl ();
       handlers ();
     ])
 
-let run ~net ~ctl ~handlers cmd =
+let run t ~net ~ctl ~handlers cmd =
   Lwt_io.flush_all () >>= fun () ->
   match Lwt_unix.fork () with
-  | 0   -> exec_calf cmd
+  | 0   -> exec_calf t cmd
-  | pid -> exec_priv ~pid ~cmd ~net ~ctl ~handlers
+  | pid -> exec_priv t ~pid ~cmd ~net ~ctl ~handlers

projects/miragesdk/src/sdk/init.mli

@@ -63,6 +63,11 @@ module Pipe: sig
   (** The type for pipes. Could be either uni-directional (normal
       pipes) or a bi-directional (socket pairs). *)
 
+  type monitor
+  (** The type for pipe monitors. *)
+
+  val v: unit -> monitor
+
   val name: t -> string
   (** [name t] is [t]'s name. *)
 
@@ -74,23 +79,26 @@ module Pipe: sig
 
   (** {1 Useful Pipes} *)
 
-  val stdout: t
+  val stdout: monitor -> t
-  (** [stdout] is the uni-directional pipe from the calf's stdout . *)
+  (** [stdout m] is the uni-directional pipe from the calf's stdout
+      monitored by [m]. *)
 
-  val stderr: t
+  val stderr: monitor -> t
-  (** [stderr] is the uni-directional pipe from the calf's stderr. *)
+  (** [stderr m] is the uni-directional pipe from the calf's stderr
+      monitored by [m]. *)
 
-  val metrics: t
+  val metrics: monitor -> t
-  (** [metrics] is the uni-directional pipe fomr the calf's metric
+  (** [metrics m] is the uni-directional pipe from the calf's metric
-      endpoint. *)
+      endpoint monitored by [m]. *)
 
-  val ctl: t
+  val ctl: monitor -> t
-  (** [ctl] is the bi-directional pipe used to exchange control
+  (** [ctl m] is the bi-directional pipe used to exchange control data
-      data between the calf and the priv containers. *)
+      between the calf and the priv containers monitored by [m]. *)
 
-  val net: t
+  val net: monitor -> t
-  (** [net] is the bi-directional pipe used to exchange network
+  (** [net m] is the bi-directional pipe used to exchange network
-      traffic between the calf and the priv containers. *)
+      traffic between the calf and the priv containers monitored by
+      [m]. *)
 
 end
 
@@ -98,12 +106,12 @@ val rawlink: ?filter:string -> string -> Lwt_rawlink.t
 (** [rawlink ?filter i] is the net raw link to the interface [i] using
     the (optional) BPF filter [filter]. *)
 
-val run:
+val run: Pipe.monitor ->
   net:Lwt_rawlink.t ->
   ctl:(unit -> unit Lwt.t) ->
   handlers:(unit -> unit Lwt.t) ->
   string list -> unit Lwt.t
-(** [run ~net ~ctl ~handlers cmd] runs [cmd] in a unprivileged calf
+(** [run m ~net ~ctl ~handlers cmd] runs [cmd] in a unprivileged calf
     process. [ctl] is the control thread connected to the {Pipe.ctl}
     pipe. [net] is the net raw link which will be connected to the
     calf via the {!Pipe.net} socket pair. [handlers] are the system

projects/miragesdk/src/test/test.ml

@@ -117,9 +117,9 @@ let test_serialization to_cstruct of_cstruct message messages =
   in
   List.iter test messages
 
-let test_send write read message messages =
+let test_send t write read message messages =
-  let calf = Init.Fd.fd @@ Init.Pipe.(calf ctl) in
+  let calf = Init.Fd.fd @@ Init.Pipe.(calf @@ ctl t) in
-  let priv = Init.Fd.fd @@ Init.Pipe.(priv ctl) in
+  let priv = Init.Fd.fd @@ Init.Pipe.(priv @@ ctl t) in
   let test m =
     write calf m >>= fun () ->
     read priv >|= function
@@ -136,13 +136,13 @@ let test_reply_serialization () =
   let open Ctl.Reply in
   test_serialization to_cstruct of_cstruct reply replies
 
-let test_query_send () =
+let test_query_send t () =
   let open Ctl.Query in
-  test_send write read query queries
+  test_send t write read query queries
 
-let test_reply_send () =
+let test_reply_send t () =
   let open Ctl.Reply in
-  test_send write read reply replies
+  test_send t write read reply replies
 
 let failf fmt = Fmt.kstrf Alcotest.fail fmt
 
@@ -191,9 +191,9 @@ let delete_should_work t k =
   | Ok ()          -> ()
   | Error (`Msg e) -> failf "write(%s) -> error: %s" k e
 
-let test_ctl () =
+let test_ctl t () =
-  let calf = Init.Fd.fd @@ Init.Pipe.(calf ctl) in
+  let calf = Init.Fd.fd @@ Init.Pipe.(calf @@ ctl t) in
-  let priv = Init.Fd.fd @@ Init.Pipe.(priv ctl) in
+  let priv = Init.Fd.fd @@ Init.Pipe.(priv @@ ctl t) in
   let k1 = "/foo/bar" in
   let k2 = "a" in
   let k3 = "b/c" in
@@ -238,16 +238,18 @@ let run f () =
 
 let test_stderr () = ()
 
+let t = Init.Pipe.v ()
+
 let test = [
-  "stdout is a pipe"    , `Quick, run (test_pipe Init.Pipe.stdout);
+  "stdout is a pipe"    , `Quick, run (test_pipe Init.Pipe.(stdout t));
-  "stdout is a pipe"    , `Quick, run (test_pipe Init.Pipe.stderr);
+  "stdout is a pipe"    , `Quick, run (test_pipe Init.Pipe.(stderr t));
-  "net is a socket pair", `Quick, run (test_socketpair Init.Pipe.net);
+  "net is a socket pair", `Quick, run (test_socketpair Init.Pipe.(net t));
-  "ctl is a socket pair", `Quick, run (test_socketpair Init.Pipe.ctl);
+  "ctl is a socket pair", `Quick, run (test_socketpair Init.Pipe.(ctl t));
   "seralize queries"    , `Quick, test_query_serialization;
   "seralize replies"    , `Quick, test_reply_serialization;
-  "send queries"        , `Quick, run test_query_send;
+  "send queries"        , `Quick, run (test_query_send t);
-  "send replies"        , `Quick, run test_reply_send;
+  "send replies"        , `Quick, run (test_reply_send t);
-  "ctl"                 , `Quick, run test_ctl;
+  "ctl"                 , `Quick, run (test_ctl t);
 ]
 
 let reporter ?(prefix="") () =