[no subject]

[Mathieu Othacehe]

branch: master
commit 5260be23e245ade5874d22dfaf28b04e90dd56f8
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Wed May 19 09:47:58 2021 +0200

    Add a register-gc-roots procedure.
    
    Factorize GC root creation in a new register-gc-roots procedure.
    
    * src/cuirass/base.scm (gc-roots): Move it out of handle-build-event
    procedure.
    (register-gc-roots): New procedure.
    (handle-build-event): Use it.
---
 src/cuirass/base.scm | 37 +++++++++++++++++++++----------------
 1 file changed, 21 insertions(+), 16 deletions(-)

diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index cfda6dc..9ee037a 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -63,6 +63,7 @@
   #:use-module (rnrs bytevectors)
   #:export (;; Procedures.
             call-with-time-display
+            register-gc-roots
             read-parameters
             evaluate
             build-derivations&
@@ -147,6 +148,13 @@
   ;; 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."
@@ -166,6 +174,18 @@ computed as its modification time + TTL seconds."
       (unless (= EEXIST (system-error-errno args))
         (apply throw args)))))
 
+(define (register-gc-roots drv)
+  "Register GC roots for the outputs of the given DRV and remove the expired
+GC roots if any."
+  (for-each (match-lambda
+              ((name . output)
+               (register-gc-root output)))
+            (derivation-path->output-paths drv))
+  (maybe-remove-expired-cache-entries (%gc-root-directory)
+                                      gc-roots
+                                      #:entry-expiration
+                                      gc-root-expiration-time))
+
 (define (call-with-time thunk kont)
   "Call THUNK and pass KONT the elapsed time followed by THUNK's return
 values."
@@ -509,13 +529,6 @@ updating the database accordingly."
     (and (store-path? file)
          (string-suffix? ".drv" file)))
 
-  (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 '("." "..")))))))
-
   (match event
     (('build-started drv _ ...)
      (if (valid? drv)
@@ -532,15 +545,7 @@ updating the database accordingly."
          (begin
            (log-message "build succeeded: '~a'" drv)
            (set-build-successful! drv)
-
-           (for-each (match-lambda
-                       ((name . output)
-                        (register-gc-root output)))
-                     (derivation-path->output-paths drv))
-           (maybe-remove-expired-cache-entries (%gc-root-directory)
-                                               gc-roots
-                                               #:entry-expiration
-                                               gc-root-expiration-time))
+           (register-gc-roots drv))
          (log-message "bogus build-succeeded event for '~a'" drv)))
     (('build-failed drv _ ...)
      (if (valid? drv)