01/01: hydra: services: Add 'cleanup-cuirass-roots' job.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository maintenance.

commit 9304c110afa636892c9444ea4814e82503cca68d
Author: Ludovic Courtès <address@hidden>
Date:   Sun Jun 16 17:57:04 2019 +0200

    hydra: services: Add 'cleanup-cuirass-roots' job.
    
    * hydra/modules/sysadmin/services.scm (cleanup-cuirass-roots): New
    variable.
    (%gc-jobs): Use it.
---
 hydra/modules/sysadmin/services.scm | 45 ++++++++++++++++++++++++++++++++++++-
 1 file changed, 44 insertions(+), 1 deletion(-)

diff --git a/hydra/modules/sysadmin/services.scm 
b/hydra/modules/sysadmin/services.scm
index 2ba30d7..cd61525 100644
--- a/hydra/modules/sysadmin/services.scm
+++ b/hydra/modules/sysadmin/services.scm
@@ -35,9 +35,52 @@
   #:export (firewall-service
             frontend-services))
 
+(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 (* 7 3600 24))))
+
+                    (define (handle-gc-root file stat _)
+                      (when (and (string-suffix? "-disk-image" file)
+                                 (old? stat))
+                        (catch 'system-error
+                          (lambda ()
+                            (delete-file file))
+                          (lambda args
+                            (pk 'failed-to-delete file
+                                (system-error-errno args))))))
+
+                    ;; Note: 'scandir' would introduce too much overhead due
+                    ;; to the large number of entries that it would sort.
+                    (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 %gc-jobs
   ;; The garbage collection mcron jobs.
-  (list #~(job '(next-hour '(4))
+  (list #~(job (next-hour '(3))
+               #$cleanup-cuirass-roots)
+
+        #~(job '(next-hour '(4))
                (string-append #$guix "/bin/guix gc -F80G"))
 
         ;; Half a day later, make sure half of our quota is available.