feature: bring back action runners

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

feature: allow action runners to write to trace

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

action runners

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

Author: rgrinberg

bin/common.ml

@@ -60,6 +60,7 @@ end
 
 let default_build_dir = "_build"
 let trace_file_name = "trace.csexp"
+let action_runner_name = Dune_engine.Action_runner.Name.of_string "action-runner"
 
 let find_default_trace_file () =
   let trace_file = Filename.concat default_build_dir trace_file_name in
@@ -625,6 +626,8 @@ module Builder = struct
     ; allow_builds : bool
     ; default_root_is_cwd : bool
     ; target_exec : string option
+    ; action_runner : bool
+    ; sandbox_actions : bool
     }
 
   let set_no_build t no_build = { t with no_build }
@@ -952,6 +955,25 @@ module Builder = struct
         & info
             [ "stop-on-first-error" ]
             ~doc:(Some "Stop the build as soon as an error is encountered."))
+    and+ sandbox_actions =
+      Arg.(
+        value
+        & flag
+        & info
+            [ "sandbox-actions" ]
+            ~docs
+            ~doc:
+              (Some
+                 "Run spawned build processes in an external dune action runner wrapped \
+                  with bubblewrap."))
+    and+ action_runner =
+      Arg.(
+        value
+        & flag
+        & info
+            [ "action-runner" ]
+            ~docs
+            ~doc:(Some "Run spawned build processes in an external dune action runner."))
     in
     { no_build
     ; debug_dep_path
@@ -996,6 +1018,8 @@ module Builder = struct
     ; allow_builds = true
     ; default_root_is_cwd = false
     ; target_exec
+    ; action_runner
+    ; sandbox_actions
     }
   ;;
 
@@ -1035,6 +1059,8 @@ module Builder = struct
         ; allow_builds
         ; default_root_is_cwd
         ; target_exec
+        ; action_runner
+        ; sandbox_actions
         }
     =
     No_build.equal t.no_build no_build
@@ -1074,6 +1100,8 @@ module Builder = struct
     && Bool.equal t.allow_builds allow_builds
     && Bool.equal t.default_root_is_cwd default_root_is_cwd
     && Option.equal String.equal t.target_exec target_exec
+    && Bool.equal t.action_runner action_runner
+    && Bool.equal t.sandbox_actions sandbox_actions
   ;;
 end
 
@@ -1082,13 +1110,16 @@ type t =
   ; root : Workspace_root.t
   ; rpc :
       [ `Allow of Dune_lang.Dep_conf.t Dune_rpc_impl.Server.t Lazy.t | `Forbid_builds ]
+  ; action_runner : Dune_engine.Action_runner.t option
   }
 
 let capture_outputs t = t.builder.capture_outputs
 let root t = t.root
 let watch t = t.builder.watch
 let x t = t.builder.workspace_config.x
 let file_watcher t = t.builder.file_watcher
+let sandbox_actions t = t.builder.sandbox_actions
+let action_runner t = t.action_runner
 let prefix_target t s = t.root.reach_from_root_prefix ^ s
 
 let rpc t =
@@ -1181,7 +1212,7 @@ let build (root : Workspace_root.t) (builder : Builder.t) =
            Dune_rpc_impl.Server.create ~lock_timeout ~registry ~root:root.dir))
     else `Forbid_builds
   in
-  { builder; root; rpc }
+  { builder; root; rpc; action_runner = None }
 ;;
 
 let maybe_init_cache (cache_config : Dune_cache.Config.t) =
@@ -1288,7 +1319,39 @@ let init_with_root ~(root : Workspace_root.t) (builder : Builder.t) =
       , Dyn.string (Path.to_string (Lazy.force Dune_cache.Layout.build_cache_dir)) )
     ];
   Dune_cache.Shared.config := maybe_init_cache cache_config;
-  Dune_rules.Main.init ~sandboxing_preference:config.sandboxing_preference ();
+  let action_runner =
+    match
+      c.builder.allow_builds, c.builder.action_runner || c.builder.sandbox_actions
+    with
+    | false, _ -> None
+    | true, false -> None
+    | true, true ->
+      let server =
+        match rpc c with
+        | `Allow server -> Dune_rpc_impl.Server.action_runner server
+        | `Forbid_builds ->
+          Code_error.raise "action runners require the dune RPC server" []
+      in
+      Some (Dune_engine.Action_runner.create server ~name:action_runner_name)
+  in
+  let c = { c with action_runner } in
+  let action_runners =
+    match action_runner with
+    | None -> fun () -> []
+    | Some runner ->
+      Dune_engine.Process.Runner.set (fun request ->
+        Some
+          (Dune_engine.Action_runner.exec_process
+             runner
+             ~run_id:(Dune_scheduler.Scheduler.current_run_id ())
+             request));
+      fun () -> if Dune_engine.Action_runner.started runner then [ runner ] else []
+  in
+  Dune_rules.Main.init
+    ~sandbox_actions:c.builder.sandbox_actions
+    ~sandboxing_preference:config.sandboxing_preference
+    ~action_runners
+    ();
   Only_packages.Clflags.set c.builder.only_packages;
   Report_error.print_memo_stacks := c.builder.debug_dep_path;
   Dune_engine.Clflags.report_errors_config := c.builder.report_errors_config;

bin/common.mli

@@ -18,6 +18,8 @@ val rpc
 val watch_exclusions : t -> string list
 val watch : t -> Dune_rpc_impl.Watch_mode_config.t
 val file_watcher : t -> Dune_scheduler.Scheduler.Run.file_watcher
+val sandbox_actions : t -> bool
+val action_runner : t -> Dune_engine.Action_runner.t option
 val prefix_target : t -> string -> string
 val find_default_trace_file : unit -> string
 

bin/internal.ml

@@ -111,6 +111,7 @@ let group =
     (Cmd.info "internal")
     [ Internal_dump.command
     ; Internal_digest_db.command
+    ; Internal_action_runner.group
     ; latest_lang_version
     ; bootstrap_info
     ; Sexp_pp.command

bin/internal_action_runner.ml

@@ -0,0 +1,38 @@
+open Import
+
+let start =
+  let+ builder = Common.Builder.term_no_trace_no_pkg
+  and+ name =
+    Arg.(required & pos 0 (some string) None (Arg.info [] ~docv:"NAME" ~doc:None))
+  and+ where =
+    Arg.(required & pos 1 (some string) None (Arg.info [] ~docv:"WHERE" ~doc:None))
+  and+ trace_fd =
+    Arg.(value & opt (some string) None (Arg.info [ "trace-fd" ] ~docv:"FD" ~doc:None))
+  in
+  let builder = Common.Builder.forbid_builds builder in
+  let common, config = Common.init builder in
+  let name = Dune_engine.Action_runner.Name.parse_string_exn (Loc.none, name) in
+  Option.iter trace_fd ~f:(fun fd ->
+    Dune_trace.set_global_inherited_fd_arg fd;
+    Dune_trace.set_common_args
+      [ "action_runner", Sexp.Atom (Dune_engine.Action_runner.Name.to_string name) ]);
+  let where =
+    match
+      Dune_rpc.Conv.of_sexp
+        Dune_rpc.Where.sexp
+        ~version:Dune_rpc.Version.latest
+        (Sexp.Atom where)
+    with
+    | Ok where -> where
+    | Error err ->
+      User_error.raise
+        [ Pp.textf "invalid action runner RPC address %S" where
+        ; Pp.text (Dyn.to_string (Dune_rpc.Conv.dyn_of_error err))
+        ]
+  in
+  Scheduler_setup.go_without_rpc_server ~common ~config (fun () ->
+    Dune_engine.Action_runner.Worker.start ~name ~where)
+;;
+
+let start = Cmd.v (Cmd.info "start") start
+let group = Cmd.group (Cmd.info "action-runner") [ start ]

bin/internal_action_runner.mli

@@ -0,0 +1,3 @@
+open Import
+
+val group : unit Cmd.t

bin/scheduler_setup.ml

@@ -71,6 +71,134 @@ let rpc server =
   }
 ;;
 
+let with_action_runner_worker ~(common : Common.t) f =
+  match Common.action_runner common with
+  | None -> f ()
+  | Some action_runner ->
+    let open Fiber.O in
+    let server =
+      match Common.rpc common with
+      | `Allow server -> server
+      | `Forbid_builds -> Code_error.raise "action runners require the dune RPC server" []
+    in
+    let find_in_path_exn prog =
+      match Bin.which ~path:(Env_path.path Env.initial) prog with
+      | Some path -> path
+      | None -> User_error.raise [ Pp.textf "unable to find %s in PATH" prog ]
+    in
+    let has_directory_component prog =
+      String.exists prog ~f:(function
+        | '/' | '\\' -> true
+        | _ -> false)
+    in
+    let dune_prog =
+      let prog = Sys.executable_name in
+      if Filename.is_relative prog && not (has_directory_component prog)
+      then find_in_path_exn prog
+      else Path.of_filename_relative_to_initial_cwd prog
+    in
+    let jobs = Int.to_string !Dune_rules.Clflags.concurrency in
+    let env =
+      Env.initial
+      |> Env.add ~var:"DUNE_JOBS" ~value:jobs
+      |> Env.add ~var:"DUNE_BUILD_DIR" ~value:(Path.Build.to_string Path.Build.root)
+      |> Env.to_unix
+      |> Spawn.Env.of_list
+    in
+    let where = Dune_rpc_impl.Server.listening_address server in
+    let monitor_pool = Fiber.Pool.create () in
+    let started_worker = ref (None : Pid.t option) in
+    let worker_command runner =
+      let worker_argv =
+        [ Path.to_string dune_prog
+        ; "internal"
+        ; "action-runner"
+        ; "start"
+        ; Dune_engine.Action_runner.Name.to_string (Dune_engine.Action_runner.name runner)
+        ; Dune_rpc.Where.to_string where
+        ]
+      in
+      if Common.sandbox_actions common
+      then (
+        let bwrap =
+          match Platform.OS.value with
+          | Linux -> find_in_path_exn "bwrap"
+          | _ ->
+            User_error.raise
+              [ Pp.text "--sandbox-actions is currently only supported on Linux" ]
+        in
+        let cwd = Path.to_absolute_filename Path.root in
+        let shared_cache_bindings =
+          let build_cache_dir = Lazy.force Dune_cache.Layout.build_cache_dir in
+          Path.mkdir_p build_cache_dir;
+          let build_cache_dir = Path.to_string build_cache_dir in
+          [ "--ro-bind"; build_cache_dir; build_cache_dir ]
+        in
+        ( Path.to_string bwrap
+        , [ Path.to_string bwrap; "--die-with-parent"; "--bind"; "/"; "/" ]
+          @ shared_cache_bindings
+          @ [ "--proc"; "/proc"; "--dev"; "/dev"; "--chdir"; cwd; "--" ]
+          @ worker_argv ))
+      else Path.to_string dune_prog, worker_argv
+    in
+    let close_trace_fd trace_fd = Option.iter trace_fd ~f:Fd.close in
+    let start_worker ~runner =
+      let* () = Root.Rpc.Global.ensure_ready () in
+      let prog, argv = worker_command runner in
+      let trace_fd = Dune_trace.duplicate_global_fd () in
+      let argv =
+        argv
+        @
+        match trace_fd with
+        | None -> []
+        | Some fd ->
+          let fd_arg : int = Obj.magic (Fd.unsafe_to_unix_file_descr fd) in
+          [ "--trace-fd"; Int.to_string fd_arg ]
+      in
+      let pid =
+        match Spawn.spawn ~env ~prog ~argv ~setpgid:Spawn.Pgid.new_process_group () with
+        | pid ->
+          close_trace_fd trace_fd;
+          let pid = Pid.of_int pid in
+          Dune_trace.emit Action (fun () ->
+            Dune_trace.Event.Action.runner_spawn
+              ~name:
+                (Dune_engine.Action_runner.Name.to_string
+                   (Dune_engine.Action_runner.name runner))
+              ~pid);
+          pid
+        | exception exn ->
+          close_trace_fd trace_fd;
+          raise exn
+      in
+      started_worker := Some pid;
+      Fiber.Pool.task monitor_pool ~f:(fun () ->
+        let* _status = Scheduler.wait_for_process pid ~is_process_group_leader:true in
+        let* () = Dune_engine.Action_runner.disconnect runner in
+        (match !started_worker with
+         | Some current_pid when Pid.equal current_pid pid -> started_worker := None
+         | None | Some _ -> ());
+        Fiber.return ())
+    in
+    let terminate_worker pid =
+      match Unix.kill (-Pid.to_int pid) Sys.sigterm with
+      | () -> Fiber.return ()
+      | exception Unix.Unix_error (Unix.ESRCH, _, _) -> Fiber.return ()
+    in
+    Dune_engine.Action_runner.set_start action_runner start_worker;
+    Fiber.fork_and_join_unit
+      (fun () -> Fiber.Pool.run monitor_pool)
+      (fun () ->
+         Fiber.finalize f ~finally:(fun () ->
+           let worker = !started_worker in
+           let* () =
+             match worker with
+             | None -> Fiber.return ()
+             | Some pid -> terminate_worker pid
+           in
+           Fiber.Pool.close monitor_pool))
+;;
+
 let no_build_no_rpc ~config:dune_config f =
   let config =
     Dune_config.for_scheduler dune_config ~print_ctrl_c_warning:true ~watch_exclusions:[]
@@ -92,7 +220,10 @@ let go_without_rpc_server ~(common : Common.t) ~config:dune_config f =
 let go_with_rpc_server ~common ~config f =
   let f =
     match Common.rpc common with
-    | `Allow server -> fun () -> Root.Rpc.Global.with_background_rpc (rpc server) f
+    | `Allow server ->
+      fun () ->
+        Root.Rpc.Global.with_background_rpc (rpc server) (fun () ->
+          with_action_runner_worker ~common f)
     | `Forbid_builds -> f
   in
   go_without_rpc_server ~common ~config f
@@ -119,7 +250,7 @@ let go_with_rpc_server_and_console_status_reporting
     Root.Rpc.Global.with_background_rpc server
     @@ fun () ->
     let* () = Root.Rpc.Global.ensure_ready () in
-    run ()
+    with_action_runner_worker ~common run
   in
   Run.go
     config