[no subject]

[Ludovic Courtès]

branch: master
commit 476324286bcaf492bed096a9ce90e4f9368b798f
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Oct 25 20:00:15 2023 +0200

    remote-worker: Periodically delete old GC roots.
    
    With commit 55af0f70c0d4938b8eda777382bbc4d8f5698a37, GC roots created
    by ‘cuirass remote-worker’ would no longer be deleted (unless it’s
    running on the same machine as ‘cuirass remote-server’).
    
    * src/cuirass/scripts/remote-worker.scm (cuirass-remote-worker): Add
    call to ‘spawn-gc-root-cleaner’.
    * src/cuirass/base.scm (delete-old-gc-roots): Add #:check-database? and
    honor it.
    (spawn-gc-root-cleaner): Likewise.
---
 src/cuirass/base.scm                  | 17 ++++++++++++-----
 src/cuirass/scripts/remote-worker.scm |  7 +++++++
 2 files changed, 19 insertions(+), 5 deletions(-)

diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index f4d821c..2950cdd 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -901,7 +901,8 @@ monitoring actor for each 'register' message it receives."
                  (build-status scheduled)
                  (build-status started))))))
 
-(define (delete-old-gc-roots directory max-age)
+(define* (delete-old-gc-roots directory max-age
+                              #:key (check-database? #t))
   "Delete from DIRECTORY garbage-collector roots older than MAX-AGE seconds."
   (define now
     (time-second (current-time time-utc)))
@@ -915,7 +916,8 @@ monitoring actor for each 'register' message it receives."
 
            ;; 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))
+           (or (not check-database?)
+               (not (string-suffix? ".drv" file))
                (not (derivation-queued? (readlink file)))))))
 
   (log-info "deleting old GC roots from '~a'..." directory)
@@ -925,15 +927,20 @@ monitoring actor for each 'register' message it receives."
                 (delete-file (in-vicinity directory file)))
               files)))
 
-(define* (spawn-gc-root-cleaner max-age #:optional (period (* 3600 24)))
+(define* (spawn-gc-root-cleaner max-age #:optional (period (* 3600 24))
+                                #:key (check-database? #t))
   "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."
+than MAX-AGE seconds and that are known to be no longer needed.
+
+When CHECK-DATABASE? is true, connect to the database server to get
+information about derivations that are still needed by queued builds."
   (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)
+       (delete-old-gc-roots (%gc-root-directory) max-age
+                            #:check-database? check-database?)
        (sleep period)
        (loop))))
   #t)
diff --git a/src/cuirass/scripts/remote-worker.scm 
b/src/cuirass/scripts/remote-worker.scm
index b37bc05..e7ec4fd 100644
--- a/src/cuirass/scripts/remote-worker.scm
+++ b/src/cuirass/scripts/remote-worker.scm
@@ -20,6 +20,7 @@
 (define-module (cuirass scripts remote-worker)
   #:use-module (fibers)
   #:use-module (fibers channels)
+  #:autoload   (cuirass base) (spawn-gc-root-cleaner)
   #:autoload   (cuirass store) (build-derivations&
                                 register-gc-roots
                                 %gc-root-directory)
@@ -509,6 +510,12 @@ exiting."
              ;; requests on MANAGEMENT-CHANNEL.
              (spawn-fiber (worker-management-thunk management-channel systems))
 
+             ;; This program registers roots for successful build results.
+             ;; Normally these build results are sent right away to 'cuirass
+             ;; remote-server', so no need to keep them for too long.
+             (spawn-gc-root-cleaner (* 5 24 3600)
+                                    #:check-database? #f)
+
              (when server-address
                (log-info (N_ "creating ~a worker for build server at ~a"
                              "creating ~a workers for build server at ~a"