Package: guix-patches;
Reported by: Ludovic Courtès <ludo <at> gnu.org>
Date: Sat, 6 Apr 2019 21:28:02 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Ludovic Courtès <ludo <at> gnu.org> To: 35176 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [bug#35176] [PATCH 4/5] guix gc: Add '--delete-generations'. Date: Sat, 6 Apr 2019 23:31:22 +0200
* guix/scripts/gc.scm (show-help, %options): Add
'--delete-generations'. Change '--delete' shorthand to '-d'.
(delete-old-generations): New procedure.
(guix-gc)[delete-generations]: New procedure.
Call it when ACTION is 'collect-garbage' and OPTS contains
'delete-generations.
* doc/guix.texi (Invoking guix gc): Document it.
---
doc/guix.texi | 16 +++++++++++++++-
guix/scripts/gc.scm | 45 +++++++++++++++++++++++++++++++++++++++++++--
2 files changed, 58 insertions(+), 3 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index 75ab2fe4f5..e1b30f0ab1 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3438,8 +3438,22 @@ as @code{500MiB}, as described above.
When @var{free} or more is already available in @file{/gnu/store}, do
nothing and exit immediately.
+@item --delete-generations[=@var{duration}]
+@itemx -d [@var{duration}]
+Before starting the garbage collection process, delete all the generations
+older than @var{duration}, for all the user profiles; when run as root, this
+applies to all the profiles @emph{of all the users}.
+
+For example, this command deletes all the generations of all your profiles
+that are older than 2 months (except generations that are current), and then
+proceeds to free space until at least 10 GiB are available:
+
+@example
+guix gc -d 2m -F 10G
+@end example
+
@item --delete
-@itemx -d
+@itemx -D
Attempt to delete all the store files and directories specified as
arguments. This fails if some of the files are not in the store, or if
they are still live.
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 2606e20deb..635a031645 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -22,6 +22,8 @@
#: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)
@@ -48,7 +50,10 @@ 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_ "
@@ -98,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
@@ -123,10 +138,24 @@ 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'~%"))
+ (alist-cons 'action 'delete
+ (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
@@ -212,6 +241,14 @@ 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 generation-profile (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?)
@@ -245,6 +282,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))
--
2.21.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.