From mboxrd@z Thu Jan 1 00:00:00 1970 From: Mark H Weaver Subject: Re: [PATCH] Implement guix-package --upgrade Date: Tue, 12 Feb 2013 14:29:07 -0500 Message-ID: <8738x1xrek.fsf@tines.lan> References: <87vc9yxcre.fsf@tines.lan> <87a9r9zwrv.fsf@gnu.org> <87liaty5cy.fsf@tines.lan> <87y5etv9ze.fsf@gnu.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([208.118.235.92]:52505) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1U5LXl-0005Zk-Td for bug-guix@gnu.org; Tue, 12 Feb 2013 14:29:32 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1U5LXi-0004J6-EQ for bug-guix@gnu.org; Tue, 12 Feb 2013 14:29:29 -0500 In-Reply-To: <87y5etv9ze.fsf@gnu.org> ("Ludovic \=\?utf-8\?Q\?Court\=C3\=A8s\=22'\?\= \=\?utf-8\?Q\?s\?\= message of "Tue, 12 Feb 2013 16:16:05 +0100") List-Id: Bug reports for GNU Guix List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guix-bounces+gcggb-bug-guix=m.gmane.org@gnu.org Sender: bug-guix-bounces+gcggb-bug-guix=m.gmane.org@gnu.org To: Ludovic =?utf-8?Q?Court=C3=A8s?= Cc: bug-guix@gnu.org --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable ludo@gnu.org (Ludovic Court=C3=A8s) writes: > Mark H Weaver skribis: > >> Okay. I was relying on the fact that attempts to install a derivation >> that's already installed will ultimately be ignored, and my (admittedly >> simple) tests seem to suggest that it works properly, but perhaps this >> approach will be too inefficient when the profile contains a large >> number of packages. > > More importantly, you don=E2=80=99t want upgrade to downgrade. Ah, good point! :) > For instance, if guile-1.8.8 turns out to be before guile-2.0.7 in the > package list, users who=E2=80=99ve installed the latter shouldn=E2=80=99t= suddenly > downgrade to the former. Would "guix-package -i guile" ever choose guile-1.8.8 over guile-2.0.7 if the latter was available? Does it not automatically choose the newest available version? If not, should it? > I=E2=80=99ll take care of the tests and -e. Great, thanks! I've attached a new implementation of --upgrade along the lines you suggested. Still remaining to be done: if there are multiple packages with the same (newest) version number, choose intelligently between them. The first patch moves 'version-string>?' to (guix utils) and renames it to 'version>?'. It also adds 'version-compare'. I needed these for the improved upgrade implementation. Comments and suggestions solicited. Mark --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-Add-version-compare-and-version-to-utils.scm.patch Content-Description: [PATCH 1/2] Add version-compare and version>? to utils.scm >From bd192057c770ca3653828498591dbe4683b51545 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 12 Feb 2013 12:02:15 -0500 Subject: [PATCH 1/2] Add version-compare and version>? to utils.scm. * guix/utils.scm (version-compare, version>?): New exported procedures, based on version-string>?, which was formerly in gnu-maintenance.scm. * guix/gnu-maintenance.scm (version-string>?): Removed procedure. (latest-release): Use 'version>?' instead of 'version-string>?'. --- guix/gnu-maintenance.scm | 12 ++---------- guix/utils.scm | 20 ++++++++++++++++++++ 2 files changed, 22 insertions(+), 10 deletions(-) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index c934694..6475c38 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -28,6 +28,7 @@ #:use-module (srfi srfi-26) #:use-module (system foreign) #:use-module (guix ftp-client) + #:use-module (guix utils) #:export (official-gnu-packages releases latest-release @@ -156,21 +157,12 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). files) result))))))) -(define version-string>? - (let ((strverscmp - (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) - (error "could not find `strverscmp' (from GNU libc)")))) - (pointer->procedure int sym (list '* '*))))) - (lambda (a b) - "Return #t when B denotes a newer version than A." - (> (strverscmp (string->pointer a) (string->pointer b)) 0)))) - (define (latest-release project) "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f." (let ((releases (releases project))) (and (not (null? releases)) (fold (lambda (release latest) - (if (version-string>? (car release) (car latest)) + (if (version>? (car release) (car latest)) release latest)) '("" . "") diff --git a/guix/utils.scm b/guix/utils.scm index 7ab835e..d7c37e3 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -57,6 +57,8 @@ gnu-triplet->nix-system %current-system + version-compare + version>? package-name->name+version)) @@ -422,6 +424,24 @@ returned by `config.guess'." ;; By default, this is equal to (gnu-triplet->nix-system %host-type). (make-parameter %system)) +(define version-compare + (let ((strverscmp + (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) + (error "could not find `strverscmp' (from GNU libc)")))) + (pointer->procedure int sym (list '* '*))))) + (lambda (a b) + "Return '> when A denotes a newer version than B, +'< when A denotes a older version than B, +or '= when they denote equal versions." + (let ((result (strverscmp (string->pointer a) (string->pointer b)))) + (cond ((positive? result) '>) + ((negative? result) '<) + (else '=)))))) + +(define (version>? a b) + "Return #t when A denotes a newer version than B." + (eq? '> (version-compare a b))) + (define (package-name->name+version name) "Given NAME, a package name like \"foo-0.9.1b\", return two values: \"foo\" and \"0.9.1b\". When the version part is unavailable, NAME and -- 1.7.10.4 --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0002-Implement-guix-package-upgrade.patch Content-Description: [PATCH 2/2] Implement guix-package --upgrade >From 6a7f8cfd7373afe664b3f0412c02d7b1beeb5c7a Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 12 Feb 2013 01:24:21 -0500 Subject: [PATCH 2/2] Implement guix-package --upgrade. * guix-package.in (%options): Add --upgrade/-u option. (newest-available-packages, upgradeable?): New procedures. (process-actions): Implement upgrade option. --- guix-package.in | 78 +++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 67 insertions(+), 11 deletions(-) diff --git a/guix-package.in b/guix-package.in index 32d9afd..f00b7e7 100644 --- a/guix-package.in +++ b/guix-package.in @@ -52,6 +52,7 @@ exec "${GUILE-@GUILE@}" -c "$startup" "@guilemoduledir@" "$0" "$@" #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -356,6 +357,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 '(#\u "upgrade") #t #f + (lambda (opt name arg result) + (alist-cons 'upgrade arg result))) (option '("roll-back") #f #f (lambda (opt name arg result) (alist-cons 'roll-back? #t result))) @@ -468,6 +472,41 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (() (leave (_ "~a: package not found~%") request))))) + (define (newest-available-packages) + ;; Return a vhash with elements of the form: + ;; (name newest-version newest-package ...) + ;; where the preferred package is listed first. + + ;; FIXME: Currently, the preferred package is whichever one + ;; was found last by 'fold-packages'. Find a better solution. + (fold-packages (lambda (p r) + (let ((name (package-name p)) + (version (package-version p))) + (match (vhash-assoc name r) + ((_ newest-so-far . pkgs) + (case (version-compare version newest-so-far) + ((>) (vhash-cons name `(,version ,p) r)) + ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) + ((<) r))) + (#f (vhash-cons name `(,version ,p) r))))) + vlist-null)) + + (define (upgradeable? name current-version current-path newest) + ;; Return #t if there is a newer version available, or if the + ;; newest version if the same as the current one but the + ;; output path would be different than the current path. + + ;; NEWEST must be the result of (newest-available-packages). + (match (vhash-assoc name newest) + ((_ candidate-version pkg . rest) + (case (version-compare candidate-version current-version) + ((>) #t) + ((<) #f) + ((=) (let* ((candidate-path (derivation-path->output-path + (package-derivation (%store) pkg)))) + (not (string=? current-path candidate-path)))))) + (#f #f))) + (define (ensure-default-profile) ;; Ensure the default profile symlink and directory exist. @@ -520,13 +559,33 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (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)) + (let* ((installed (manifest-packages (profile-manifest profile))) + (upgrade-regexps (filter-map (match-lambda + (('upgrade . regexp) + (make-regexp regexp)) + (_ #f)) + opts)) + (upgrade (if (null? upgrade-regexps) + '() + (let ((newest (newest-available-packages))) + (filter-map (match-lambda + ((name version output path _) + (and (any (cut regexp-exec <> name) + upgrade-regexps) + (upgradeable? name version path + newest) + (find-package name))) + (_ #f)) + installed)))) + (install (append + upgrade + (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) @@ -563,10 +622,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (match package ((name _ ...) (alist-delete name result)))) - (fold alist-delete - (manifest-packages - (profile-manifest profile)) - remove) + (fold alist-delete installed remove) install*)))) (when (equal? profile %current-profile) -- 1.7.10.4 --=-=-=--