[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
branch master updated: hydra: services: "cleanup-cuirass-roots" deletes
From: |
Ludovic Courtès |
Subject: |
branch master updated: hydra: services: "cleanup-cuirass-roots" deletes roots for referrers. |
Date: |
Fri, 24 Apr 2020 05:55:28 -0400 |
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.
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- branch master updated: hydra: services: "cleanup-cuirass-roots" deletes roots for referrers.,
Ludovic Courtès <=