futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

guix package: Add '--delete-generations'.

Browse Source 
* guix/scripts/package.scm (switch-to-previous-generation): New function.
  (roll-back): Use the new function instead of 'switch-link'.
  (show-help): Add '--delete-generations'.
  (%options): Likewise.
  (guix-package)[process-actions]: Add 'current-generation-number',
  'display-and-delete', and 'delete-generation'.  Add support for
  '--delete-generations', and reindent the code.
* tests/guix-package.sh: Test '--delete-generations'.
* doc/guix.texi (Invoking guix-package): Document '--delete-generations'.
This commit is contained in:
Nikita Karetnikov 2013-09-26 02:36:24 +00:00
parent 64d2e973fb
commit b7884ca3ca
3 changed files with 185 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
doc/guix.texi
View File

@ -714,6 +714,16 @@ or months by passing an integer along with the first letter of the
duration, e.g., @code{--list-generations=20d}.
@end itemize
@item --delete-generations[=@var{pattern}]
@itemx -d [@var{pattern}]
Delete all generations except the current one. Note that the zeroth
generation is never deleted.
This command accepts the same patterns as @option{--list-generations}.
When @var{pattern} is specified, delete the matching generations. If
the current generation matches, it is deleted atomically, i.e., by
switching to the previous available generation.
@end table
@node Packages with Multiple Outputs

104
guix/scripts/package.scm
View File

@ -223,6 +223,16 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(switch-symlinks generation prof)))
(define (switch-to-previous-generation profile)
"Atomically switch PROFILE to the previous generation."
(let* ((number (generation-number profile))
(previous-number (previous-generation-number profile number))
(previous-generation (format #f "~a-~a-link"
profile previous-number)))
(format #t (_ "switching from generation ~a to ~a~%")
number previous-number)
(switch-symlinks profile previous-generation)))
(define (roll-back profile)
"Roll back to the previous generation of PROFILE."
(let* ((number (generation-number profile))
@ -230,15 +240,8 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(previous-generation (format #f "~a-~a-link"
profile previous-number))
(manifest (string-append previous-generation "/manifest")))
(define (switch-link)
;; Atomically switch PROFILE to the previous generation.
(format #t (_ "switching from generation ~a to ~a~%")
number previous-number)
(switch-symlinks profile previous-generation))
(cond ((not (file-exists? profile)) ; invalid profile
(leave (_ "profile `~a' does not exist~%")
(leave (_ "profile '~a' does not exist~%")
profile))
((zero? number) ; empty profile
(format (current-error-port)
@ -246,8 +249,9 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
((or (zero? previous-number) ; going to emptiness
(not (file-exists? previous-generation)))
(link-to-empty-profile previous-generation)
(switch-link))
(else (switch-link))))) ; anything else
(switch-to-previous-generation profile))
(else
(switch-to-previous-generation profile))))) ; anything else
(define (generation-time profile number)
"Return the creation time of a generation in the UTC format."
@ -515,6 +519,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(display (_ "
-l, --list-generations[=PATTERN]
list generations matching PATTERN"))
(display (_ "
-d, --delete-generations[=PATTERN]
delete generations matching PATTERN"))
(newline)
(display (_ "
-p, --profile=PROFILE use PROFILE instead of the user's default profile"))
@ -578,6 +585,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(lambda (opt name arg result)
(cons `(query list-generations ,(or arg ""))
result)))
(option '(#\d "delete-generations") #f #t
(lambda (opt name arg result)
(alist-cons 'delete-generations (or arg "")
result)))
(option '("search-paths") #f #f
(lambda (opt name arg result)
(cons `(query search-paths) result)))
@ -828,11 +839,69 @@ more information.~%"))
install))))
(_ #f)))
(define current-generation-number
(generation-number profile))
(define (display-and-delete number)
(let ((generation (format #f "~a-~a-link" profile number)))
(unless (zero? number)
(format #t (_ "deleting ~a~%") generation)
(delete-file generation))))
(define (delete-generation number)
(let* ((previous-number (previous-generation-number profile number))
(previous-generation (format #f "~a-~a-link"
profile previous-number)))
(cond ((zero? number)) ; do not delete generation 0
((and (= number current-generation-number)
(not (file-exists? previous-generation)))
(link-to-empty-profile previous-generation)
(switch-to-previous-generation profile)
(display-and-delete number))
((= number current-generation-number)
(roll-back profile)
(display-and-delete number))
(else
(display-and-delete number)))))
;; First roll back if asked to.
(if (and (assoc-ref opts 'roll-back?) (not dry-run?))
(cond ((and (assoc-ref opts 'roll-back?) (not dry-run?))
(begin
(roll-back profile)
(process-actions (alist-delete 'roll-back? opts)))
(process-actions (alist-delete 'roll-back? opts))))
((and (assoc-ref opts 'delete-generations)
(not dry-run?))
(filter-map
(match-lambda
(('delete-generations . pattern)
(cond ((not (file-exists? profile)) ; XXX: race condition
(leave (_ "profile '~a' does not exist~%")
profile))
((string-null? pattern)
(let ((numbers (generation-numbers profile)))
(if (equal? numbers '(0))
(exit 0)
(for-each display-and-delete
(delete current-generation-number
numbers)))))
;; Do not delete the zeroth generation.
((equal? 0 (string->number pattern))
(exit 0))
((matching-generations pattern profile)
=>
(lambda (numbers)
(if (null-list? numbers)
(exit 1)
(for-each delete-generation numbers))))
(else
(leave (_ "invalid syntax: ~a~%")
pattern)))
(process-actions
(alist-delete 'delete-generations opts)))
(_ #f))
opts))
(else
(let* ((installed (manifest-packages (profile-manifest profile)))
(upgrade-regexps (filter-map (match-lambda
(('upgrade . regexp)
@ -842,7 +911,8 @@ more information.~%"))
(upgrade (if (null? upgrade-regexps)
'()
(let ((newest (find-newest-available-packages)))
(filter-map (match-lambda
(filter-map
(match-lambda
((name version output path _)
(and (any (cut regexp-exec <> name)
upgrade-regexps)
@ -870,7 +940,8 @@ more information.~%"))
(package-derivation (%store) package))
(_ #f))
install))
(install* (append
(install*
(append
(filter-map (match-lambda
(('install . (? package? p))
#f)
@ -897,7 +968,8 @@ more information.~%"))
(_ #f))
opts))
(remove* (filter-map (cut assoc <> installed) remove))
(packages (append install*
(packages
(append install*
(fold (lambda (package result)
(match package
((name _ out _ ...)
@ -950,7 +1022,7 @@ more information.~%"))
count)
count)
(display-search-paths packages
profile))))))))))
profile)))))))))))
(define (process-query opts)
;; Process any query specified by OPTS. Return #t when a query was

11
tests/guix-package.sh
View File

@ -142,6 +142,17 @@ then
# Make sure LIBRARY_PATH gets listed by `--search-paths'.
guix package --bootstrap -p "$profile" -i guile-bootstrap -i gcc-bootstrap
guix package --search-paths -p "$profile" | grep LIBRARY_PATH
# Delete the third generation and check that it was actually deleted.
guix package -p "$profile" --delete-generations=3
test -z "`guix package -p "$profile" -l 3`"
# Exit with 1 when a generation does not exist.
if guix package -p "$profile" --delete-generations=42;
then false; else true; fi
# Exit with 0 when trying to delete the zeroth generation.
guix package -p "$profile" --delete-generations=0
fi
# Make sure the `:' syntax works.