Re: [PATCH] Implement guix-package --upgrade

[Mark H Weaver]

address@hidden (Ludovic Courtès) writes:

> Mark H Weaver <address@hidden> 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’t 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’ve installed the latter shouldn’t 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’ll 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


>From bd192057c770ca3653828498591dbe4683b51545 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
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

>From 6a7f8cfd7373afe664b3f0412c02d7b1beeb5c7a Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
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 "address@hidden@}" -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