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}
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
View File

@ -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

39
tests/guix-package.sh
View File

@ -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