Add support for hard links

CHANGES.md

@@ -92,6 +92,8 @@ Unreleased
 - If an .ml file is not used by an executable, Dune no longer report
   parsing error in this file (#...., @jeremiedimino)
 
+- Add support for sandboxing using hard links (#4360, @snowleopard)
+
 2.8.2 (21/01/2021)
 ------------------
 

doc/concepts.rst

@@ -814,9 +814,9 @@ directory, filtering it to only contain the files that were declared as
 dependencies. Then we run the action in that directory, and then we copy
 the targets back to the build directory.
 
-You can configure dune to use sandboxing modes ``symlink`` or ``copy``, which
-determines how the individual files are populated (they will be symlinked or
-copied into the sandbox directory).
+You can configure dune to use sandboxing modes ``symlink``, ``hardlink`` or
+``copy``, which determines how the individual files are populated (they will be
+symlinked, hardlinked or copied into the sandbox directory).
 
 This approach is very simple and portable, but that comes with
 certain limitations:

src/dune_engine/action.ml

@@ -136,6 +136,7 @@ let fold_one_step t ~init:acc ~f =
   | Cat _
   | Copy _
   | Symlink _
+  | Hardlink _
   | Copy_and_add_line_directive _
   | System _
   | Bash _
@@ -185,6 +186,7 @@ let rec is_dynamic = function
   | Cat _
   | Copy _
   | Symlink _
+  | Hardlink _
   | Copy_and_add_line_directive _
   | Write_file _
   | Rename _
@@ -215,18 +217,26 @@ let prepare_managed_paths ~link ~sandboxed deps =
   Progn steps
 
 let link_function ~(mode : Sandbox_mode.some) : path -> target -> t =
+  let win32_error mode =
+    let mode = Sandbox_mode.to_string (Some mode) in
+    Code_error.raise
+      (sprintf
+         "Don't have %ss on win32, but [%s] sandboxing mode was selected. To \
+          use emulation via copy, the [copy] sandboxing mode should be \
+          selected."
+         mode mode)
+      []
+  in
   match mode with
-  | Symlink ->
-    if Sys.win32 then
-      Code_error.raise
-        "Don't have symlinks on win32, but [Symlink] sandboxing mode was \
-         selected. To use emulation via copy, the [Copy] sandboxing mode \
-         should be selected."
-        []
-    else
-      fun a b ->
-    Symlink (a, b)
+  | Symlink -> (
+    match Sys.win32 with
+    | true -> win32_error mode
+    | false -> fun a b -> Symlink (a, b))
   | Copy -> fun a b -> Copy (a, b)
+  | Hardlink -> (
+    match Sys.win32 with
+    | true -> win32_error mode
+    | false -> fun a b -> Hardlink (a, b))
 
 let maybe_sandbox_path f p =
   match Path.as_in_build_dir p with
@@ -266,6 +276,7 @@ let is_useful_to distribute memoize =
     | Cat _ -> memoize
     | Copy _ -> memoize
     | Symlink _ -> false
+    | Hardlink _ -> false
     | Copy_and_add_line_directive _ -> memoize
     | Write_file _ -> distribute
     | Rename _ -> memoize

src/dune_engine/action_ast.ml

@@ -247,6 +247,7 @@ struct
     | Cat x -> List [ atom "cat"; path x ]
     | Copy (x, y) -> List [ atom "copy"; path x; target y ]
     | Symlink (x, y) -> List [ atom "symlink"; path x; target y ]
+    | Hardlink (x, y) -> List [ atom "hardlink"; path x; target y ]
     | Copy_and_add_line_directive (x, y) ->
       List [ atom "copy#"; path x; target y ]
     | System x -> List [ atom "system"; string x ]

src/dune_engine/action_dune_lang.ml

@@ -55,6 +55,7 @@ let ensure_at_most_one_dynamic_run ~loc action =
     | Cat _
     | Copy _
     | Symlink _
+    | Hardlink _
     | Copy_and_add_line_directive _
     | System _
     | Bash _

src/dune_engine/action_exec.ml

@@ -246,6 +246,29 @@ let rec exec t ~ectx ~eenv =
         )
       | exception _ -> Unix.symlink src dst);
     Fiber.return Done
+  | Hardlink (src, dst) ->
+    (* CR-someday amokhov: Instead of always falling back to copying, we could
+       detect if hardlinking works on Windows and if yes, use it. We do this in
+       the Dune cache implementation, so we can share some code. *)
+    (match Sys.win32 with
+    | true -> Io.copy_file ~src ~dst:(Path.build dst) ()
+    | false -> (
+      let rec follow_symlinks name =
+        let stats = Unix.lstat name in
+        match stats.st_kind with
+        | S_LNK ->
+          let link_name = Unix.readlink name in
+          let name = Filename.concat (Filename.dirname name) link_name in
+          follow_symlinks name
+        | _ -> name
+      in
+      let src = follow_symlinks (Path.to_string src) in
+      let dst = Path.Build.to_string dst in
+      try Unix.link src dst with
+      | Unix.Unix_error (Unix.EEXIST, _, _) ->
+        Unix.unlink dst;
+        Unix.link src dst));
+    Fiber.return Done
   | Copy_and_add_line_directive (src, dst) ->
     Io.with_file_in src ~f:(fun ic ->
         Path.build dst

src/dune_engine/action_intf.ml

@@ -36,6 +36,7 @@ module type Ast = sig
     | Cat of path
     | Copy of path * target
     | Symlink of path * target
+    | Hardlink of path * target
     | Copy_and_add_line_directive of path * target
     | System of string
     | Bash of string

src/dune_engine/action_mapper.ml

@@ -33,6 +33,7 @@ module Make (Src : Action_intf.Ast) (Dst : Action_intf.Ast) = struct
     | Cat x -> Cat (f_path ~dir x)
     | Copy (x, y) -> Copy (f_path ~dir x, f_target ~dir y)
     | Symlink (x, y) -> Symlink (f_path ~dir x, f_target ~dir y)
+    | Hardlink (x, y) -> Hardlink (f_path ~dir x, f_target ~dir y)
     | Copy_and_add_line_directive (x, y) ->
       Copy_and_add_line_directive (f_path ~dir x, f_target ~dir y)
     | System x -> System (f_string ~dir x)

src/dune_engine/build_system.ml

@@ -1326,23 +1326,28 @@ end = struct
   let select_sandbox_mode (config : Sandbox_config.t) ~loc
       ~sandboxing_preference =
     let evaluate_sandboxing_preference preference =
+      let use_copy_on_windows mode =
+        match Sandbox_mode.Set.mem config Sandbox_mode.copy with
+        | true ->
+          Some
+            (if Sys.win32 then
+              Sandbox_mode.copy
+            else
+              mode)
+        | false ->
+          User_error.raise ~loc
+            [ Pp.textf
+                "This rule requires sandboxing with %ss, but that won't work \
+                 on Windows."
+                (Sandbox_mode.to_string mode)
+            ]
+      in
       match Sandbox_mode.Set.mem config preference with
       | false -> None
       | true -> (
         match preference with
-        | Some Symlink ->
-          if Sandbox_mode.Set.mem config Sandbox_mode.copy then
-            Some
-              (if Sys.win32 then
-                Sandbox_mode.copy
-              else
-                Sandbox_mode.symlink)
-          else
-            User_error.raise ~loc
-              [ Pp.text
-                  "This rule requires sandboxing with symlinks, but that won't \
-                   work on Windows."
-              ]
+        | Some Symlink -> use_copy_on_windows Sandbox_mode.symlink
+        | Some Hardlink -> use_copy_on_windows Sandbox_mode.hardlink
         | _ -> Some preference)
     in
     match
@@ -1376,7 +1381,7 @@ end = struct
 
   (* The current version of the rule digest scheme. We should increment it when
      making any changes to the scheme, to avoid collisions. *)
-  let rule_digest_version = 2
+  let rule_digest_version = 3
 
   let compute_rule_digest (rule : Rule.t) ~deps ~action ~sandbox_mode =
     let env = Rule.effective_env rule in

src/dune_engine/dep.ml

@@ -42,18 +42,13 @@ module T = struct
 
   let encode t =
     let open Dune_lang.Encoder in
-    let sandbox_mode (mode : Sandbox_mode.t) =
-      match mode with
-      | None -> "none"
-      | Some Copy -> "copy"
-      | Some Symlink -> "symlink"
-    in
     let sandbox_config (config : Sandbox_config.t) =
       list
         (fun x -> x)
         (List.filter_map Sandbox_mode.all ~f:(fun mode ->
              if not (Sandbox_config.mem config mode) then
-               Some (pair string string ("disallow", sandbox_mode mode))
+               Some
+                 (pair string string ("disallow", Sandbox_mode.to_string mode))
              else
                None))
     in

src/dune_engine/sandbox_mode.ml

@@ -3,13 +3,17 @@ open! Stdune
 type some =
   | Symlink
   | Copy
+  | Hardlink
 
 let compare_some a b =
   match (a, b) with
   | Symlink, Symlink -> Eq
   | Symlink, _ -> Lt
   | _, Symlink -> Gt
   | Copy, Copy -> Eq
+  | Copy, _ -> Lt
+  | _, Copy -> Gt
+  | Hardlink, Hardlink -> Eq
 
 type t = some option
 
@@ -29,6 +33,7 @@ module Dict = struct
     { none : 'a
     ; symlink : 'a
     ; copy : 'a
+    ; hardlink : 'a
     }
 
   let compare compare x y =
@@ -39,16 +44,22 @@ module Dict = struct
       | Gt -> Gt
     in
     compare_k x.none y.none (fun () ->
-        compare_k x.symlink y.symlink (fun () -> compare x.copy y.copy))
+        compare_k x.symlink y.symlink (fun () ->
+            compare_k x.copy y.copy (fun () -> compare x.hardlink y.hardlink)))
 
   let of_func (f : key -> _) =
-    { none = f None; symlink = f (Some Symlink); copy = f (Some Copy) }
+    { none = f None
+    ; symlink = f (Some Symlink)
+    ; copy = f (Some Copy)
+    ; hardlink = f (Some Hardlink)
+    }
 
-  let get { none; symlink; copy } (key : key) =
+  let get { none; symlink; copy; hardlink } (key : key) =
     match key with
     | None -> none
     | Some Copy -> copy
     | Some Symlink -> symlink
+    | Some Hardlink -> hardlink
 end
 
 module Set = struct
@@ -73,27 +84,34 @@ module Set = struct
     { none = x.none && y.none
     ; copy = x.copy && y.copy
     ; symlink = x.symlink && y.symlink
+    ; hardlink = x.hardlink && y.hardlink
     }
 end
 
 (* these should be listed in the default order of preference *)
-let all = [ None; Some Symlink; Some Copy ]
+let all = [ None; Some Symlink; Some Copy; Some Hardlink ]
 
 let none = None
 
 let symlink = Some Symlink
 
 let copy = Some Copy
 
-let error = Error "invalid sandboxing mode, must be 'none', 'symlink' or 'copy'"
+let hardlink = Some Hardlink
+
+let error =
+  Error
+    "invalid sandboxing mode, must be 'none', 'symlink', 'copy' or 'hardlink'"
 
 let of_string = function
   | "none" -> Ok None
-  | "symlink" -> Ok (Some Symlink : t)
+  | "symlink" -> Ok (Some Symlink)
   | "copy" -> Ok (Some Copy)
+  | "hardlink" -> Ok (Some Hardlink)
   | _ -> error
 
 let to_string = function
   | None -> "none"
   | Some Symlink -> "symlink"
   | Some Copy -> "copy"
+  | Some Hardlink -> "hardlink"

src/dune_engine/sandbox_mode.mli

@@ -10,6 +10,7 @@ open! Stdune
 type some =
   | Symlink
   | Copy
+  | Hardlink
 
 type t = some option
 
@@ -24,6 +25,7 @@ module Dict : sig
     { none : 'a
     ; symlink : 'a
     ; copy : 'a
+    ; hardlink : 'a
     }
 
   val compare : ('a -> 'a -> Ordering.t) -> 'a t -> 'a t -> Ordering.t
@@ -57,6 +59,8 @@ val symlink : t
 
 val copy : t
 
+val hardlink : t
+
 val of_string : string -> (t, string) Result.t
 
 val to_string : t -> string

src/dune_rules/action_to_sh.ml

@@ -57,6 +57,7 @@ let simplify act =
     | Copy (x, y) -> Run ("cp", [ x; y ]) :: acc
     | Symlink (x, y) ->
       Run ("ln", [ "-s"; x; y ]) :: Run ("rm", [ "-f"; y ]) :: acc
+    | Hardlink (x, y) -> Run ("ln", [ x; y ]) :: Run ("rm", [ "-f"; y ]) :: acc
     | Copy_and_add_line_directive (x, y) ->
       Redirect_out
         ( echo (Utils.line_directive ~filename:x ~line_number:1) @ [ cat x ]

src/dune_rules/action_unexpanded.ml

@@ -453,6 +453,10 @@ let rec expand (t : Action_dune_lang.t) : Action.t Action_expander.t =
     let+ x = E.dep x
     and+ y = E.target y in
     O.Symlink (x, y)
+  | Hardlink (x, y) ->
+    let+ x = E.dep x
+    and+ y = E.target y in
+    O.Hardlink (x, y)
   | Copy_and_add_line_directive (x, y) ->
     let+ x = E.dep x
     and+ y = E.target y in

test/blackbox-tests/test-cases/dune-cache/trim.t/run.t

@@ -64,15 +64,16 @@ end up in a situation where the same hash means something different
 before and after the change, which is bad. To reduce the risk, we
 inject a version number into rule digests.
 
-If you see the bellow test breaking, then you probably accidentally
+If you see the below test breaking, then you probably accidentally
 changed the way the digest is computed and you should increase this
 version number. This number is stored in the [rule_digest_version]
 variable in [build_system.ml].
 
-  $ cat $PWD/.xdg-cache/dune/db/meta/v4/70/70e20e84ad3f1df3a3b6e2fabcc6465b
-  ((8:metadata)(5:files(16:default/target_b32:8a53bfae3829b48866079fa7f2d97781)))
+  $ (cd "$PWD/.xdg-cache/dune/db/meta/v4"; grep -rws . -e 'metadata' | sort)
+  ./a5/a5577fffaa751cd2aa8b2345ac11119a:((8:metadata)(5:files(16:default/target_a32:5637dd9730e430c7477f52d46de3909c)))
+  ./c5/c5af296726141def07847e5510a680c6:((8:metadata)(5:files(16:default/target_b32:8a53bfae3829b48866079fa7f2d97781)))
 
-  $ dune_cmd stat size $PWD/.xdg-cache/dune/db/meta/v4/70/70e20e84ad3f1df3a3b6e2fabcc6465b
+  $ dune_cmd stat size "$PWD/.xdg-cache/dune/db/meta/v4/a5/a5577fffaa751cd2aa8b2345ac11119a"
   79
 
 Trimming the cache at this point should not remove anything, as all