mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
guix gc: Add '--delete-generations'.
* 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.
This commit is contained in:
parent
c872b952c5
commit
96b8c2e6e2
2 changed files with 59 additions and 3 deletions
|
@ -3438,8 +3438,22 @@ as @code{500MiB}, as described above.
|
||||||
When @var{free} or more is already available in @file{/gnu/store}, do
|
When @var{free} or more is already available in @file{/gnu/store}, do
|
||||||
nothing and exit immediately.
|
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
|
@item --delete
|
||||||
@itemx -d
|
@itemx -D
|
||||||
Attempt to delete all the store files and directories specified as
|
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
|
arguments. This fails if some of the files are not in the store, or if
|
||||||
they are still live.
|
they are still live.
|
||||||
|
|
|
@ -22,6 +22,8 @@ (define-module (guix scripts gc)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix store roots)
|
#:use-module (guix store roots)
|
||||||
#:autoload (guix build syscalls) (free-disk-space)
|
#: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 match)
|
||||||
#:use-module (ice-9 regex)
|
#:use-module (ice-9 regex)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
|
@ -48,7 +50,10 @@ (define (show-help)
|
||||||
(display (G_ "
|
(display (G_ "
|
||||||
-F, --free-space=FREE attempt to reach FREE available space in the store"))
|
-F, --free-space=FREE attempt to reach FREE available space in the store"))
|
||||||
(display (G_ "
|
(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_ "
|
(display (G_ "
|
||||||
--list-roots list the user's garbage collector roots"))
|
--list-roots list the user's garbage collector roots"))
|
||||||
(display (G_ "
|
(display (G_ "
|
||||||
|
@ -98,6 +103,16 @@ (define argument->verify-options
|
||||||
lst)
|
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
|
(define %options
|
||||||
;; Specification of the command-line options.
|
;; Specification of the command-line options.
|
||||||
(list (option '(#\h "help") #f #f
|
(list (option '(#\h "help") #f #f
|
||||||
|
@ -123,10 +138,25 @@ (define %options
|
||||||
(option '(#\F "free-space") #t #f
|
(option '(#\F "free-space") #t #f
|
||||||
(lambda (opt name arg result)
|
(lambda (opt name arg result)
|
||||||
(alist-cons 'free-space (size->number 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)
|
(lambda (opt name arg result)
|
||||||
(alist-cons 'action 'delete
|
(alist-cons 'action 'delete
|
||||||
(alist-delete 'action result))))
|
(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
|
(option '("optimize") #f #f
|
||||||
(lambda (opt name arg result)
|
(lambda (opt name arg result)
|
||||||
(alist-cons 'action 'optimize
|
(alist-cons 'action 'optimize
|
||||||
|
@ -212,6 +242,14 @@ (define (ensure-free-space store space)
|
||||||
(info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.))
|
(info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.))
|
||||||
(collect-garbage store to-free)))))
|
(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)
|
(define (list-roots)
|
||||||
;; List all the user-owned GC roots.
|
;; List all the user-owned GC roots.
|
||||||
(let ((roots (filter (if (zero? (getuid)) (const #t) user-owned?)
|
(let ((roots (filter (if (zero? (getuid)) (const #t) user-owned?)
|
||||||
|
@ -245,6 +283,10 @@ (define (list-relatives relatives)
|
||||||
(assert-no-extra-arguments)
|
(assert-no-extra-arguments)
|
||||||
(let ((min-freed (assoc-ref opts 'min-freed))
|
(let ((min-freed (assoc-ref opts 'min-freed))
|
||||||
(free-space (assoc-ref opts 'free-space)))
|
(free-space (assoc-ref opts 'free-space)))
|
||||||
|
(match (assoc-ref opts 'delete-generations)
|
||||||
|
(#f #t)
|
||||||
|
((? string? pattern)
|
||||||
|
(delete-generations store pattern)))
|
||||||
(cond
|
(cond
|
||||||
(free-space
|
(free-space
|
||||||
(ensure-free-space store free-space))
|
(ensure-free-space store free-space))
|
||||||
|
|
Loading…
Reference in a new issue