profiles: Distinguish downgrades from upgrades.

Fixes <http://bugs.gnu.org/19764>.

* guix/profiles.scm (manifest-transaction-effects): Return downgraded
  packages as a fourth value.
* guix/ui.scm (show-manifest-transaction): Adjust accordingly.
* tests/profiles.scm ("manifest-transaction-effects and downgrades"):
  New test.
master
Ludovic Courtès 2015-02-08 18:52:00 +01:00
parent 77ee4a96f4
commit 46b23e1a43
3 changed files with 49 additions and 16 deletions

View File

@ -303,24 +303,25 @@ no match.."
(default '())))
(define (manifest-transaction-effects manifest transaction)
"Compute the effect of applying TRANSACTION to MANIFEST. Return 3 values:
the list of packages that would be removed, installed, or upgraded when
applying TRANSACTION to MANIFEST. Upgrades are represented as pairs where the
head is the entry being upgraded and the tail is the entry that will replace
it."
"Compute the effect of applying TRANSACTION to MANIFEST. Return 4 values:
the list of packages that would be removed, installed, upgraded, or downgraded
when applying TRANSACTION to MANIFEST. Upgrades are represented as pairs
where the head is the entry being upgraded and the tail is the entry that will
replace it."
(define (manifest-entry->pattern entry)
(manifest-pattern
(name (manifest-entry-name entry))
(output (manifest-entry-output entry))))
(let loop ((input (manifest-transaction-install transaction))
(install '())
(upgrade '()))
(let loop ((input (manifest-transaction-install transaction))
(install '())
(upgrade '())
(downgrade '()))
(match input
(()
(let ((remove (manifest-transaction-remove transaction)))
(values (manifest-matching-entries manifest remove)
(reverse install) (reverse upgrade))))
(reverse install) (reverse upgrade) (reverse downgrade))))
((entry rest ...)
;; Check whether installing ENTRY corresponds to the installation of a
;; new package or to an upgrade.
@ -328,12 +329,18 @@ it."
;; XXX: When the exact same output directory is installed, we're not
;; really upgrading anything. Add a check for that case.
(let* ((pattern (manifest-entry->pattern entry))
(previous (manifest-lookup manifest pattern)))
(previous (manifest-lookup manifest pattern))
(newer? (and previous
(version>? (manifest-entry-version entry)
(manifest-entry-version previous)))))
(loop rest
(if previous install (cons entry install))
(if previous
(if (and previous newer?)
(alist-cons previous entry upgrade)
upgrade)))))))
upgrade)
(if (and previous (not newer?))
(alist-cons previous entry downgrade)
downgrade)))))))
(define (manifest-perform-transaction manifest transaction)
"Perform TRANSACTION on MANIFEST and return new manifest."

View File

@ -416,7 +416,7 @@ replacement if PORT is not Unicode-capable."
(package-output store item output)
item)))
(let-values (((remove install upgrade)
(let-values (((remove install upgrade downgrade)
(manifest-transaction-effects manifest transaction)))
(match remove
((($ <manifest-entry> name version output item) ..1)
@ -434,6 +434,24 @@ replacement if PORT is not Unicode-capable."
len)
remove))))
(_ #f))
(match downgrade
(((($ <manifest-entry> name old-version)
. ($ <manifest-entry> _ new-version output item)) ..1)
(let ((len (length name))
(downgrade (map upgrade-string
name old-version new-version output item)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be downgraded:~%~{~a~%~}~%"
"The following packages would be downgraded:~%~{~a~%~}~%"
len)
downgrade)
(format (current-error-port)
(N_ "The following package will be downgraded:~%~{~a~%~}~%"
"The following packages will be downgraded:~%~{~a~%~}~%"
len)
downgrade))))
(_ #f))
(match upgrade
(((($ <manifest-entry> name old-version)
. ($ <manifest-entry> _ new-version output item)) ..1)

View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
@ -155,12 +155,20 @@
(t (manifest-transaction
(install (list guile-2.0.9 glibc))
(remove (list (manifest-pattern (name "coreutils")))))))
(let-values (((remove install upgrade)
(let-values (((remove install upgrade downgrade)
(manifest-transaction-effects m0 t)))
(and (null? remove)
(and (null? remove) (null? downgrade)
(equal? (list glibc) install)
(equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
(test-assert "manifest-transaction-effects and downgrades"
(let* ((m0 (manifest (list guile-2.0.9)))
(t (manifest-transaction (install (list guile-1.8.8)))))
(let-values (((remove install upgrade downgrade)
(manifest-transaction-effects m0 t)))
(and (null? remove) (null? install) (null? upgrade)
(equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))
(test-assertm "profile-derivation"
(mlet* %store-monad
((entry -> (package->manifest-entry %bootstrap-guile))