guix-package: Add `--roll-back'.
Based on a patch by Nikita Karetnikov <nikita@karetnikov.org>. * guix-package.in (profile-regexp): New procedure. (latest-profile-number): Remove `%profile-rx', and use `profile-regexp' instead. (profile-number, roll-back): New procedure. (show-help): Add `--roll-back'. (%options): Likewise. (guix-package)[process-actions]: First check whether `roll-back?' is among OPTS, and call `roll-back' if it is, followed by a recursive call to `process-actions'. Emit the "nothing to be done" message only when INSTALL or REMOVE is non-empty. * tests/guix-package.sh (readlink_base): New function. Add tests for `--roll-back'. * doc/guix.texi (Invoking guix-package): Document `--roll-back'.master
Ludovic Courtès
parent
8ca6cc4b45
commit
24e262f086
|
|
@ -490,6 +490,13 @@ Remove @var{package}.
|
|||
@itemx -u @var{regexp}
|
||||
Upgrade all the installed packages matching @var{regexp}.
|
||||
|
||||
@item --roll-back
|
||||
Roll back to the previous @dfn{generation} of the profile---i.e., undo
|
||||
the last transaction.
|
||||
|
||||
When combined with options such as @code{--install}, roll back occurs
|
||||
before any other actions.
|
||||
|
||||
@item --profile=@var{profile}
|
||||
@itemx -p @var{profile}
|
||||
Use @var{profile} instead of the user's default profile.
|
||||
|
|
|
|||
222
guix-package.in
222
guix-package.in
|
|
@ -13,6 +13,7 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
|
|||
!#
|
||||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -89,13 +90,14 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
|
|||
(_
|
||||
(error "unsupported manifest format" manifest))))
|
||||
|
||||
(define (profile-regexp profile)
|
||||
"Return a regular expression that matches PROFILE's name and number."
|
||||
(make-regexp (string-append "^" (regexp-quote (basename profile))
|
||||
"-([0-9]+)")))
|
||||
|
||||
(define (latest-profile-number profile)
|
||||
"Return the identifying number of the latest generation of PROFILE.
|
||||
PROFILE is the name of the symlink to the current generation."
|
||||
(define %profile-rx
|
||||
(make-regexp (string-append "^" (regexp-quote (basename profile))
|
||||
"-([0-9]+)")))
|
||||
|
||||
(define* (scandir name #:optional (select? (const #t))
|
||||
(entry<? (@ (ice-9 i18n) string-locale<?)))
|
||||
;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
|
||||
|
|
@ -131,16 +133,17 @@ PROFILE is the name of the symlink to the current generation."
|
|||
(sort files entry<?))))
|
||||
|
||||
(match (scandir (dirname profile)
|
||||
(cut regexp-exec %profile-rx <>))
|
||||
(cute regexp-exec (profile-regexp profile) <>))
|
||||
(#f ; no profile directory
|
||||
0)
|
||||
(() ; no profiles
|
||||
0)
|
||||
((profiles ...) ; former profiles around
|
||||
(let ((numbers (map (compose string->number
|
||||
(cut match:substring <> 1)
|
||||
(cut regexp-exec %profile-rx <>))
|
||||
profiles)))
|
||||
(let ((numbers
|
||||
(map (compose string->number
|
||||
(cut match:substring <> 1)
|
||||
(cut regexp-exec (profile-regexp profile) <>))
|
||||
profiles)))
|
||||
(fold (lambda (number highest)
|
||||
(if (> number highest)
|
||||
number
|
||||
|
|
@ -179,6 +182,37 @@ all of PACKAGES, a list of name/version/output/path tuples."
|
|||
packages)
|
||||
#:modules '((guix build union))))
|
||||
|
||||
(define (profile-number profile)
|
||||
"Return PROFILE's number or 0. An absolute file name must be used."
|
||||
(or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
|
||||
(basename (readlink profile))))
|
||||
(compose string->number (cut match:substring <> 1)))
|
||||
0))
|
||||
|
||||
(define (roll-back profile)
|
||||
"Roll back to the previous generation of PROFILE."
|
||||
;; XXX: Get the previous generation number from the manifest?
|
||||
(let* ((number (profile-number profile))
|
||||
(previous-number (1- number))
|
||||
(previous-profile (format #f "~a/~a-~a-link"
|
||||
(dirname profile) profile
|
||||
previous-number))
|
||||
(manifest (string-append previous-profile "/manifest")))
|
||||
|
||||
(define (switch-link)
|
||||
;; Atomically switch PROFILE to the previous profile.
|
||||
(let ((pivot (string-append previous-profile ".new")))
|
||||
(format #t (_ "switching from generation ~a to ~a~%")
|
||||
number previous-number)
|
||||
(symlink previous-profile pivot)
|
||||
(rename-file pivot profile)))
|
||||
|
||||
(if (= number 0)
|
||||
(leave (_ "error: `~a' is not a valid profile~%") profile)
|
||||
(if (file-exists? previous-profile)
|
||||
(switch-link)
|
||||
(leave (_ "error: no previous profile; not rolling back~%"))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Command-line options.
|
||||
|
|
@ -197,6 +231,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
|
|||
-r, --remove=PACKAGE remove PACKAGE"))
|
||||
(display (_ "
|
||||
-u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP"))
|
||||
(display (_ "
|
||||
--roll-back roll back to the previous generation"))
|
||||
(newline)
|
||||
(display (_ "
|
||||
-p, --profile=PROFILE use PROFILE instead of the user's default profile"))
|
||||
|
|
@ -237,6 +273,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
|
|||
(option '(#\r "remove") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'remove arg result)))
|
||||
(option '("roll-back") #f #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'roll-back? #t result)))
|
||||
(option '(#\p "profile") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'profile arg
|
||||
|
|
@ -362,87 +401,96 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
|
|||
|
||||
(define (process-actions opts)
|
||||
;; Process any install/remove/upgrade action from OPTS.
|
||||
(let* ((dry-run? (assoc-ref opts 'dry-run?))
|
||||
(verbose? (assoc-ref opts 'verbose?))
|
||||
(profile (assoc-ref opts 'profile))
|
||||
(install (filter-map (match-lambda
|
||||
(('install . (? store-path?))
|
||||
#f)
|
||||
(('install . package)
|
||||
(find-package package))
|
||||
(_ #f))
|
||||
opts))
|
||||
(drv (filter-map (match-lambda
|
||||
((name version sub-drv
|
||||
(? package? package))
|
||||
(package-derivation (%store) package))
|
||||
(_ #f))
|
||||
install))
|
||||
(install* (append
|
||||
(filter-map (match-lambda
|
||||
(('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 _)
|
||||
(let ((output-path
|
||||
(derivation-path->output-path
|
||||
drv sub-drv)))
|
||||
`(,name ,version ,sub-drv ,output-path)))))
|
||||
install drv)))
|
||||
(remove (filter-map (match-lambda
|
||||
(('remove . package)
|
||||
package)
|
||||
(_ #f))
|
||||
opts))
|
||||
(packages (append install*
|
||||
(fold (lambda (package result)
|
||||
(match package
|
||||
((name _ ...)
|
||||
(alist-delete name result))))
|
||||
(fold alist-delete
|
||||
(manifest-packages
|
||||
(profile-manifest profile))
|
||||
remove)
|
||||
install*))))
|
||||
|
||||
(when (equal? (assoc-ref opts 'profile) %current-profile)
|
||||
(ensure-default-profile))
|
||||
(define dry-run? (assoc-ref opts 'dry-run?))
|
||||
(define verbose? (assoc-ref opts 'verbose?))
|
||||
(define profile (assoc-ref opts 'profile))
|
||||
|
||||
(show-what-to-build drv dry-run?)
|
||||
;; First roll back if asked to.
|
||||
(if (and (assoc-ref opts 'roll-back?) (not dry-run?))
|
||||
(begin
|
||||
(roll-back profile)
|
||||
(process-actions (alist-delete 'roll-back? opts)))
|
||||
(let* ((install (filter-map (match-lambda
|
||||
(('install . (? store-path?))
|
||||
#f)
|
||||
(('install . package)
|
||||
(find-package package))
|
||||
(_ #f))
|
||||
opts))
|
||||
(drv (filter-map (match-lambda
|
||||
((name version sub-drv
|
||||
(? package? package))
|
||||
(package-derivation (%store) package))
|
||||
(_ #f))
|
||||
install))
|
||||
(install* (append
|
||||
(filter-map (match-lambda
|
||||
(('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 _)
|
||||
(let ((output-path
|
||||
(derivation-path->output-path
|
||||
drv sub-drv)))
|
||||
`(,name ,version ,sub-drv ,output-path)))))
|
||||
install drv)))
|
||||
(remove (filter-map (match-lambda
|
||||
(('remove . package)
|
||||
package)
|
||||
(_ #f))
|
||||
opts))
|
||||
(packages (append install*
|
||||
(fold (lambda (package result)
|
||||
(match package
|
||||
((name _ ...)
|
||||
(alist-delete name result))))
|
||||
(fold alist-delete
|
||||
(manifest-packages
|
||||
(profile-manifest profile))
|
||||
remove)
|
||||
install*))))
|
||||
|
||||
(or dry-run?
|
||||
(and (build-derivations (%store) drv)
|
||||
(let* ((prof-drv (profile-derivation (%store) packages))
|
||||
(prof (derivation-path->output-path prof-drv))
|
||||
(old-drv (profile-derivation
|
||||
(%store) (manifest-packages
|
||||
(profile-manifest profile))))
|
||||
(old-prof (derivation-path->output-path old-drv))
|
||||
(number (latest-profile-number profile))
|
||||
(name (format #f "~a/~a-~a-link"
|
||||
(dirname profile)
|
||||
(basename profile) (+ 1 number))))
|
||||
(if (string=? old-prof prof)
|
||||
(format (current-error-port) (_ "nothing to be done~%"))
|
||||
(and (parameterize ((current-build-output-port
|
||||
;; Output something when Guile
|
||||
;; needs to be built.
|
||||
(if (or verbose? (guile-missing?))
|
||||
(current-error-port)
|
||||
(%make-void-port "w"))))
|
||||
(build-derivations (%store) (list prof-drv)))
|
||||
(begin
|
||||
(symlink prof name)
|
||||
(when (file-exists? profile)
|
||||
(delete-file profile))
|
||||
(symlink name profile)))))))))
|
||||
(when (equal? profile %current-profile)
|
||||
(ensure-default-profile))
|
||||
|
||||
(show-what-to-build drv dry-run?)
|
||||
|
||||
(or dry-run?
|
||||
(and (build-derivations (%store) drv)
|
||||
(let* ((prof-drv (profile-derivation (%store) packages))
|
||||
(prof (derivation-path->output-path prof-drv))
|
||||
(old-drv (profile-derivation
|
||||
(%store) (manifest-packages
|
||||
(profile-manifest profile))))
|
||||
(old-prof (derivation-path->output-path old-drv))
|
||||
(number (latest-profile-number profile))
|
||||
(name (format #f "~a/~a-~a-link"
|
||||
(dirname profile)
|
||||
(basename profile) (+ 1 number))))
|
||||
(if (string=? old-prof prof)
|
||||
(when (or (pair? install) (pair? remove))
|
||||
(format (current-error-port)
|
||||
(_ "nothing to be done~%")))
|
||||
(and (parameterize ((current-build-output-port
|
||||
;; Output something when Guile
|
||||
;; needs to be built.
|
||||
(if (or verbose? (guile-missing?))
|
||||
(current-error-port)
|
||||
(%make-void-port "w"))))
|
||||
(build-derivations (%store) (list prof-drv)))
|
||||
(begin
|
||||
(symlink prof name)
|
||||
(when (file-exists? profile)
|
||||
(delete-file profile))
|
||||
(symlink name profile))))))))))
|
||||
|
||||
(define (process-query opts)
|
||||
;; Process any query specified by OPTS. Return #t when a query was
|
||||
|
|
|
|||
|
|
@ -22,6 +22,11 @@
|
|||
|
||||
guix-package --version
|
||||
|
||||
readlink_base ()
|
||||
{
|
||||
basename `readlink "$1"`
|
||||
}
|
||||
|
||||
profile="t-profile-$$"
|
||||
rm -f "$profile"
|
||||
|
||||
|
|
@ -34,8 +39,7 @@ test -L "$profile" && test -L "$profile-1-link"
|
|||
test -f "$profile/bin/guile"
|
||||
|
||||
# Installing the same package a second time does nothing.
|
||||
guix-package --bootstrap -p "$profile" \
|
||||
-i `guix-build -e '(@@ (distro packages base) %bootstrap-guile)'`
|
||||
guix-package --bootstrap -p "$profile" -i "$boot_guile"
|
||||
test -L "$profile" && test -L "$profile-1-link"
|
||||
! test -f "$profile-2-link"
|
||||
test -f "$profile/bin/guile"
|
||||
|
|
@ -43,8 +47,8 @@ test -f "$profile/bin/guile"
|
|||
# Check whether we have network access.
|
||||
if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null
|
||||
then
|
||||
guix-package --bootstrap -p "$profile" \
|
||||
-i `guix-build -e '(@@ (distro packages base) gnu-make-boot0)'`
|
||||
boot_make="`guix-build -e '(@@ (distro packages base) gnu-make-boot0)'`"
|
||||
guix-package --bootstrap -p "$profile" -i "$boot_make"
|
||||
test -L "$profile-2-link"
|
||||
test -f "$profile/bin/make" && test -f "$profile/bin/guile"
|
||||
|
||||
|
|
@ -68,6 +72,29 @@ then
|
|||
guix-package --bootstrap -p "$profile" -r "guile-bootstrap"
|
||||
test -L "$profile-3-link"
|
||||
test -f "$profile/bin/make" && ! test -f "$profile/bin/guile"
|
||||
|
||||
# Roll back.
|
||||
guix-package --roll-back -p "$profile"
|
||||
test "`readlink_base "$profile"`" = "$profile-2-link"
|
||||
test -x "$profile/bin/guile" && test -x "$profile/bin/make"
|
||||
guix-package --roll-back -p "$profile"
|
||||
test "`readlink_base "$profile"`" = "$profile-1-link"
|
||||
test -x "$profile/bin/guile" && ! test -x "$profile/bin/make"
|
||||
|
||||
# Failed attempt to roll back because there's no previous generation.
|
||||
if guix-package --roll-back -p "$profile";
|
||||
then false; else true; fi
|
||||
|
||||
# Reinstall after roll-back to generation 1.
|
||||
guix-package --bootstrap -p "$profile" -i "$boot_make"
|
||||
test "`readlink_base "$profile"`" = "$profile-4-link"
|
||||
test -x "$profile/bin/guile" && test -x "$profile/bin/make"
|
||||
|
||||
# Roll-back to generation 3[*], and install---all at once.
|
||||
# [*] FIXME: Eventually, this should roll-back to generation 1.
|
||||
guix-package --bootstrap -p "$profile" --roll-back -i "$boot_guile"
|
||||
test "`readlink_base "$profile"`" = "$profile-5-link"
|
||||
test -x "$profile/bin/guile" && test -x "$profile/bin/make"
|
||||
fi
|
||||
|
||||
# Make sure the `:' syntax works.
|
||||
|
|
@ -88,3 +115,7 @@ mkdir -p "$HOME"
|
|||
guix-package --bootstrap -i "$boot_guile"
|
||||
test -L "$HOME/.guix-profile"
|
||||
test -f "$HOME/.guix-profile/bin/guile"
|
||||
|
||||
# Failed attempt to roll back.
|
||||
if guix-package --bootstrap --roll-back;
|
||||
then false; else true; fi
|
||||
|
|
|
|||
Reference in New Issue