Improve error messages on unreadable targets

CHANGES.md

@@ -108,6 +108,10 @@ Unreleased
   implementation is based on Jenga's cache library, which was thoroughly tested
   on large-scale builds. Using Jenga's cache library will also make it easier
   for us to port Jenga's cloud cache to Dune. (#4443, #4465, Andrey Mokhov)
+
+- More informative error message when Dune can't read a target that's supposed 
+  to be produced by the action. Old message is still produced on ENOENT, but other
+  errors deserve a more detailed report. (#4501, @aalekseyev)
 
 2.9.0 (unreleased)
 ------------------

otherlibs/stdune-unstable/digest.ml

@@ -53,6 +53,12 @@ let file_with_stats path (stats : Unix.stats) =
   match stats.st_kind with
   | S_DIR ->
     generic (stats.st_size, stats.st_perm, stats.st_mtime, stats.st_ctime)
-  | _ ->
+  | S_BLK
+  | S_CHR
+  | S_LNK
+  | S_FIFO
+  | S_SOCK ->
+    failwith "Unexpected file kind"
+  | S_REG ->
     let executable = stats.st_perm land 0o100 <> 0 in
     file_with_executable_bit ~executable path

otherlibs/stdune-unstable/string.ml

@@ -69,6 +69,11 @@ let drop_prefix s ~prefix =
   else
     None
 
+let drop_prefix_if_exists s ~prefix =
+  match drop_prefix s ~prefix with
+  | None -> s
+  | Some s -> s
+
 let drop_suffix s ~suffix =
   if is_suffix s ~suffix then
     if length s = length suffix then
@@ -78,6 +83,11 @@ let drop_suffix s ~suffix =
   else
     None
 
+let drop_suffix_if_exists s ~suffix =
+  match drop_suffix s ~suffix with
+  | None -> s
+  | Some s -> s
+
 let extract_words s ~is_word_char =
   let rec skip_blanks i =
     if i = length s then

otherlibs/stdune-unstable/string.mli

@@ -31,8 +31,12 @@ val split_n : t -> int -> t * t
 
 val drop_prefix : t -> prefix:t -> t option
 
+val drop_prefix_if_exists : t -> prefix:t -> t
+
 val drop_suffix : t -> suffix:t -> t option
 
+val drop_suffix_if_exists : t -> suffix:t -> t
+
 (** These only change ASCII characters *)
 val capitalize : t -> t
 

src/dune_engine/build_system.ml

@@ -435,10 +435,11 @@ let t () = Fdecl.get t
 
 let errors () = (t ()).errors
 
-let pp_paths set =
-  Pp.enumerate (Path.Set.to_list set) ~f:(fun p ->
-      Path.drop_optional_build_context p
-      |> Path.to_string_maybe_quoted |> Pp.verbatim)
+let pp_path p =
+  Path.drop_optional_build_context p
+  |> Path.to_string_maybe_quoted |> Pp.verbatim
+
+let pp_paths set = Pp.enumerate (Path.Set.to_list set) ~f:pp_path
 
 let get_dir_triage t ~dir =
   match Dpath.analyse_dir dir with
@@ -563,26 +564,55 @@ let compute_target_digests_or_raise_error exec_params ~loc targets =
       Execution_parameters.should_remove_write_permissions_on_generated_files
         exec_params
   in
-  let refresh =
-    if remove_write_permissions then
-      Cached_digest.refresh_and_chmod
-    else
-      Cached_digest.refresh
-  in
-  let good, bad =
-    Path.Build.Set.fold targets ~init:([], []) ~f:(fun target (good, bad) ->
-        match refresh target with
-        | digest -> ((target, digest) :: good, bad)
-        | exception (Unix.Unix_error _ | Sys_error _) ->
-          (good, Path.build target :: bad))
+  let good, missing, errors =
+    Path.Build.Set.fold targets ~init:([], [], [])
+      ~f:(fun target (good, missing, errors) ->
+        match Cached_digest.refresh ~remove_write_permissions target with
+        | Ok digest -> ((target, digest) :: good, missing, errors)
+        | No_such_file -> (good, target :: missing, errors)
+        | Error exn -> (good, missing, (target, exn) :: errors))
   in
-  match bad with
-  | [] -> List.rev good
-  | missing ->
+  match (missing, errors) with
+  | [], [] -> List.rev good
+  | missing, errors ->
     User_error.raise ~loc
-      [ Pp.textf "Rule failed to generate the following targets:"
-      ; pp_paths (Path.Set.of_list missing)
-      ]
+      ((match missing with
+       | [] -> []
+       | _ ->
+         [ Pp.textf "Rule failed to generate the following targets:"
+         ; pp_paths (Path.Set.of_list (List.map ~f:Path.build missing))
+         ])
+      @
+      match errors with
+      | [] -> []
+      | _ ->
+        [ Pp.textf "Error trying to read targets after a rule was run:"
+        ; Pp.enumerate (List.rev errors) ~f:(fun (path, exn) ->
+              let path = Path.build path in
+              let expected_syscall_path = Path.to_string path in
+              Pp.concat ~sep:(Pp.verbatim ": ")
+                (pp_path path
+                 ::
+                 (match exn with
+                 | Unix.Unix_error (error, syscall, p) ->
+                   [ (if String.equal expected_syscall_path p then
+                       Pp.verbatim syscall
+                     else
+                       Pp.concat
+                         [ Pp.verbatim syscall
+                         ; Pp.verbatim " "
+                         ; Pp.verbatim (String.maybe_quoted p)
+                         ])
+                   ; Pp.text (Unix.error_message error)
+                   ]
+                 | Sys_error msg ->
+                   [ Pp.verbatim
+                       (String.drop_prefix_if_exists
+                          ~prefix:(expected_syscall_path ^ ": ")
+                          msg)
+                   ]
+                 | exn -> [ Pp.verbatim (Printexc.to_string exn) ])))
+        ])
 
 let sandbox_dir = Path.Build.relative Path.Build.root ".sandbox"
 

src/dune_engine/cached_digest.ml

@@ -147,50 +147,53 @@ let set fn digest =
   let stat = Path.stat_exn fn in
   set_with_stat fn digest stat
 
-let refresh_ stats fn =
-  (* CR-soon aalekseyev: handle errors from [Digest.file_with_stats] in case
-     it's the source file and it's deleted *)
+let refresh_exn stats fn =
   let digest = Digest.file_with_stats fn stats in
   set_with_stat fn digest stats;
   digest
 
-let refresh_internal fn =
-  (* CR-soon aalekseyev: handle errors from [Path.stat]. *)
+let refresh_internal_exn fn =
   let stats = Path.stat_exn fn in
-  refresh_ stats fn
+  refresh_exn stats fn
 
-let refresh fn = refresh_internal (Path.build fn)
+module Refresh_result = struct
+  type t =
+    | Ok of Digest.t
+    | No_such_file
+    | Error of exn
+end
+
+let catch_fs_errors f =
+  match f () with
+  | exception ((Unix.Unix_error _ | Sys_error _) as exn) ->
+    Refresh_result.Error exn
+  | res -> res
 
-let refresh_and_chmod fn =
+let refresh fn ~remove_write_permissions : Refresh_result.t =
   let fn = Path.build fn in
-  (* CR-soon aalekseyev: handle errors from [Path.lstat]. *)
-  let stats = Path.lstat_exn fn in
-  let stats =
-    match stats.st_kind with
-    | S_LNK ->
-      (* If the path is a symbolic link, we don't try to remove write
-         permissions. For two reasons:
-
-         - if the destination was not a build path (i.e. in the build
-         directory), then it would definitely be wrong to do so
-
-         - if it is in the build directory, then we expect that the rule
-         producing this file will have taken core of chmodding it *)
-      (* CR-soon aalekseyev: handle errors from [Path.stat]. *)
-      Path.stat_exn fn
-    | Unix.S_REG ->
-      (* We remove write permissions to uniformize behavior regardless of
-         whether the cache is activated. No need to be zealous in case the file
-         is not cached anyway. See issue #3311. *)
-      (* CR-soon aalekseyev: handle errors from [chmod] etc. *)
-      let perm =
-        Path.Permissions.remove ~mode:Path.Permissions.write stats.st_perm
-      in
-      Path.chmod ~mode:perm fn;
-      { stats with st_perm = perm }
-    | _ -> stats
-  in
-  refresh_ stats fn
+  catch_fs_errors (fun () ->
+      match Path.lstat_exn fn with
+      | exception Unix.Unix_error (ENOENT, _, _) -> Refresh_result.No_such_file
+      | stats ->
+        let stats =
+          match stats.st_kind with
+          | Unix.S_LNK -> (
+            try Path.stat_exn fn with
+            | Unix.Unix_error (ENOENT, _, _) ->
+              raise (Sys_error "Broken symlink"))
+          | Unix.S_REG -> (
+            match remove_write_permissions with
+            | false -> stats
+            | true ->
+              let perm =
+                Path.Permissions.remove ~mode:Path.Permissions.write
+                  stats.st_perm
+              in
+              Path.chmod ~mode:perm fn;
+              { stats with st_perm = perm })
+          | _ -> stats
+        in
+        Refresh_result.Ok (refresh_exn stats fn))
 
 let peek_file fn =
   let cache = Lazy.force cache in
@@ -201,7 +204,6 @@ let peek_file fn =
       (if x.stats_checked = cache.checked_key then
         x.digest
       else
-        (* CR-soon aalekseyev: handle errors from [Path.stat]. *)
         let stats = Path.stat_exn fn in
         let reduced_stats = Reduced_stats.of_unix_stats stats in
         match Reduced_stats.compare x.stats reduced_stats with
@@ -238,7 +240,7 @@ let peek_file fn =
 
 let peek_or_refresh_file fn =
   match peek_file fn with
-  | None -> refresh_internal fn
+  | None -> refresh_internal_exn fn
   | Some v -> v
 
 let source_or_external_file fn =

src/dune_engine/cached_digest.mli

@@ -12,11 +12,18 @@ val peek_file : Path.t -> Digest.t option
 (** Digest the contents of an artefact *)
 val build_file : Path.Build.t -> Digest.t
 
-(** Same as [build_file], but forces the digest of the file to be re-computed *)
-val refresh : Path.Build.t -> Digest.t
-
-(** Same as {!refresh} but also remove write permissions on the file *)
-val refresh_and_chmod : Path.Build.t -> Digest.t
+module Refresh_result : sig
+  type t =
+    | Ok of Digest.t
+    | No_such_file
+    | Error of exn
+end
+
+(** Same as [build_file], but forces the digest of the file to be re-computed.
+
+    If [remove_write_permissions] is true, also remove write permissions on the
+    file. *)
+val refresh : Path.Build.t -> remove_write_permissions:bool -> Refresh_result.t
 
 (** {1 Managing the cache} *)
 

test/blackbox-tests/test-cases/dir-target-dep.t/run.t

@@ -3,6 +3,16 @@
   bar contents
   foo contents
 
+  $ dune build --root target @cat_dir
+  Entering directory 'target'
+       cat_dir alias cat_dir
+  bar:
+  bar contents
+
+  foo:
+  foo contents
+
+
   $ dune build --root dep
   Entering directory 'dep'
   File "dune", line 1, characters 0-68:

test/blackbox-tests/test-cases/dir-target-dep.t/target/cat_dir.ml

@@ -0,0 +1,19 @@
+let dir = Sys.argv.(1)
+
+let input_all t =
+  let buffer = Buffer.create 0 in
+  let rec loop () =
+    Buffer.add_channel buffer t 65536;
+    loop ()
+  in
+  try loop () with
+  | End_of_file -> Buffer.contents buffer
+
+let () =
+  let files =
+    Sys.readdir dir |> Array.to_list |> ListLabels.sort ~cmp:String.compare
+  in
+  ListLabels.iter files ~f:(fun file ->
+    let inp = open_in (Filename.concat dir file) in
+    Printf.printf "%s:\n%s\n" file (input_all inp)
+  )

test/blackbox-tests/test-cases/dir-target-dep.t/target/dune

@@ -1,5 +1,11 @@
 (executable
  (name foo)
+ (modules foo)
+ (libraries unix))
+
+(executable
+ (name cat_dir)
+ (modules cat_dir)
  (libraries unix))
 
 (rule
@@ -9,3 +15,9 @@
 (alias
  (name default)
  (deps dir))
+
+(alias
+ (name cat_dir)
+ (deps dir)
+ (action (run ./cat_dir.exe dir))
+ )

test/blackbox-tests/test-cases/unreadable-target.t/run.t

@@ -0,0 +1,20 @@
+  $ cat > dune-project <<EOF
+  > (lang dune 2.9)
+  > EOF
+
+  $ cat > dune <<EOF
+  > (rule
+  >   (targets a b)
+  >   (action (bash "echo content > a; chmod -r a; ln -s foo b")))
+  > 
+  > EOF
+
+  $ dune build b
+  File "dune", line 1, characters 0-84:
+  1 | (rule
+  2 |   (targets a b)
+  3 |   (action (bash "echo content > a; chmod -r a; ln -s foo b")))
+  Error: Error trying to read targets after a rule was run:
+  - a: Permission denied
+  - b: Broken symlink
+  [1]