[no subject]

[Ludovic Courtès]

branch: master
commit db6b63371159a735de74eee97c313740c998439a
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Oct 10 18:38:12 2023 +0200

    base: Update the mtime of GC roots still in use.
    
    This should prevent GC roots from being evicted when they are in fact
    still used by recent evaluations.
    
    See <https://issues.guix.gnu.org/54447>.
    
    * src/cuirass/store.scm (register-gc-root): Add call to ‘utime’ upon EEXIST.
---
 src/cuirass/store.scm | 20 +++++++++++---------
 1 file changed, 11 insertions(+), 9 deletions(-)

diff --git a/src/cuirass/store.scm b/src/cuirass/store.scm
index 9cf9b7d..03c628b 100644
--- a/src/cuirass/store.scm
+++ b/src/cuirass/store.scm
@@ -78,15 +78,17 @@ computed as its modification time + TTL seconds."
 
 (define (register-gc-root item)
   "Create a GC root pointing to ITEM, a store item."
-  (catch 'system-error
-    (lambda ()
-      (symlink item
-               (string-append (%gc-root-directory)
-                              "/" (basename item))))
-    (lambda args
-      ;; If the symlink already exist, assume it points to ITEM.
-      (unless (= EEXIST (system-error-errno args))
-        (apply throw args)))))
+  (let ((root (string-append (%gc-root-directory) "/" (basename item))))
+    (catch 'system-error
+      (lambda ()
+        (symlink item root))
+      (lambda args
+        ;; If the symlink already exist, assume it points to ITEM, but update
+        ;; its mtime so it doesn't get GC'd too early.
+        (if (= EEXIST (system-error-errno args))
+            (let ((now (current-time)))
+              (utime root now now 0 0 AT_SYMLINK_NOFOLLOW))
+            (apply throw args))))))
 
 (define* (register-gc-roots drv
                             #:key (mode 'outputs))