[no subject]

[Ludovic Courtès]

branch: master
commit 55af0f70c0d4938b8eda777382bbc4d8f5698a37
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Oct 15 21:55:14 2023 +0200

    base: Keep GC roots for derivations that are still queued.
    
    Previously, ‘maybe-remove-expired-cache-entries’ would periodically
    delete old GC roots, regardless of whether there were still builds
    queued for them.  This approach addresses that.
    
    Partly fixes <https://issues.guix.gnu.org/54447>.
    
    * src/cuirass/base.scm (derivation-queued?, delete-old-gc-roots)
    (spawn-gc-root-cleaner): New procedures.
    * src/cuirass/scripts/register.scm (cuirass-register): Call
    ‘spawn-gc-root-cleaner’.
    * src/cuirass/store.scm (gc-roots, gc-root-expiration-time): Remove.
    (register-gc-roots): Remove call to ‘maybe-remove-expired-cache-entries’.
---
 src/cuirass/base.scm             | 53 ++++++++++++++++++++++++++++++++++++++++
 src/cuirass/scripts/register.scm |  3 +++
 src/cuirass/store.scm            | 24 +-----------------
 3 files changed, 57 insertions(+), 23 deletions(-)

diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 60ff046..2f3526b 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -72,6 +72,7 @@
             spawn-channel-update-service
             spawn-jobset-evaluator
             spawn-jobset-registry
+            spawn-gc-root-cleaner
 
             lookup-jobset
             register-jobset
@@ -886,3 +887,55 @@ monitoring actor for each 'register' message it receives."
 (define* (update-jobset registry spec)
   "Update SPEC, so far known under FORMER-NAME, in REGISTRY."
   (put-message registry `(update ,spec)))
+
+
+;;;
+;;; GC root cleanup.
+;;;
+
+(define (derivation-queued? drv)
+  "Return true if DRV corresponds to a build that is still queued."
+  (match (db-get-build drv)
+    (#f #f)
+    (build
+     (memv (build-current-status build)
+           (list (build-status submitted)
+                 (build-status scheduled)
+                 (build-status started))))))
+
+(define (delete-old-gc-roots directory max-age)
+  "Delete from DIRECTORY garbage-collector roots older than MAX-AGE seconds."
+  (define now
+    (time-second (current-time time-utc)))
+
+  (define (old-root? file)
+    (let* ((file (in-vicinity directory file))
+           (stat (false-if-exception (lstat file))))
+      (and stat
+           (eq? 'symlink (stat:type stat))
+           (>= (- now (stat:mtime stat)) max-age)
+
+           ;; If the GC root corresponds to the derivation of a build
+           ;; that's still queued, do not remove it.
+           (or (not (string-suffix? ".drv" file))
+               (not (derivation-queued? (readlink file)))))))
+
+  (log-info "deleting old GC roots from '~a'..." directory)
+  (let ((files (scandir directory old-root?)))
+    (log-info "selected ~a GC roots to remove" (length files))
+    (for-each (lambda (file)
+                (delete-file (in-vicinity directory file)))
+              files)))
+
+(define* (spawn-gc-root-cleaner max-age #:optional (period (* 3600 24)))
+  "Spawn an agent that, every PERIOD seconds, deletes GC roots that are older
+than MAX-AGE seconds and that are known to be no longer needed."
+  (spawn-fiber
+   (lambda ()
+     (log-info "unused GC roots older than ~as will be deleted every ~as"
+               max-age period)
+     (let loop ()
+       (delete-old-gc-roots (%gc-root-directory) max-age)
+       (sleep period)
+       (loop))))
+  #t)
diff --git a/src/cuirass/scripts/register.scm b/src/cuirass/scripts/register.scm
index 24f2338..2d963d1 100644
--- a/src/cuirass/scripts/register.scm
+++ b/src/cuirass/scripts/register.scm
@@ -244,6 +244,9 @@
                        ;; registry.
                        (spawn-bridge (open-bridge-socket) registry))
 
+                     ;; Periodically delete old GC roots.
+                     (spawn-gc-root-cleaner (%gc-root-ttl))
+
                      (spawn-fiber
                       (essential-task
                        'metrics exit-channel
diff --git a/src/cuirass/store.scm b/src/cuirass/store.scm
index 03c628b..e920f32 100644
--- a/src/cuirass/store.scm
+++ b/src/cuirass/store.scm
@@ -22,13 +22,10 @@
   #:autoload   (guix derivations) (build-derivations
                                    derivation-path->output-paths)
   #:use-module ((guix config) #:select (%state-directory))
-  #:autoload   (guix cache) (maybe-remove-expired-cache-entries)
-  #:autoload   (srfi srfi-26) (cut)
   #:use-module (srfi srfi-34)
   #:use-module ((srfi srfi-35) #:select (condition?))
   #:use-module (ice-9 atomic)
   #:use-module (ice-9 match)
-  #:autoload   (ice-9 ftw) (scandir)
   #:autoload   (ice-9 rdelim) (read-line)
   #:use-module (ice-9 threads)
   #:export (non-blocking-port
@@ -62,20 +59,6 @@
   ;; The "time to live" (TTL) of GC roots.
   (make-parameter (* 30 24 3600)))
 
-(define (gc-roots directory)
-  ;; Return the list of GC roots (symlinks) in DIRECTORY.
-  (map (cut string-append directory "/" <>)
-       (scandir directory
-                (lambda (file)
-                  (not (member file '("." "..")))))))
-
-(define (gc-root-expiration-time file)
-  "Return \"expiration time\" of FILE (a symlink in %GC-ROOT-DIRECTORY)
-computed as its modification time + TTL seconds."
-  (match (false-if-exception (lstat file))
-    (#f 0)                         ;FILE may have been deleted in the meantime
-    (st (+ (stat:mtime st) (%gc-root-ttl)))))
-
 (define (register-gc-root item)
   "Create a GC root pointing to ITEM, a store item."
   (let ((root (string-append (%gc-root-directory) "/" (basename item))))
@@ -107,12 +90,7 @@ any."
          (register-gc-root drv))))
     (lambda args
       (unless (= ENOENT (system-error-errno args)) ;collected in the meantime
-        (apply throw args))))
-
-  (maybe-remove-expired-cache-entries (%gc-root-directory)
-                                      gc-roots
-                                      #:entry-expiration
-                                      gc-root-expiration-time))
+        (apply throw args)))))
 
 
 ;;;