nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

* 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}. duration, e.g., @code{--list-generations=20d}.
@end itemize @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 @end table
@node Packages with Multiple Outputs @node Packages with Multiple Outputs

256
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))) (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) (define (roll-back profile)
"Roll back to the previous generation of PROFILE." "Roll back to the previous generation of PROFILE."
(let* ((number (generation-number profile)) (let* ((number (generation-number profile))
@ -230,24 +240,18 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(previous-generation (format #f "~a-~a-link" (previous-generation (format #f "~a-~a-link"
profile previous-number)) profile previous-number))
(manifest (string-append previous-generation "/manifest"))) (manifest (string-append previous-generation "/manifest")))
(cond ((not (file-exists? profile)) ; invalid profile
(define (switch-link) (leave (_ "profile '~a' does not exist~%")
;; 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~%")
profile)) profile))
((zero? number) ; empty profile ((zero? number) ; empty profile
(format (current-error-port) (format (current-error-port)
(_ "nothing to do: already at the empty profile~%"))) (_ "nothing to do: already at the empty profile~%")))
((or (zero? previous-number) ; going to emptiness ((or (zero? previous-number) ; going to emptiness
(not (file-exists? previous-generation))) (not (file-exists? previous-generation)))
(link-to-empty-profile previous-generation) (link-to-empty-profile previous-generation)
(switch-link)) (switch-to-previous-generation profile))
(else (switch-link))))) ; anything else (else
(switch-to-previous-generation profile))))) ; anything else
(define (generation-time profile number) (define (generation-time profile number)
"Return the creation time of a generation in the UTC format." "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 (_ " (display (_ "
-l, --list-generations[=PATTERN] -l, --list-generations[=PATTERN]
list generations matching PATTERN")) list generations matching PATTERN"))
(display (_ "
-d, --delete-generations[=PATTERN]
delete generations matching PATTERN"))
(newline) (newline)
(display (_ " (display (_ "
-p, --profile=PROFILE use PROFILE instead of the user's default profile")) -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) (lambda (opt name arg result)
(cons `(query list-generations ,(or arg "")) (cons `(query list-generations ,(or arg ""))
result))) result)))
(option '(#\d "delete-generations") #f #t
(lambda (opt name arg result)
(alist-cons 'delete-generations (or arg "")
result)))
(option '("search-paths") #f #f (option '("search-paths") #f #f
(lambda (opt name arg result) (lambda (opt name arg result)
(cons `(query search-paths) result))) (cons `(query search-paths) result)))
@ -828,85 +839,146 @@ more information.~%"))
install)))) install))))
(_ #f))) (_ #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. ;; 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 (begin
(roll-back profile) (roll-back profile)
(process-actions (alist-delete 'roll-back? opts))) (process-actions (alist-delete 'roll-back? opts))))
(let* ((installed (manifest-packages (profile-manifest profile))) ((and (assoc-ref opts 'delete-generations)
(upgrade-regexps (filter-map (match-lambda (not dry-run?))
(('upgrade . regexp) (filter-map
(make-regexp (or regexp ""))) (match-lambda
(_ #f)) (('delete-generations . pattern)
opts)) (cond ((not (file-exists? profile)) ; XXX: race condition
(upgrade (if (null? upgrade-regexps) (leave (_ "profile '~a' does not exist~%")
'() profile))
(let ((newest (find-newest-available-packages))) ((string-null? pattern)
(filter-map (match-lambda (let ((numbers (generation-numbers profile)))
((name version output path _) (if (equal? numbers '(0))
(and (any (cut regexp-exec <> name) (exit 0)
upgrade-regexps) (for-each display-and-delete
(upgradeable? name version path) (delete current-generation-number
(find-package name numbers)))))
(or output "out")))) ;; Do not delete the zeroth generation.
(_ #f)) ((equal? 0 (string->number pattern))
installed)))) (exit 0))
(install (append ((matching-generations pattern profile)
upgrade =>
(filter-map (match-lambda (lambda (numbers)
(('install . (? package? p)) (if (null-list? numbers)
(package->tuple p)) (exit 1)
(('install . (? store-path?)) (for-each delete-generation numbers))))
#f) (else
(('install . package) (leave (_ "invalid syntax: ~a~%")
(find-package package)) pattern)))
(_ #f))
opts))) (process-actions
(drv (filter-map (match-lambda (alist-delete 'delete-generations opts)))
((name version sub-drv (_ #f))
(? package? package) opts))
(deps ...)) (else
(check-package-freshness package) (let* ((installed (manifest-packages (profile-manifest profile)))
(package-derivation (%store) package)) (upgrade-regexps (filter-map (match-lambda
(_ #f)) (('upgrade . regexp)
install)) (make-regexp (or regexp "")))
(install* (append (_ #f))
(filter-map (match-lambda opts))
(('install . (? package? p)) (upgrade (if (null? upgrade-regexps)
#f) '()
(('install . (? store-path? path)) (let ((newest (find-newest-available-packages)))
(let-values (((name version) (filter-map
(package-name->name+version (match-lambda
(store-path-package-name ((name version output path _)
path)))) (and (any (cut regexp-exec <> name)
`(,name ,version #f ,path ()))) upgrade-regexps)
(_ #f)) (upgradeable? name version path)
opts) (find-package name
(map (lambda (tuple drv) (or output "out"))))
(match tuple (_ #f))
((name version sub-drv _ (deps ...)) installed))))
(let ((output-path (install (append
(derivation->output-path upgrade
drv sub-drv))) (filter-map (match-lambda
`(,name ,version ,sub-drv ,output-path (('install . (? package? p))
,(canonicalize-deps deps)))))) (package->tuple p))
install drv))) (('install . (? store-path?))
(remove (filter-map (match-lambda #f)
(('remove . package) (('install . package)
package) (find-package package))
(_ #f)) (_ #f))
opts)) opts)))
(remove* (filter-map (cut assoc <> installed) remove)) (drv (filter-map (match-lambda
(packages (append install* ((name version sub-drv
(fold (lambda (package result) (? package? package)
(match package (deps ...))
((name _ out _ ...) (check-package-freshness package)
(filter (negate (package-derivation (%store) package))
(cut same-package? <> (_ #f))
name out)) install))
result)))) (install*
(fold alist-delete installed remove) (append
install*)))) (filter-map (match-lambda
(('install . (? package? p))
#f)
(('install . (? store-path? path))
(let-values (((name version)
(package-name->name+version
(store-path-package-name
path))))
`(,name ,version #f ,path ())))
(_ #f))
opts)
(map (lambda (tuple drv)
(match tuple
((name version sub-drv _ (deps ...))
(let ((output-path
(derivation->output-path
drv sub-drv)))
`(,name ,version ,sub-drv ,output-path
,(canonicalize-deps deps))))))
install drv)))
(remove (filter-map (match-lambda
(('remove . package)
package)
(_ #f))
opts))
(remove* (filter-map (cut assoc <> installed) remove))
(packages
(append install*
(fold (lambda (package result)
(match package
((name _ out _ ...)
(filter (negate
(cut same-package? <>
name out))
result))))
(fold alist-delete installed remove)
install*))))
(when (equal? profile %current-profile) (when (equal? profile %current-profile)
(ensure-default-profile)) (ensure-default-profile))
@ -950,7 +1022,7 @@ more information.~%"))
count) count)
count) count)
(display-search-paths packages (display-search-paths packages
profile)))))))))) profile)))))))))))
(define (process-query opts) (define (process-query opts)
;; Process any query specified by OPTS. Return #t when a query was ;; 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'. # Make sure LIBRARY_PATH gets listed by `--search-paths'.
guix package --bootstrap -p "$profile" -i guile-bootstrap -i gcc-bootstrap guix package --bootstrap -p "$profile" -i guile-bootstrap -i gcc-bootstrap
guix package --search-paths -p "$profile" | grep LIBRARY_PATH 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 fi
# Make sure the `:' syntax works. # Make sure the `:' syntax works.