aboutsummaryrefslogtreecommitdiff
path: root/guix/scripts/gc.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/gc.scm')
-rw-r--r--guix/scripts/gc.scm71
1 files changed, 68 insertions, 3 deletions
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 6f37b767ff..9a57e5fd1e 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -20,7 +20,10 @@
#:use-module (guix ui)
#:use-module (guix scripts)
#:use-module (guix store)
+ #:use-module (guix store roots)
#:autoload (guix build syscalls) (free-disk-space)
+ #:autoload (guix profiles) (generation-profile)
+ #:autoload (guix scripts package) (delete-generations)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
@@ -47,7 +50,12 @@ Invoke the garbage collector.\n"))
(display (G_ "
-F, --free-space=FREE attempt to reach FREE available space in the store"))
(display (G_ "
- -d, --delete attempt to delete PATHS"))
+ -d, --delete-generations[=PATTERN]
+ delete profile generations matching PATTERN"))
+ (display (G_ "
+ -D, --delete attempt to delete PATHS"))
+ (display (G_ "
+ --list-roots list the user's garbage collector roots"))
(display (G_ "
--optimize optimize the store by deduplicating identical files"))
(display (G_ "
@@ -95,6 +103,16 @@ Invoke the garbage collector.\n"))
lst)
'()))))
+(define (delete-old-generations store profile pattern)
+ "Remove the generations of PROFILE that match PATTERN, a duration pattern.
+Do nothing if none matches."
+ (let* ((current (generation-number profile))
+ (numbers (matching-generations pattern profile
+ #:duration-relation >)))
+
+ ;; Make sure we don't inadvertently remove the current generation.
+ (delete-generations store profile (delv current numbers))))
+
(define %options
;; Specification of the command-line options.
(list (option '(#\h "help") #f #f
@@ -120,10 +138,25 @@ Invoke the garbage collector.\n"))
(option '(#\F "free-space") #t #f
(lambda (opt name arg result)
(alist-cons 'free-space (size->number arg) result)))
- (option '(#\d "delete") #f #f
+ (option '(#\D "delete") #f #f ;used to be '-d' (lower case)
(lambda (opt name arg result)
(alist-cons 'action 'delete
(alist-delete 'action result))))
+ (option '(#\d "delete-generations") #f #t
+ (lambda (opt name arg result)
+ (if (and arg (store-path? arg))
+ (begin
+ (warning (G_ "'-d' as an alias for '--delete' \
+is deprecated; use '-D'~%"))
+ `((action . delete)
+ (argument . ,arg)
+ (alist-delete 'action result)))
+ (begin
+ (when (and arg (not (string->duration arg)))
+ (leave (G_ "~s does not denote a duration~%")
+ arg))
+ (alist-cons 'delete-generations (or arg "")
+ result)))))
(option '("optimize") #f #f
(lambda (opt name arg result)
(alist-cons 'action 'optimize
@@ -135,6 +168,10 @@ Invoke the garbage collector.\n"))
(alist-cons 'verify-options options
(alist-delete 'action
result))))))
+ (option '("list-roots") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'action 'list-roots
+ (alist-delete 'action result))))
(option '("list-dead") #f #f
(lambda (opt name arg result)
(alist-cons 'action 'list-dead
@@ -205,6 +242,27 @@ Invoke the garbage collector.\n"))
(info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.))
(collect-garbage store to-free)))))
+ (define (delete-generations store pattern)
+ ;; Delete the generations matching PATTERN of all the user's profiles.
+ (let ((profiles (delete-duplicates
+ (filter-map (lambda (root)
+ (and (or (zero? (getuid))
+ (user-owned? root))
+ (generation-profile root)))
+ (gc-roots)))))
+ (for-each (lambda (profile)
+ (delete-old-generations store profile pattern))
+ profiles)))
+
+ (define (list-roots)
+ ;; List all the user-owned GC roots.
+ (let ((roots (filter (if (zero? (getuid)) (const #t) user-owned?)
+ (gc-roots))))
+ (for-each (lambda (root)
+ (display root)
+ (newline))
+ roots)))
+
(with-error-handling
(let* ((opts (parse-options))
(store (open-connection))
@@ -229,6 +287,10 @@ Invoke the garbage collector.\n"))
(assert-no-extra-arguments)
(let ((min-freed (assoc-ref opts 'min-freed))
(free-space (assoc-ref opts 'free-space)))
+ (match (assoc-ref opts 'delete-generations)
+ (#f #t)
+ ((? string? pattern)
+ (delete-generations store pattern)))
(cond
(free-space
(ensure-free-space store free-space))
@@ -238,6 +300,9 @@ Invoke the garbage collector.\n"))
(else
(let-values (((paths freed) (collect-garbage store)))
(info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.)))))))
+ ((list-roots)
+ (assert-no-extra-arguments)
+ (list-roots))
((delete)
(delete-paths store (map direct-store-path paths)))
((list-references)