base: Register GC roots for build results.

Fixes <https://bugs.gnu.org/33124>.

* src/cuirass/base.scm (%gc-root-directory, %gc-root-ttl): New variables.
(gc-root-expiration-time, register-gc-root): New procedures.
(handle-build-event)[gc-roots]: New procedure.
Upon 'build-succeeded' events, call 'register-gc-root' and
'maybe-remove-expired-cache-entries'.
* bin/cuirass.in (show-help, %options): Add '--ttl'.
(main): Parameterize %GC-ROOT-TTL.  Create %GC-ROOT-DIRECTORY.
* doc/cuirass.texi (Invocation): Document '--ttl'.

3 files changed, 71 insertions, 2 deletions

diff --git a/bin/cuirass.in b/bin/cuirass.in
index a7af5b2..b09ca27 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -31,8 +31,10 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
              (cuirass logging)
              (cuirass utils)
              (guix ui)
+             ((guix build utils) #:select (mkdir-p))
              (fibers)
              (fibers channels)
+             (srfi srfi-19)
              (ice-9 threads)                    ;for 'current-processor-count'
              (ice-9 getopt-long))
 
@@ -46,6 +48,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
   -S  --specifications=SPECFILE
                             Add specifications from SPECFILE to database.
   -D  --database=DB         Use DB to store build results.
+      --ttl=DURATION        Keep build results live for at least DURATION.
   -p  --port=NUM            Port of the HTTP server.
       --listen=HOST         Listen on the network interface for HOST
   -I, --interval=N          Wait N seconds between each poll
@@ -67,6 +70,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
     (use-substitutes                  (value #f))
     (threads                          (value #t))
     (fallback                         (value #f))
+    (ttl                              (value #t))
     (version        (single-char #\V) (value #f))
     (help           (single-char #\h) (value #f))))
 
@@ -88,7 +92,9 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
          (%package-cachedir
           (option-ref opts 'cache-directory (%package-cachedir)))
          (%use-substitutes? (option-ref opts 'use-substitutes #f))
-         (%fallback? (option-ref opts 'fallback #f)))
+         (%fallback? (option-ref opts 'fallback #f))
+         (%gc-root-ttl
+          (time-second (string->duration (option-ref opts 'ttl "30d")))))
       (cond
        ((option-ref opts 'help #f)
         (show-help)
@@ -97,6 +103,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
         (show-version)
         (exit 0))
        (else
+        (mkdir-p (%gc-root-directory))
         (let ((one-shot? (option-ref opts 'one-shot #f))
               (port      (string->number (option-ref opts 'port "8080")))
               (host      (option-ref opts 'listen "localhost"))
diff --git a/doc/cuirass.texi b/doc/cuirass.texi
index 08ca832..ebb1fa5 100644
--- a/doc/cuirass.texi
+++ b/doc/cuirass.texi
@@ -203,6 +203,17 @@ build results. Since @code{cuirass} uses SQLite as a database engine,
 @var{database} must be a file name.  If the file doesn't exist, it will
 be created.
 
+@item --ttl=@var{duration}
+Cuirass registers build results as garbage collector (GC) roots, thereby
+preventing them from being deleted by the GC.  The @option{--ttl} option
+instructs it to keep those GC roots live for at least @var{duration}---e.g.,
+@code{1m} for one month, @code{2w} for two weeks, and so on.  The default is
+30 days.
+
+Those GC roots are typically stored in
+@file{/var/guix/gcroots/per-user/@var{user}/cuirass}, where @var{user} is the
+user under which Cuirass is running.
+
 @item --port=@var{num}
 @itemx -p @var{num}
 Make the HTTP interface listen on port @var{num}.  Use port 8080 by
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 35e748d..fe0ec6c 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -30,6 +30,8 @@
   #:use-module (guix derivations)
   #:use-module (guix store)
   #:use-module (guix git)
+  #:use-module (guix cache)
+  #:use-module ((guix config) #:select (%state-directory))
   #:use-module (git)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 format)
@@ -61,6 +63,8 @@
             process-specs
             ;; Parameters.
             %package-cachedir
+            %gc-root-directory
+            %gc-root-ttl
             %use-substitutes?
             %fallback?))
 
@@ -112,6 +116,37 @@
           (scm-error 'wrong-type-arg
                      "%package-cachedir" "Not a string: ~S" (list #f) #f)))))
 
+(define %gc-root-directory
+  ;; Directory where garbage collector roots are stored.  We register build
+  ;; outputs there.
+  (make-parameter (string-append %state-directory
+                                 "/gcroots/profiles/per-user/"
+                                 (passwd:name (getpwuid (getuid)))
+                                 "/cuirass")))
+
+(define %gc-root-ttl
+  ;; The "time to live" (TTL) of GC roots.
+  (make-parameter (* 30 24 3600)))
+
+(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."
+  (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)))))
+
 (define (call-with-time thunk kont)
   "Call THUNK and pass KONT the elapsed time followed by THUNK's return
 values."
@@ -473,6 +508,13 @@ 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)
@@ -486,7 +528,16 @@ updating the database accordingly."
      (if (valid? drv)
          (begin
            (log-message "build succeeded: '~a'" drv)
-           (db-update-build-status! drv (build-status succeeded)))
+           (db-update-build-status! drv (build-status succeeded))
+
+           (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))
          (log-message "bogus build-succeeded event for '~a'" drv)))
     (('build-failed drv _ ...)
      (if (valid? drv)