From 3b90fc5b3cc128c1aaaaccc5ea4100c51522abf4 Mon Sep 17 00:00:00 2001
From: Hugo Buddelmeijer <hugo@buddelmeijer.nl>
Date: Thu, 18 Dec 2025 22:33:28 +0100
Subject: [PATCH] refresh: Make --list-updaters fast if
 web.cvs.savannah.gnu.org is broken.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

--list-updaters loops through all packages and all updaters to see whether they
match. The gnu-ftp updater used to use official-gnu-packages to fetch a list of
packages from web.cvs.savannah.gnu.org. official-gnu-packages only caches the
result if it succeeds; but does not cache upon a timout or 5xx status.
official-gnu-packages times out after a minute and is called for all 30k+
packages. refresh --list-updaters could therefore take 30000 minutes. Now
--list-updaters uses official-gnu-packages* (from lint.scm) that memoizes the
result also on failure, thereby limiting the time to 1 minute.

* guix/gnu-maintenance.scm: Add official-gnu-packages* from guix/lint.scm.
Call official-gnu-packages* from gnu-package?
* guix/lint.scm: Move official-gnu-packages* to guix/gnu-maintenance.scm

Change-Id: I5e2e094bfb1042b03db47e119ced0e94b49b417c
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
Merges: #4949
---
 guix/gnu-maintenance.scm | 91 +++++++++++++++++++++-------------------
 guix/lint.scm            |  7 ----
 2 files changed, 49 insertions(+), 49 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index a33f941cb8..c37baf19b7 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -61,6 +61,7 @@
             gnu-package-download-url
 
             official-gnu-packages
+            official-gnu-packages*
             find-package
             gnu-package?
 
@@ -181,6 +182,13 @@ to fetch the list of GNU packages over HTTP."
          (close-port port)
          lst)))
 
+(define official-gnu-packages*
+  (mlambda ()
+    "A memoizing version of 'official-gnu-packages' that returns the empty
+list when something goes wrong, such as a networking issue."
+    (let ((gnus (false-if-exception (official-gnu-packages))))
+      (or gnus '()))))
+
 (define (find-package name)
   "Find GNU package called NAME and return it.  Return #f if it was not
 found."
@@ -189,51 +197,50 @@ found."
         (official-gnu-packages)))
 
 (define gnu-package?
-  (let ((official-gnu-packages (memoize official-gnu-packages)))
-    (mlambdaq (package)
-      "Return true if PACKAGE is a GNU package.  This procedure may access the
+  (mlambdaq (package)
+    "Return true if PACKAGE is a GNU package.  This procedure may access the
 network to check in GNU's database."
-      (define (mirror-type url)
-        (let ((uri (string->uri url)))
-          (and (eq? (uri-scheme uri) 'mirror)
-               (cond
-                ((member (uri-host uri)
-                         '("gnu" "gnupg" "gcc" "gnome"))
-                 ;; Definitely GNU.
-                 'gnu)
-                ((equal? (uri-host uri) "cran")
-                 ;; Possibly GNU: mirror://cran could be either GNU R itself
-                 ;; or a non-GNU package.
-                 #f)
-                (else
-                 ;; Definitely non-GNU.
-                 'non-gnu)))))
+    (define (mirror-type url)
+      (let ((uri (string->uri url)))
+        (and (eq? (uri-scheme uri) 'mirror)
+             (cond
+              ((member (uri-host uri)
+                       '("gnu" "gnupg" "gcc" "gnome"))
+               ;; Definitely GNU.
+               'gnu)
+              ((equal? (uri-host uri) "cran")
+               ;; Possibly GNU: mirror://cran could be either GNU R itself
+               ;; or a non-GNU package.
+               #f)
+              (else
+               ;; Definitely non-GNU.
+               'non-gnu)))))
 
-      (define (gnu-home-page? package)
-        (letrec-syntax ((>> (syntax-rules ()
-                              ((_ value proc)
-                               (and=> value proc))
-                              ((_ value proc rest ...)
-                               (and=> value
-                                      (lambda (next)
-                                        (>> (proc next) rest ...)))))))
-          (>> package package-home-page
-              string->uri uri-host
-              (lambda (host)
-                (member host '("www.gnu.org" "gnu.org"))))))
+    (define (gnu-home-page? package)
+      (letrec-syntax ((>> (syntax-rules ()
+                            ((_ value proc)
+                             (and=> value proc))
+                            ((_ value proc rest ...)
+                             (and=> value
+                                    (lambda (next)
+                                      (>> (proc next) rest ...)))))))
+        (>> package package-home-page
+            string->uri uri-host
+            (lambda (host)
+              (member host '("www.gnu.org" "gnu.org"))))))
 
-      (or (gnu-home-page? package)
-          (match (package-source package)
-            ((? origin? origin)
-             (let ((url  (origin-uri origin))
-                   (name (package-upstream-name package)))
-               (case (and (string? url) (mirror-type url))
-                 ((gnu) #t)
-                 ((non-gnu) #f)
-                 (else
-                  (and (member name (map gnu-package-name (official-gnu-packages)))
-                       #t)))))
-            (_ #f))))))
+    (or (gnu-home-page? package)
+        (match (package-source package)
+          ((? origin? origin)
+           (let ((url  (origin-uri origin))
+                 (name (package-upstream-name package)))
+             (case (and (string? url) (mirror-type url))
+               ((gnu) #t)
+               ((non-gnu) #f)
+               (else
+                (and (member name (map gnu-package-name (official-gnu-packages*)))
+                     #t)))))
+          (_ #f)))))
 
 
 ;;;
diff --git a/guix/lint.scm b/guix/lint.scm
index 99920a95d0..cfe97b21a4 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1237,13 +1237,6 @@ upstream status")
                       '()
                       str)))
 
-(define official-gnu-packages*
-  (mlambda ()
-    "A memoizing version of 'official-gnu-packages' that returns the empty
-list when something goes wrong, such as a networking issue."
-    (let ((gnus (false-if-exception (official-gnu-packages))))
-      (or gnus '()))))
-
 (define (check-gnu-synopsis+description package)
   "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and
 descriptions maintained upstream."