aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/guix.texi7
-rw-r--r--guix-package.in228
-rw-r--r--tests/guix-package.sh39
3 files changed, 180 insertions, 94 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index 27a00a6ed9..a41560e75c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -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.
diff --git a/guix-package.in b/guix-package.in
index c3fc397e5c..5dd4724b53 100644
--- a/guix-package.in
+++ b/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))
-
- (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)
- (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 dry-run? (assoc-ref opts 'dry-run?))
+ (define verbose? (assoc-ref opts 'verbose?))
+ (define profile (assoc-ref opts 'profile))
+
+ ;; 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*))))
+
+ (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
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index e5b8db7088..fd778f4f4f 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -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
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-15 05:53:26 +0000