diff --git a/projects/miragesdk/src/fdd/Dockerfile b/projects/miragesdk/src/fdd/Dockerfile index 99712134e..452205643 100644 --- a/projects/miragesdk/src/fdd/Dockerfile +++ b/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 diff --git a/projects/miragesdk/src/fdd/exec.ml b/projects/miragesdk/src/fdd/exec.ml new file mode 100644 index 000000000..14fda1c7f --- /dev/null +++ b/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) diff --git a/projects/miragesdk/src/fdd/exec.mli b/projects/miragesdk/src/fdd/exec.mli new file mode 100644 index 000000000..ae0ec340f --- /dev/null +++ b/projects/miragesdk/src/fdd/exec.mli @@ -0,0 +1 @@ +val f: (string * int list) list -> string list -> unit Lwt.t diff --git a/projects/miragesdk/src/fdd/fdd.ml b/projects/miragesdk/src/fdd/fdd.ml index 4b08874ce..1528655f9 100644 --- a/projects/miragesdk/src/fdd/fdd.ml +++ b/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 \ + :[: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 \ + :[: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 diff --git a/projects/miragesdk/src/fdd/jbuild b/projects/miragesdk/src/fdd/jbuild index 63a08dee6..31ba7d22a 100644 --- a/projects/miragesdk/src/fdd/jbuild +++ b/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)))) \ No newline at end of file + fmt.cli logs.fmt fmt.tty logs.cli astring)))) diff --git a/projects/miragesdk/src/fdd/share.ml b/projects/miragesdk/src/fdd/share.ml index c5859c823..966bc9b4e 100644 --- a/projects/miragesdk/src/fdd/share.ml +++ b/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