Merge pull request #2133 from samoht/fdd

sdk: add a yml example on how to use fdd to create container channels

projects/miragesdk/examples/fdd.yml

@@ -0,0 +1,37 @@
+kernel:
+  image: "linuxkit/kernel:4.9.34"
+  cmdline: "console=ttyS0 page_poison=1"
+init:
+  - linuxkit/init:36c56f0664d49c5a6adc1120d1bf5ba6ac30b389
+  - linuxkit/runc:291131ec026430371e7c36165c3f43734fbc2541
+  - linuxkit/containerd:1e3e8f207421de8deac8cedc26a138d6b1661a0d
+  - linuxkit/ca-certificates:46b59484919bfa9af700e54e042048cb06261de4
+  - samoht/fdd
+onboot:
+  - name: sysctl
+    image: "linuxkit/sysctl:3aa6bc663c2849ef239be7d941d3eaf3e6fcc018"
+services:
+  - name: getty
+    image: "linuxkit/getty:6cbeee0392b0670053ce2bf05a5a0d67ec2bce05"
+    env:
+     - INSECURE=true
+  - name: rngd
+    image: "linuxkit/rngd:b50b22dd574c5377708977af769f053009fff6d5"
+  - name: dhcpcd
+    image: "linuxkit/dhcpcd:6c1ca76dbf808d5c27d10cbf22a8d4399be5c8ae"
+files:
+  - path: etc/init.d/020-fdd-init
+    mode: "0700"
+    contents: |
+      #!/bin/sh
+      /bin/fdd init -vv -s /run/fdd.sock
+  - path: etc/init.d/030-fdd-share
+    mode: "0700"
+    contents: |
+      #!/bin/sh
+      /bin/fdd share -vv -s /run/fdd.sock /tmp/channel-net-eng &&
+      /bin/fdd share -vv -s /run/fdd.sock /tmp/channel-conf-net &&
+      /bin/fdd share -vv -s /run/fdd.sock /tmp/channel-conf-act
+trust:
+  org:
+    - linuxkit

projects/miragesdk/src/fdd/Dockerfile

@@ -1,12 +1,12 @@
 FROM ocaml/opam:alpine as base
 RUN sudo apk add m4
-RUN opam install jbuilder lwt fd-send-recv logs fmt cmdliner
+RUN opam install jbuilder lwt fd-send-recv logs fmt cmdliner astring
 ADD . /src
 RUN opam pin add fdd /src
-RUN sudo mkdir /out
-RUN sudo cp /home/opam/.opam/4.04.2/bin/fdd /out
+RUN sudo mkdir -p /out/bin
+RUN sudo cp /home/opam/.opam/4.04.2/bin/fdd /out/bin
 
 FROM scratch
-COPY --from=base /out/fdd .
+COPY --from=base /out .
 USER 0
 ENTRYPOINT ["/fdd"]

projects/miragesdk/src/fdd/Makefile

@@ -5,3 +5,10 @@ all:
 
 clean:
 	jbuilder clean
+
+### FIXME: use Makefile template
+
+IMAGE=samoht/fdd
+
+tag:
+	docker build -t $(IMAGE) . && docker push $(IMAGE)

projects/miragesdk/src/fdd/exec.ml

@@ -0,0 +1,22 @@
+open Lwt.Infix
+open Common
+
+let src = Logs.Src.create "fdd/exec"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let get_fd share = connect share >>= recv_fd
+
+let fd_of_int (i:int) =
+  let fd : Unix.file_descr = Obj.magic i in
+  Lwt_unix.of_unix_file_descr fd
+
+let dup (share, fds) =
+  Log.info (fun l ->
+      l "mapping %s to fds: %a" share Fmt.(list ~sep:(unit " ") int) fds);
+  get_fd share >|= fun fd ->
+  List.iter (fun n -> Lwt_unix.dup2 fd (fd_of_int n)) fds;
+  Unix.close (Lwt_unix.unix_file_descr fd)
+
+let f dups cmd =
+  Lwt_list.iter_p dup dups >>= fun () ->
+  Unix.execvp (List.hd cmd) (Array.of_list cmd)

projects/miragesdk/src/fdd/exec.mli

@@ -0,0 +1 @@
+val f: (string * int list) list -> string list -> unit Lwt.t

projects/miragesdk/src/fdd/fdd.ml

@@ -1,3 +1,4 @@
+open Astring
 open Cmdliner
 
 let socket =
@@ -42,6 +43,38 @@ let share =
   Term.(const f $ socket $ share $ setup_log),
   Term.info "share" ~doc:"Share a new socketpair on a given unix domain socket."
 
+let exec =
+  let dup =
+    let parse str = match String.cuts ~sep:":" str with
+      | [] | [_] ->
+        Error (`Msg ("A valid share map should have the form \
+                      <path>:<fd-number>[:fd-number]*"))
+      | s :: fds  -> Ok (s, List.map int_of_string fds)
+    in
+    let pp ppf (name, fds) =
+      Fmt.pf ppf "%s:%a" name Fmt.(list ~sep:(unit ":") int) fds
+    in
+    Arg.conv (parse, pp)
+  in
+  let dups =
+    let doc =
+      Arg.info ~docv:"MAP" ~doc:
+        "Maps of socketpairs/local fds in the form \
+         <path>:<fd-number>[:fd-number]*,..."
+        ["m";"map"]
+    in
+    Arg.(value & opt (list dup) [] doc)
+  in
+  let cmd =
+    let doc = Arg.info ~docv:"COMMAND" ~doc:"The command to execute" [] in
+    Arg.(non_empty & pos_all string [] doc)
+  in
+  let f dups cmd () = run (Exec.f dups cmd) in
+  Term.(const f $ dups $ cmd $ setup_log),
+  Term.info "exec"
+    ~doc:"Execute a command with a side of the socketpair pre-opened on the \
+          specified files descriptors."
+
 let default =
   let usage () =
     Fmt.pr "usage: fdd [--version]\n\
@@ -64,6 +97,7 @@ let cmds = [
   init;
   share;
   test;
+  exec;
 ]
 
 let () = match Term.eval_choice default cmds with

projects/miragesdk/src/fdd/jbuild

@@ -4,4 +4,4 @@
     (package     fdd)
     (flags     (:standard -cclib -static))
     (libraries (unix lwt.unix lwt.preemptive fd-send-recv logs fmt cmdliner
-                fmt.cli logs.fmt fmt.tty logs.cli))))
+                fmt.cli logs.fmt fmt.tty logs.cli astring))))

projects/miragesdk/src/fdd/share.ml

@@ -1,8 +1,34 @@
 open Lwt.Infix
 open Common
 
+let src = Logs.Src.create "fdd/share"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let sleep ?(sleep_t=0.01) () =
+  let sleep_t = min sleep_t 1. in
+  Lwt_unix.yield () >>= fun () ->
+  Lwt_unix.sleep sleep_t
+
+let retry ?(timeout=5. *. 60.) ?(sleep_t=0.) fn =
+  let sleep_t = max sleep_t 0.001 in
+  let time = Unix.gettimeofday in
+  let t = time () in
+  let str i = Fmt.strf "%d, %.3fs" i (time () -. t) in
+  let rec aux i =
+    if time () -. t > timeout then fn ()
+    else
+      Lwt.catch fn (fun ex ->
+          Log.debug (fun f -> f "retry ex: %a" Fmt.exn ex);
+          let sleep_t = sleep_t *. (1. +. float i ** 2.) in
+          sleep ~sleep_t () >>= fun () ->
+          Log.debug (fun f -> f "Test.retry %s" (str i));
+          aux (i+1)
+        )
+  in
+  aux 0
+
 let f ~socket ~share =
-  connect socket >>= fun fd ->
+  retry (fun () -> connect socket) >>= fun fd ->
   let oc = Lwt_io.of_fd ~mode:Lwt_io.Output fd in
   Lwt_io.write_line oc share >>= fun () ->
   Lwt_io.close oc