diff --git a/projects/miragesdk/examples/fdd.yml b/projects/miragesdk/examples/fdd.yml new file mode 100644 index 000000000..5e0d04b98 --- /dev/null +++ b/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 diff --git a/projects/miragesdk/src/fdd/Dockerfile b/projects/miragesdk/src/fdd/Dockerfile index 01ef77d00..452205643 100644 --- a/projects/miragesdk/src/fdd/Dockerfile +++ b/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"] diff --git a/projects/miragesdk/src/fdd/Makefile b/projects/miragesdk/src/fdd/Makefile index 815ccd890..2a4b5d48d 100644 --- a/projects/miragesdk/src/fdd/Makefile +++ b/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) 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