sdk: add fdd exec to map socketpair shares to local fds

To enable this:

```
$ fdd init &
$ fdd share /tmp/foo

$ fdd exec -m /tmp/foo:1:2 -- echo hello world!

$ fdd exec -m /tmp/foo:0 -- cat
hello world!
```

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

projects/miragesdk/src/fdd/Dockerfile

@@ -1,6 +1,6 @@
 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 -p /out/bin

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