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

1 files changed, 29 insertions, 1 deletions

diff --git a/tests/cache.scm b/tests/cache.scm
index d495ace2bd..e8ad083d40 100644
--- a/tests/cache.scm
+++ b/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