02/02: hydra: services: Accumulate the list of deleted files.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository maintenance.

commit 60aba43012b8c5ff9f6807f1dd114cf628d7a07c
Author: Ludovic Courtès <address@hidden>
AuthorDate: Fri Apr 24 10:54:13 2020 +0200

    hydra: services: Accumulate the list of deleted files.
    
    * hydra/modules/sysadmin/services.scm 
(cleanup-cuirass-roots)[handle-gc-root]:
    Rename last argument to 'deleted'.  Cons FILE to DELETED when it's
    actually deleted.
    [deleted]: New variable.
    Iterate over it to create "/gnu/big-stuff".
---
 hydra/modules/sysadmin/services.scm | 71 ++++++++++++++++++++-----------------
 1 file changed, 39 insertions(+), 32 deletions(-)

diff --git a/hydra/modules/sysadmin/services.scm 
b/hydra/modules/sysadmin/services.scm
index eb9792d..8b20baa 100644
--- a/hydra/modules/sysadmin/services.scm
+++ b/hydra/modules/sysadmin/services.scm
@@ -57,43 +57,50 @@
                       (< (stat:mtime stat)
                          (- now (* 5 3600 24))))
 
-                    (define (handle-gc-root file stat _)
+                    (define (handle-gc-root file stat deleted)
                       ;; Remove disk images, including *-installation (disk
                       ;; images of the targets of installation tests.)
-                      (when (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)
-                            (display file (current-output-port))
-                            (newline (current-output-port)))
-                          (lambda args
-                            (format (current-error-port)
-                                    "failed to delete ~a ~a~%" file
-                                    (system-error-errno args))))))
+                      (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.
-                    (with-output-to-file "/gnu/big-stuff"
-                      (lambda ()
-                        (file-system-fold (const #t)  ;enter?
-                                          handle-gc-root
-                                          (const #t)  ;down
-                                          (const #t)  ;up
-                                          (const #t)  ;skip
-                                          (const #t)  ;error
-                                          #t
-                                          %roots-directory
-                                          lstat))))))
+                    (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))))))
 
 (define %gc-jobs
   ;; The garbage collection mcron jobs.