01/01: Do not check package freshness during upgrade.

[Alex Kost]

alezost pushed a commit to branch master
in repository guix.

commit 6caa4dfa37e9b87336908e188500c14b402a0090
Author: Alex Kost <address@hidden>
Date:   Tue Feb 23 11:38:00 2016 +0300

    Do not check package freshness during upgrade.
    
    Fixes <http://bugs.gnu.org/22740>.
    Reported by Andreas Enge <address@hidden>.
    
    * gnu/packages.scm (waiting, ftp-open*, check-package-freshness): Remove.
    * guix/scripts/package.scm (options->installable): Adjust accordingly.
    * emacs/guix-main.scm (package->manifest-entry*): Likewise.
---
 emacs/guix-main.scm      |    4 +--
 gnu/packages.scm         |   69 +---------------------------------------------
 guix/scripts/package.scm |   12 ++-----
 3 files changed, 6 insertions(+), 79 deletions(-)

diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm
index 335686e..11b9c77 100644
--- a/emacs/guix-main.scm
+++ b/emacs/guix-main.scm
@@ -856,9 +856,7 @@ parameter/value pairs."
 
 (define* (package->manifest-entry* package #:optional output)
   (and package
-       (begin
-         (check-package-freshness package)
-         (package->manifest-entry package output))))
+       (package->manifest-entry package output)))
 
 (define* (make-install-manifest-entries id #:optional output)
   (package->manifest-entry* (package-by-id id) output))
diff --git a/gnu/packages.scm b/gnu/packages.scm
index b309a78..64a695d 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2013 Mark H Weaver <address@hidden>
 ;;; Copyright © 2014 Eric Bavier <address@hidden>
+;;; Copyright © 2016 Alex Kost <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,9 +23,6 @@
   #:use-module (guix packages)
   #:use-module (guix ui)
   #:use-module (guix utils)
-  #:use-module ((guix ftp-client) #:select (ftp-open))
-  #:use-module (guix gnu-maintenance)
-  #:use-module (guix upstream)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
@@ -46,8 +44,6 @@
             find-best-packages-by-name
             find-newest-available-packages
 
-            check-package-freshness
-
             specification->package
             specification->package+output))
 
@@ -280,69 +276,6 @@ return its return value."
                     (lambda (k signum)
                       (handler signum))))
 
-(define-syntax-rule (waiting exp fmt rest ...)
-  "Display the given message while EXP is being evaluated."
-  (let* ((message (format #f fmt rest ...))
-         (blank   (make-string (string-length message) #\space)))
-    (display message (current-error-port))
-    (force-output (current-error-port))
-    (call-with-sigint-handler
-     (lambda ()
-       (dynamic-wind
-         (const #f)
-         (lambda () exp)
-         (lambda ()
-           ;; Clear the line.
-           (display #\cr (current-error-port))
-           (display blank (current-error-port))
-           (display #\cr (current-error-port))
-           (force-output (current-error-port)))))
-     (lambda (signum)
-       (format (current-error-port) "  interrupted by signal ~a~%" SIGINT)
-       #f))))
-
-(define ftp-open*
-  ;; Memoizing version of `ftp-open'.  The goal is to avoid initiating a new
-  ;; FTP connection for each package, esp. since most of them are to the same
-  ;; server.  This has a noticeable impact when doing "guix upgrade -u".
-  (memoize ftp-open))
-
-(define (check-package-freshness package)
-  "Check whether PACKAGE has a newer version available upstream, and report
-it."
-  ;; TODO: Automatically inject the upstream version when desired.
-
-  (catch #t
-    (lambda ()
-      (when (false-if-exception (gnu-package? package))
-        (let ((name      (package-name package))
-              (full-name (package-full-name package)))
-          ;; XXX: This could work with non-GNU packages as well.  However,
-          ;; GNU's FTP-based updater would be too slow if it weren't memoized,
-          ;; and the generic interface in (guix upstream) doesn't support
-          ;; that.
-          (match (waiting (latest-release name
-                                          #:ftp-open ftp-open*
-                                          #:ftp-close (const #f))
-                          (_ "looking for the latest release of GNU ~a...") 
name)
-            ((? upstream-source? source)
-             (let ((latest-version
-                    (string-append (upstream-source-package source) "-"
-                                   (upstream-source-version source))))
-              (when (version>? latest-version full-name)
-                (format (current-error-port)
-                        (_ "~a: note: using ~a \
-but ~a is available upstream~%")
-                        (location->string (package-location package))
-                        full-name latest-version))))
-            (_ #t)))))
-    (lambda (key . args)
-      ;; Silently ignore networking errors rather than preventing
-      ;; installation.
-      (case key
-        ((getaddrinfo-error ftp-error) #f)
-        (else (apply throw key args))))))
-
 (define (specification->package spec)
   "Return a package matching SPEC.  SPEC may be a package name, or a package
 name followed by a hyphen and a version number.  If the version number is not
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index b93ffb0..f658343 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -2,7 +2,7 @@
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
 ;;; Copyright © 2013, 2015 Mark H Weaver <address@hidden>
-;;; Copyright © 2014 Alex Kost <address@hidden>
+;;; Copyright © 2014, 2016 Alex Kost <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -551,10 +551,6 @@ upgrading, #f otherwise."
 (define (options->installable opts manifest)
   "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
 return the new list of manifest entries."
-  (define (package->manifest-entry* package output)
-    (check-package-freshness package)
-    (package->manifest-entry package output))
-
   (define upgrade?
     (options->upgrade-predicate opts))
 
@@ -567,7 +563,7 @@ return the new list of manifest entries."
                           (call-with-values
                               (lambda ()
                                 (specification->package+output name output))
-                            package->manifest-entry*))))
+                            package->manifest-entry))))
                   (_ #f))
                 (manifest-entries manifest)))
 
@@ -576,13 +572,13 @@ return the new list of manifest entries."
                   (('install . (? package? p))
                    ;; When given a package via `-e', install the first of its
                    ;; outputs (XXX).
-                   (package->manifest-entry* p "out"))
+                   (package->manifest-entry p "out"))
                   (('install . (? string? spec))
                    (if (store-path? spec)
                        (store-item->manifest-entry spec)
                        (let-values (((package output)
                                      (specification->package+output spec)))
-                         (package->manifest-entry* package output))))
+                         (package->manifest-entry package output))))
                   (_ #f))
                 opts))