diff options
| -rw-r--r-- | doc/guix.texi | 7 | ||||
| -rw-r--r-- | guix-package.in | 228 | ||||
| -rw-r--r-- | tests/guix-package.sh | 39 |
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 |