cache: Avoid cache cleanup storms from concurrent processes.

Reported by Christopher Baines <guix@cbaines.net>.

* guix/cache.scm (maybe-remove-expired-cache-entries): Define
‘expiry-port’; create it with ‘lock-file’.  Change ‘last-expiry-date’
accordingly.  Write timestamp straight to ‘expiry-port’.
* tests/cache.scm ("maybe-remove-expired-cache-entries, cleanup needed
but lock taken"): New test.

Change-Id: I22441d9d2c4a339d3d3878de131864db5a0ae826

guix/cache.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013-2017, 2020-2021, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2017, 2020-2021, 2023-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2022 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -19,6 +19,7 @@
 
 (define-module (guix cache)
   #:use-module ((guix utils) #:select (with-atomic-file-output))
+  #:autoload   (guix build syscalls) (lock-file unlock-file)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
@@ -93,13 +94,19 @@ CLEANUP-PERIOD denotes the minimum time between two cache cleanups."
   (define expiry-file
     (string-append cache "/last-expiry-cleanup"))
 
+  (define expiry-port
+    ;; Get exclusive access to EXPIRY-FILE to avoid "cleanup storms" where
+    ;; several processes would concurrently decide that time has come to clean
+    ;; up the same cache.  'lock-file' might throw to 'system-error' or to
+    ;; 'flock-error'; in either case, assume that we lost the race.
+    (false-if-exception
+     (lock-file expiry-file "a+0" #:wait? #f)))
+
   (define last-expiry-date
-    (catch 'system-error
+    (if expiry-port
-      (lambda ()
+        (or (string->number (get-string-all expiry-port))
-        (or (string->number
+            0)
-             (call-with-input-file expiry-file get-string-all))
+        +inf.0))
-            0))
-      (const 0)))
 
   (when (obsolete? last-expiry-date now cleanup-period)
     (remove-expired-cache-entries (cache-entries cache)
@@ -108,8 +115,10 @@ CLEANUP-PERIOD denotes the minimum time between two cache cleanups."
                                   #:delete-entry delete-entry)
     (catch 'system-error
       (lambda ()
-        (with-atomic-file-output expiry-file
+        (seek expiry-port 0 SEEK_SET)
-          (cute write (time-second now) <>)))
+        (truncate-file expiry-port 0)
+        (write (time-second now) expiry-port)
+        (unlock-file expiry-port))
       (lambda args
         ;; ENOENT means CACHE does not exist.
         (unless (= ENOENT (system-error-errno args))

tests/cache.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2020, 2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2022 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -22,7 +22,9 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-64)
+  #:use-module ((guix build syscalls) #:select (lock-file))
   #:use-module ((guix utils) #:select (call-with-temporary-directory))
+  #:use-module ((rnrs io ports) #:select (get-string-all))
   #:use-module (ice-9 match))
 
 (test-begin "cache")
@@ -75,6 +77,32 @@
       (lambda (port)
         (display 0 port)))))
 
+(let ((pid #f))
+  (test-equal "maybe-remove-expired-cache-entries, cleanup needed but lock taken"
+    '()
+    (test-cache-cleanup cache
+      (let ((in+out (pipe)))
+        (match (primitive-fork)
+          (0 (dynamic-wind
+               (const #t)
+               (lambda ()
+                 (close-port (car in+out))
+                 (let ((port (lock-file
+                              (string-append cache "/last-expiry-cleanup"))))
+                   (display 0 port)
+                   (display "done!\n" (cdr in+out))
+                   (close-port (cdr in+out))
+                   (sleep 100)))
+               (lambda ()
+                 (primitive-exit 0))))
+          (n
+           (set! pid n)
+           (close-port (cdr in+out))
+           (pk 'chr (get-string-all (car in+out)))
+           (close-port (car in+out)))))))
+
+  (when pid (kill pid SIGKILL)))
+
 (test-equal "maybe-remove-expired-cache-entries, empty cache"
   '("a" "b" "c")
   (test-cache-cleanup cache