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

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'.
This commit is contained in:
Ludovic Courtès 2013-01-17 22:20:42 +01:00
parent 8ca6cc4b45
commit 24e262f086
3 changed files with 177 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
doc/guix.texi
View File

@ -490,6 +490,13 @@ Remove @var{package}.
@itemx -u @var{regexp} @itemx -u @var{regexp}
Upgrade all the installed packages matching @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} @item --profile=@var{profile}
@itemx -p @var{profile} @itemx -p @var{profile}
Use @var{profile} instead of the user's default profile. Use @var{profile} instead of the user's default profile.

222
guix-package.in
View File

@ -13,6 +13,7 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
!# !#
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -89,13 +90,14 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
(_ (_
(error "unsupported manifest format" manifest)))) (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) (define (latest-profile-number profile)
"Return the identifying number of the latest generation of PROFILE. "Return the identifying number of the latest generation of PROFILE.
PROFILE is the name of the symlink to the current generation." 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)) (define* (scandir name #:optional (select? (const #t))
(entry<? (@ (ice-9 i18n) string-locale<?))) (entry<? (@ (ice-9 i18n) string-locale<?)))
;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19. ;; 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<?)))) (sort files entry<?))))
(match (scandir (dirname profile) (match (scandir (dirname profile)
(cut regexp-exec %profile-rx <>)) (cute regexp-exec (profile-regexp profile) <>))
(#f ; no profile directory (#f ; no profile directory
0) 0)
(() ; no profiles (() ; no profiles
0) 0)
((profiles ...) ; former profiles around ((profiles ...) ; former profiles around
(let ((numbers (map (compose string->number (let ((numbers
(cut match:substring <> 1) (map (compose string->number
(cut regexp-exec %profile-rx <>)) (cut match:substring <> 1)
profiles))) (cut regexp-exec (profile-regexp profile) <>))
profiles)))
(fold (lambda (number highest) (fold (lambda (number highest)
(if (> number highest) (if (> number highest)
number number
@ -179,6 +182,37 @@ all of PACKAGES, a list of name/version/output/path tuples."
packages) packages)
#:modules '((guix build union)))) #: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. ;;; Command-line options.
@ -197,6 +231,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
-r, --remove=PACKAGE remove PACKAGE")) -r, --remove=PACKAGE remove PACKAGE"))
(display (_ " (display (_ "
-u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP")) -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP"))
(display (_ "
--roll-back roll back to the previous generation"))
(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"))
@ -237,6 +273,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(option '(#\r "remove") #t #f (option '(#\r "remove") #t #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'remove 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 (option '(#\p "profile") #t #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'profile arg (alist-cons 'profile arg
@ -362,87 +401,96 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(define (process-actions opts) (define (process-actions opts)
;; Process any install/remove/upgrade action from 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) (define dry-run? (assoc-ref opts 'dry-run?))
(ensure-default-profile)) (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? (when (equal? profile %current-profile)
(and (build-derivations (%store) drv) (ensure-default-profile))
(let* ((prof-drv (profile-derivation (%store) packages))
(prof (derivation-path->output-path prof-drv)) (show-what-to-build drv dry-run?)
(old-drv (profile-derivation
(%store) (manifest-packages (or dry-run?
(profile-manifest profile)))) (and (build-derivations (%store) drv)
(old-prof (derivation-path->output-path old-drv)) (let* ((prof-drv (profile-derivation (%store) packages))
(number (latest-profile-number profile)) (prof (derivation-path->output-path prof-drv))
(name (format #f "~a/~a-~a-link" (old-drv (profile-derivation
(dirname profile) (%store) (manifest-packages
(basename profile) (+ 1 number)))) (profile-manifest profile))))
(if (string=? old-prof prof) (old-prof (derivation-path->output-path old-drv))
(format (current-error-port) (_ "nothing to be done~%")) (number (latest-profile-number profile))
(and (parameterize ((current-build-output-port (name (format #f "~a/~a-~a-link"
;; Output something when Guile (dirname profile)
;; needs to be built. (basename profile) (+ 1 number))))
(if (or verbose? (guile-missing?)) (if (string=? old-prof prof)
(current-error-port) (when (or (pair? install) (pair? remove))
(%make-void-port "w")))) (format (current-error-port)
(build-derivations (%store) (list prof-drv))) (_ "nothing to be done~%")))
(begin (and (parameterize ((current-build-output-port
(symlink prof name) ;; Output something when Guile
(when (file-exists? profile) ;; needs to be built.
(delete-file profile)) (if (or verbose? (guile-missing?))
(symlink name profile))))))))) (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) (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

39
tests/guix-package.sh
View File

@ -22,6 +22,11 @@
guix-package --version guix-package --version
readlink_base ()
{
basename `readlink "$1"`
}
profile="t-profile-$$" profile="t-profile-$$"
rm -f "$profile" rm -f "$profile"
@ -34,8 +39,7 @@ test -L "$profile" && test -L "$profile-1-link"
test -f "$profile/bin/guile" test -f "$profile/bin/guile"
# Installing the same package a second time does nothing. # Installing the same package a second time does nothing.
guix-package --bootstrap -p "$profile" \ guix-package --bootstrap -p "$profile" -i "$boot_guile"
-i `guix-build -e '(@@ (distro packages base) %bootstrap-guile)'`
test -L "$profile" && test -L "$profile-1-link" test -L "$profile" && test -L "$profile-1-link"
! test -f "$profile-2-link" ! test -f "$profile-2-link"
test -f "$profile/bin/guile" test -f "$profile/bin/guile"
@ -43,8 +47,8 @@ test -f "$profile/bin/guile"
# Check whether we have network access. # Check whether we have network access.
if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null
then then
guix-package --bootstrap -p "$profile" \ boot_make="`guix-build -e '(@@ (distro packages base) gnu-make-boot0)'`"
-i `guix-build -e '(@@ (distro packages base) gnu-make-boot0)'` guix-package --bootstrap -p "$profile" -i "$boot_make"
test -L "$profile-2-link" test -L "$profile-2-link"
test -f "$profile/bin/make" && test -f "$profile/bin/guile" test -f "$profile/bin/make" && test -f "$profile/bin/guile"
@ -68,6 +72,29 @@ then
guix-package --bootstrap -p "$profile" -r "guile-bootstrap" guix-package --bootstrap -p "$profile" -r "guile-bootstrap"
test -L "$profile-3-link" test -L "$profile-3-link"
test -f "$profile/bin/make" && ! test -f "$profile/bin/guile" 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 fi
# Make sure the `:' syntax works. # Make sure the `:' syntax works.
@ -88,3 +115,7 @@ mkdir -p "$HOME"
guix-package --bootstrap -i "$boot_guile" guix-package --bootstrap -i "$boot_guile"
test -L "$HOME/.guix-profile" test -L "$HOME/.guix-profile"
test -f "$HOME/.guix-profile/bin/guile" test -f "$HOME/.guix-profile/bin/guile"
# Failed attempt to roll back.
if guix-package --bootstrap --roll-back;
then false; else true; fi