Return lock holder info when taking global lock fails

Signed-off-by: Stephen Sherratt <[email protected]>

Author: gridbugs

bin/build_cmd.ml

@@ -205,7 +205,7 @@ let build =
        state of the lock could otherwise change between checking it and taking
        it. *)
     match Dune_util.Global_lock.lock ~timeout:None with
-    | Error () ->
+    | Error _lock_held_by ->
       (* This case is reached if dune detects that another instance of dune
          is already running. Rather than performing the build itself, the
          current instance of dune will instruct the already-running instance to

src/dune_util/global_lock.ml

@@ -66,6 +66,28 @@ end
 
 let locked = ref false
 
+module Lock_held_by = struct
+  type t =
+    | Pid_from_lockfile of string
+    | Unknown
+
+  let read_lock_file () =
+    match Io.read_file (Path.build lock_file) with
+    | exception _ -> Unknown
+    | pid -> Pid_from_lockfile pid
+  ;;
+
+  let message t =
+    Pp.textf
+      "A running dune%s instance has locked the build directory. If this is not the \
+       case, please delete %S."
+      (match t with
+       | Unknown -> ""
+       | Pid_from_lockfile pid -> sprintf " (pid: %s)" pid)
+      (Path.Build.to_string_maybe_quoted lock_file)
+  ;;
+end
+
 let lock ~timeout =
   match Config.(get global_lock) with
   | `Disabled -> Ok ()
@@ -90,22 +112,15 @@ let lock ~timeout =
       | `Success ->
         locked := true;
         Ok ()
-      | `Failure -> Error ())
+      | `Failure ->
+        let lock_held_by = Lock_held_by.read_lock_file () in
+        Error lock_held_by)
 ;;
 
 let lock_exn ~timeout =
   match lock ~timeout with
   | Ok () -> ()
-  | Error () ->
-    User_error.raise
-      [ Pp.textf
-          "A running dune%s instance has locked the build directory. If this is not the \
-           case, please delete %s"
-          (match Io.read_file (Path.build lock_file) with
-           | exception _ -> ""
-           | pid -> sprintf " (pid: %s)" pid)
-          (Path.Build.to_string_maybe_quoted lock_file)
-      ]
+  | Error lock_held_by -> User_error.raise [ Lock_held_by.message lock_held_by ]
 ;;
 
 let unlock () =

src/dune_util/global_lock.mli

@@ -2,10 +2,16 @@
 
     Before starting rpc, writing to the build dir, this lock should be locked. *)
 
-(** attempt to acquire a lock. once a lock is locked, subsequent locks always
+module Lock_held_by : sig
+  type t
+
+  val message : t -> 'a Pp.t
+end
+
+(** Attempt to acquire a lock. once a lock is locked, subsequent locks always
     succeed. Returns [Ok ()] if the lock is acquired within [timeout] seconds,
     and [Error ()] otherwise. *)
-val lock : timeout:float option -> (unit, unit) result
+val lock : timeout:float option -> (unit, Lock_held_by.t) result
 
 val lock_exn : timeout:float option -> unit