Protect shared cache using landlock

bin/action_runner.ml

@@ -1,27 +1,147 @@
 open Import
 
 let name = Action_runner_name.of_string "action-runner"
+let dune_prog () = Util.resolve_program_path Sys.executable_name
 
-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 ]
-;;
+module Backend = struct
+  type t =
+    | Bwrap
+    | Landlock
 
-let has_directory_component prog =
-  String.exists prog ~f:(function
-    | '/' | '\\' -> true
-    | _ -> false)
-;;
+  let equal a b = Poly.equal (a : t) b
+  let all = [ Bwrap; Landlock ]
 
-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
-;;
+  let to_string = function
+    | Bwrap -> "bwrap"
+    | Landlock -> "landlock"
+  ;;
+
+  let parse = function
+    | "bwrap" -> Some Bwrap
+    | "landlock" -> Some Landlock
+    | _ -> None
+  ;;
+
+  let conv =
+    let parser s =
+      match parse s with
+      | Some b -> Ok b
+      | None -> Error (`Msg (Printf.sprintf "unknown sandbox backend %S" s))
+    in
+    let printer fmt b = Format.pp_print_string fmt (to_string b) in
+    Arg.conv (parser, printer)
+  ;;
+
+  let available = function
+    | Bwrap -> Bwrap.available ()
+    | Landlock -> Landlock.available ()
+  ;;
+
+  let unavailable_reason = function
+    | Bwrap ->
+      [ Pp.text
+          "bwrap is unavailable: install the bubblewrap package and ensure the binary is \
+           on PATH (Linux only)"
+      ]
+    | Landlock ->
+      [ Pp.text
+          "Landlock is unavailable: requires Linux kernel with the Landlock LSM enabled \
+           and a sufficient ABI version"
+      ]
+  ;;
+end
+
+module Backends = struct
+  (* Canonicalise into chain order (outermost first), deduplicated. The chosen
+     layering is bwrap outer / landlock inner regardless of CLI order. *)
+  let canonicalise bs =
+    List.filter Backend.all ~f:(fun b -> List.mem ~equal:Backend.equal bs b)
+  ;;
+
+  let resolve ~sandbox_actions ~requested =
+    if not sandbox_actions
+    then []
+    else (
+      match requested with
+      | _ :: _ as bs ->
+        List.iter bs ~f:(fun b ->
+          if not (Backend.available b)
+          then
+            User_error.raise
+              ([ Pp.textf
+                   "Sandbox backend %s requested via --sandbox-actions-backend but \
+                    unavailable."
+                   (Backend.to_string b)
+               ]
+               @ Backend.unavailable_reason b));
+        canonicalise bs
+      | [] ->
+        (match Backend.available Landlock, Backend.available Bwrap with
+         | true, _ -> [ Landlock ]
+         | false, true -> [ Bwrap ]
+         | false, false ->
+           User_error.raise
+             [ Pp.text
+                 "--sandbox-actions was requested but no sandbox backend is available on \
+                  this system. Use --sandbox-actions-backend to request a specific \
+                  backend and see the diagnostic, or omit --sandbox-actions."
+             ]))
+  ;;
 
-let create ~where ~config ~sandbox_actions =
+  let path_flag name p = [ name; Path.to_absolute_filename p ]
+
+  let landlock_wrap ~dune_prog ~cache_dir ~deny_read_dirs ~allow_read_dirs argv =
+    Path.mkdir_p cache_dir;
+    List.iter deny_read_dirs ~f:Path.mkdir_p;
+    List.iter allow_read_dirs ~f:Path.mkdir_p;
+    let dune = Path.to_string dune_prog in
+    let argv =
+      List.concat
+        [ [ dune
+          ; "internal"
+          ; "with-landlock"
+          ; "--deny-write"
+          ; Path.to_absolute_filename cache_dir
+          ]
+        ; List.concat_map deny_read_dirs ~f:(path_flag "--deny-read")
+        ; List.concat_map allow_read_dirs ~f:(path_flag "--allow-read")
+        ; "--" :: argv
+        ]
+    in
+    dune, argv
+  ;;
+
+  let bwrap_wrap argv =
+    let { Bwrap.prog; argv } =
+      Bwrap.wrap ~cwd:(Path.to_absolute_filename Path.root) argv
+    in
+    prog, argv
+  ;;
+
+  let compose t ~dune_prog ~worker_argv =
+    let cache_dir = lazy (Lazy.force Dune_cache.Layout.build_cache_dir) in
+    let deny_read_dirs = [ Path.root ] in
+    let allow_read_dirs = [ Path.build Path.Build.root; dune_prog ] in
+    (* Fold from innermost to outermost: reverse the chain, then wrap step by
+       step so the first element of [t] ends up as the outermost. *)
+    List.fold_right
+      t
+      ~init:(Path.to_string dune_prog, worker_argv)
+      ~f:(fun b (_, argv) ->
+        match b with
+        | Backend.Landlock ->
+          landlock_wrap
+            ~dune_prog
+            ~cache_dir:(Lazy.force cache_dir)
+            ~deny_read_dirs
+            ~allow_read_dirs
+            argv
+        | Backend.Bwrap -> bwrap_wrap argv)
+  ;;
+end
+
+let create ~where ~config ~sandbox_actions ~sandbox_actions_backends =
+  let backends = Backends.resolve ~sandbox_actions ~requested:sandbox_actions_backends in
   let pid =
     let env =
       let jobs =
@@ -36,24 +156,16 @@ let create ~where ~config ~sandbox_actions =
       |> Spawn.Env.of_list
     in
     let trace_fd = Dune_trace.duplicate_global_fd () in
-    let prog, argv =
-      let dune_prog = dune_prog () in
-      let worker_argv =
-        [ Path.to_string dune_prog
-        ; "internal"
-        ; "action-runner"
-        ; "start"
-        ; Action_runner_name.to_string name
-        ]
-      in
-      if sandbox_actions
-      then (
-        let { Bwrap.prog; argv } =
-          Bwrap.wrap ~cwd:(Path.to_absolute_filename Path.root) worker_argv
-        in
-        prog, argv)
-      else Path.to_string dune_prog, worker_argv
+    let dune_prog = dune_prog () in
+    let worker_argv =
+      [ Path.to_string dune_prog
+      ; "internal"
+      ; "action-runner"
+      ; "start"
+      ; Action_runner_name.to_string name
+      ]
     in
+    let prog, argv = Backends.compose backends ~dune_prog ~worker_argv in
     let argv =
       let where = Dune_rpc.Where.to_string where in
       argv

bin/action_runner.mli

@@ -1,9 +1,22 @@
 open Import
 
+module Backend : sig
+  type t =
+    | Bwrap
+    | Landlock
+
+  val all : t list
+  val equal : t -> t -> bool
+  val to_string : t -> string
+  val parse : string -> t option
+  val conv : t Arg.conv
+end
+
 val create
   :  where:Dune_rpc.Where.t
   -> config:Dune_config.t
   -> sandbox_actions:bool
+  -> sandbox_actions_backends:Backend.t list
   -> Dune_engine.Action_runner.t
 
 val start_worker : name:string -> where:string -> trace_fd:string option -> unit Fiber.t

bin/bwrap.ml

@@ -5,15 +5,15 @@ type command =
   ; argv : string list
   }
 
-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 ]
+let available () =
+  match Platform.OS.value with
+  | Linux -> Option.is_some (Bin.which ~path:(Env_path.path Env.initial) "bwrap")
+  | _ -> false
 ;;
 
 let prog () =
   match Platform.OS.value with
-  | Linux -> find_in_path_exn "bwrap"
+  | Linux -> Util.find_in_path_exn "bwrap"
   | _ ->
     User_error.raise [ Pp.text "--sandbox-actions is currently only supported on Linux" ]
 ;;

bin/bwrap.mli

@@ -5,6 +5,7 @@ type command =
   ; argv : string list
   }
 
+val available : unit -> bool
 val wrap : cwd:string -> string list -> command
 
 module With_bwrap : sig

bin/common.ml

@@ -627,6 +627,7 @@ module Builder = struct
     ; target_exec : string option
     ; action_runner : bool
     ; sandbox_actions : bool
+    ; sandbox_actions_backends : Action_runner.Backend.t list
     }
 
   let set_no_build t no_build = { t with no_build }
@@ -963,8 +964,23 @@ module Builder = struct
             ~docs
             ~doc:
               (Some
-                 "Run spawned build processes in an external dune action runner wrapped \
-                  with bubblewrap."))
+                 "Run spawned build processes in an external dune action runner under a \
+                  sandbox. The sandbox layering is selected automatically; pass \
+                  --sandbox-actions-backend to override."))
+    and+ sandbox_actions_backends =
+      Arg.(
+        value
+        & opt_all Action_runner.Backend.conv []
+        & info
+            [ "sandbox-actions-backend" ]
+            ~docs
+            ~docv:"BACKEND"
+            ~doc:
+              (Some
+                 "Use this sandbox backend for --sandbox-actions. Repeatable; when \
+                  passed more than once the backends are stacked (currently bwrap \
+                  outermost, landlock inside). If unset, all available backends are \
+                  selected automatically."))
     and+ action_runner =
       Arg.(
         value
@@ -1019,6 +1035,7 @@ module Builder = struct
     ; target_exec
     ; action_runner
     ; sandbox_actions
+    ; sandbox_actions_backends
     }
   ;;
 
@@ -1060,6 +1077,7 @@ module Builder = struct
         ; target_exec
         ; action_runner
         ; sandbox_actions
+        ; sandbox_actions_backends
         }
     =
     No_build.equal t.no_build no_build
@@ -1101,6 +1119,10 @@ module Builder = struct
     && Option.equal String.equal t.target_exec target_exec
     && Bool.equal t.action_runner action_runner
     && Bool.equal t.sandbox_actions sandbox_actions
+    && List.equal
+         Action_runner.Backend.equal
+         t.sandbox_actions_backends
+         sandbox_actions_backends
   ;;
 end
 
@@ -1393,7 +1415,8 @@ let init_with_root_and_rpc ~(root : Workspace_root.t) ~rpc_build (builder : Buil
            (Action_runner.create
               ~where:(Lazy.force where)
               ~config
-              ~sandbox_actions:c.builder.sandbox_actions)
+              ~sandbox_actions:c.builder.sandbox_actions
+              ~sandbox_actions_backends:c.builder.sandbox_actions_backends)
        else None)
   in
   let rpc =

bin/dune

@@ -7,6 +7,9 @@
  (enabled_if
   (<> %{profile} dune-bootstrap))
  (root_module root)
+ (foreign_stubs
+  (language c)
+  (names landlock_stubs))
  (libraries
   memo
   ocaml

bin/internal.ml

@@ -230,6 +230,7 @@ let group =
     ; Internal_digest_db.command
     ; Internal_action_runner.group
     ; Bwrap.With_bwrap.command
+    ; Landlock.With_landlock.command
     ; latest_lang_version
     ; bootstrap_info
     ; Sexp_pp.command