branch master updated: hydra: services: "cleanup-cuirass-roots" deletes roots for referrers.

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script.

civodul pushed a commit to branch master
in repository maintenance.

The following commit(s) were added to refs/heads/master by this push:
     new aff8df6  hydra: services: "cleanup-cuirass-roots" deletes roots for 
referrers.
aff8df6 is described below

commit aff8df6bf32b87f97184c2618fed1137b284a431
Author: Ludovic Courtès <address@hidden>
AuthorDate: Fri Apr 24 11:52:20 2020 +0200

    hydra: services: "cleanup-cuirass-roots" deletes roots for referrers.
    
    * hydra/modules/sysadmin/services.scm (not-config?): New procedure.
    (cleanup-cuirass-roots): Wrap gexp in 'with-extensions' and
    'with-imported-modules'.
    [root-target, derivation-referrers, delete-gc-root-for-derivation]: New
    procedures.  Delete GC roots for the referrers of DELETED.
    Arguments to 'file-system-fold' now preserve RESULT.
---
 hydra/modules/sysadmin/services.scm | 168 +++++++++++++++++++++++-------------
 1 file changed, 110 insertions(+), 58 deletions(-)

diff --git a/hydra/modules/sysadmin/services.scm 
b/hydra/modules/sysadmin/services.scm
index 8b20baa..5a066a1 100644
--- a/hydra/modules/sysadmin/services.scm
+++ b/hydra/modules/sysadmin/services.scm
@@ -18,6 +18,8 @@
 
 (define-module (sysadmin services)
   #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module ((guix self) #:select (make-config.scm))
   #:use-module (gnu services)
   #:use-module (gnu services admin)
   #:use-module (gnu services base)
@@ -29,6 +31,7 @@
   #:use-module (guix packages)
   #:use-module (gnu packages)
   #:use-module (gnu packages ci)
+  #:use-module (gnu packages gnupg)
   #:use-module (gnu packages guile-xyz)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages package-management)
@@ -36,71 +39,120 @@
   #:use-module (gnu packages web)
   #:use-module (sysadmin people)
   #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
   #:export (firewall-service
             frontend-services))
 
+(define not-config?
+  ;; Select (guix …) and (gnu …) modules, except (guix config).
+  (match-lambda
+    (('guix 'config) #f)
+    (('guix _ ...) #t)
+    (('gnu _ ...) #t)
+    (_ #f)))
+
 (define cleanup-cuirass-roots
   ;; This program removes Cuirass GC roots that correspond to disk
   ;; images--which typically take 2+GiB and are produced at a high rate--so
   ;; that there's more garbage to collect.
-  (program-file "cleanup-cuirass-roots"
-                #~(begin
-                    (use-modules (ice-9 ftw))
-
-                    (define %roots-directory
-                      "/var/guix/profiles/per-user/cuirass/cuirass")
-
-                    (define now
-                      (current-time))
-
-                    (define (old? stat)
-                      (< (stat:mtime stat)
-                         (- now (* 5 3600 24))))
-
-                    (define (handle-gc-root file stat deleted)
-                      ;; Remove disk images, including *-installation (disk
-                      ;; images of the targets of installation tests.)
-                      (if (and (or (string-suffix? "-test" file)
-                                   (string-suffix? "-run-vm.sh" file)
-                                   (string-suffix? "-disk-image" file)
-                                   (string-suffix? "-qemu-image" file)
-                                   (string-suffix? ".squashfs" file)
-                                   (string-suffix? "docker-pack.tar.gz" file)
-                                   (string-suffix? "docker-image.tar.gz" file)
-                                   (string-suffix? "-installed-os" file)
-                                   (string-suffix? "-installed-os-encrypted" 
file)
-                                   (string-suffix? "-installation" file))
-                               (old? stat))
-                          (catch 'system-error
-                            (lambda ()
-                              (delete-file file)
-                              (cons file deleted))
-                            (lambda args
-                              (format (current-error-port)
-                                      "failed to delete ~a ~a~%" file
-                                      (system-error-errno args))
-                              deleted))
-                          deleted))
-
-                    ;; Note: 'scandir' would introduce too much overhead due
-                    ;; to the large number of entries that it would sort.
-                    (define deleted
-                      (file-system-fold (const #t) ;enter?
-                                        handle-gc-root
-                                        (const #t) ;down
-                                        (const #t) ;up
-                                        (const #t) ;skip
-                                        (const #t) ;error
-                                        '()
-                                        %roots-directory
-                                        lstat))
-
-                    (call-with-output-file "/gnu/big-stuff"
-                      (lambda (port)
-                        (for-each (lambda (file)
-                                    (display file port)
-                                    (newline port))
-                                  deleted))))))
+  (program-file
+   "cleanup-cuirass-roots"
+   (with-extensions (list guile-gcrypt)
+     (with-imported-modules `(,@(source-module-closure
+                                 '((guix store))
+                                 #:select? not-config?)
+                              ((guix config) => ,(make-config.scm)))
+       #~(begin
+           (use-modules (ice-9 ftw)
+                        (srfi srfi-1)
+                        (guix store))
+
+           (define %roots-directory
+             "/var/guix/profiles/per-user/cuirass/cuirass")
+
+           (define now
+             (current-time))
+
+           (define (old? stat)
+             (< (stat:mtime stat)
+                (- now (* 5 3600 24))))
+
+           (define (handle-gc-root file stat deleted)
+             ;; Remove disk images, including *-installation (disk
+             ;; images of the targets of installation tests.)
+             (if (and (or (string-suffix? "-test" file)
+                          (string-suffix? "-run-vm.sh" file)
+                          (string-suffix? "-disk-image" file)
+                          (string-suffix? "-qemu-image" file)
+                          (string-suffix? ".squashfs" file)
+                          (string-suffix? "docker-pack.tar.gz" file)
+                          (string-suffix? "docker-image.tar.gz" file)
+                          (string-suffix? "-installed-os" file)
+                          (string-suffix? "-installed-os-encrypted" file)
+                          (string-suffix? "-installation" file))
+                      (old? stat))
+                 (catch 'system-error
+                   (lambda ()
+                     (delete-file file)
+                     (cons file deleted))
+                   (lambda args
+                     (format (current-error-port)
+                             "failed to delete ~a ~a~%" file
+                             (system-error-errno args))
+                     deleted))
+                 deleted))
+
+           (define (root-target root)
+             ;; Return the store item ROOT refers to.
+             (string-append (%store-prefix) "/" (basename root)))
+
+           (define (derivation-referrers store item)
+             ;; Return the referrers of the derivers of ITEM.
+             (let* ((derivers  (valid-derivers store item))
+                    (referrers (append-map (lambda (drv)
+                                             (referrers store drv))
+                                           derivers)))
+               (delete-duplicates referrers)))
+
+           (define (delete-gc-root-for-derivation drv)
+             ;; Delete the GC root for DRV, if any.
+             (catch 'system-error
+               (lambda ()
+                 (let ((item (derivation-path->output-path drv)))
+                   (delete-file
+                    (string-append %roots-directory
+                                   "/" (basename drv)))))
+               (const #f)))
+
+           ;; Note: 'scandir' would introduce too much overhead due
+           ;; to the large number of entries that it would sort.
+           (define deleted
+             (file-system-fold (const #t)         ;enter?
+                               handle-gc-root
+                               (lambda (file stat result) result) ;down
+                               (lambda (file stat result) result) ;up
+                               (lambda (file stat result) result) ;skip
+                               (lambda (file stat errno result) result) ;error
+                               '()
+                               %roots-directory
+                               lstat))
+
+           (call-with-output-file "/gnu/big-stuff"
+             (lambda (port)
+               (for-each (lambda (file)
+                           (display file port)
+                           (newline port))
+                         deleted)))
+
+           ;; Since we run 'guix-daemon --gc-keep-outputs
+           ;; --gc-keep-derivations', also remove GC roots for the outputs of
+           ;; derivations that refer to the derivers of DELETED.
+           (for-each delete-gc-root-for-derivation
+                     (with-store store
+                       (append-map (lambda (root)
+                                     (derivation-referrers
+                                      store (root-target root)))
+                                   deleted))))))))
 
 (define %gc-jobs
   ;; The garbage collection mcron jobs.