[bug#47597] [PATCH 0/3] Add SourceForge updater and lint warnings

[bug#47597] [PATCH 0/3] Add SourceForge updater and lint warnings

[Ludovic Courtès]

Hi!

These patches add a ‘sourceforge’ updater.  Initially I tried
implementing it in terms of ‘latest-html-release’ but that doesn’t
work because of the peculiar URL scheme that SF uses, with “/download”
appended to otherwise nice-looking URLs.

Instead, this one looks at the /latest URL supported by SourceForge.
It’s less efficient than ‘generic-html’ for instance because there’s
no caching and there’s up to three additional HEAD requests performed
to find if there are detached signatures.

The last patch has ‘guix lint -c refresh’ emit warnings when a package
lacks an updater or when its updater doesn’t work.  This should help us
find out which updaters need to be improved or implemented.

Feedback welcome!

Ludo’.

Ludovic Courtès (3):
  gnu-maintenance: Add 'sourceforge' updater.
  upstream: 'package-latest-release' tries all the matching updaters.
  lint: refresh: Warn about missing or dysfunctional updaters.

 doc/guix.texi            |  2 ++
 guix/gnu-maintenance.scm | 55 ++++++++++++++++++++++++++++++++++++++++
 guix/lint.scm            | 41 +++++++++++++++++++-----------
 guix/upstream.scm        | 15 ++++++-----
 4 files changed, 92 insertions(+), 21 deletions(-)

-- 
2.31.1

[bug#47597] [PATCH 1/3] gnu-maintenance: Add 'sourceforge' updater.

[Ludovic Courtès]

This updater currently covers 2.4% of the packages.

* guix/gnu-maintenance.scm (latest-sourceforge-release): New procedure.
(%sourceforge-updater): New variable.
* doc/guix.texi (Invoking guix refresh): Document it.
---
 doc/guix.texi            |  2 ++
 guix/gnu-maintenance.scm | 55 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 57 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index bada446357..d9ab8090a0 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -11713,6 +11713,8 @@ list of updaters).  Currently, @var{updater} may be one of:
 the updater for GNU packages;
 @item savannah
 the updater for packages hosted at @uref{https://savannah.gnu.org, Savannah};
+@item sourceforge
+the updater for packages hosted at @uref{https://sourceforge.net, SourceForge};
 @item gnome
 the updater for GNOME packages;
 @item kde
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index c7972d13a5..79214ae1a0 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -66,6 +66,7 @@
             %gnu-updater
             %gnu-ftp-updater
             %savannah-updater
+            %sourceforge-updater
             %xorg-updater
             %kernel.org-updater
             %generic-html-updater))
@@ -660,6 +661,53 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
                                 #:directory directory)
            (cut adjusted-upstream-source <> rewrite))))
 
+(define (latest-sourceforge-release package)
+  "Return the latest release of PACKAGE."
+  (define (uri-append uri extension)
+    ;; Return URI with EXTENSION appended.
+    (build-uri (uri-scheme uri)
+               #:host (uri-host uri)
+               #:path (string-append (uri-path uri) extension)))
+
+  (define (valid-uri? uri)
+    ;; Return true if URI is reachable.
+    (catch #t
+      (lambda ()
+        (case (response-code (http-head uri))
+          ((200 302) #t)
+          (else #f)))
+      (const #f)))
+
+  (let* ((name     (package-upstream-name package))
+         (base     (string-append "https://sourceforge.net/projects/"
+                                  name "/files"))
+         (url      (string-append base "/latest/download"))
+         (response (catch #t (lambda () (http-head url))
+                     (const #f))))
+    (and response
+         (= 302 (response-code response))
+         (response-location response)
+         (match (string-tokenize (uri-path (response-location response))
+                                 (char-set-complement (char-set #\/)))
+           ((_ components ...)
+            (let* ((path (string-join components "/"))
+                   (url  (string-append "mirror://sourceforge/" path)))
+              (and (release-file? name (basename path))
+
+                   ;; Take the heavy-handed approach of probing 3 additional
+                   ;; URLs.  XXX: Would be nicer if this could be avoided.
+                   (let* ((loc (response-location response))
+                          (sig (any (lambda (extension)
+                                      (let ((uri (uri-append loc extension)))
+                                        (and (valid-uri? uri)
+                                             (string-append url extension))))
+                                    '(".asc" ".sig" ".sign"))))
+                     (upstream-source
+                      (package name)
+                      (version (tarball->version (basename path)))
+                      (urls (list url))
+                      (signature-urls (and sig (list sig))))))))))))
+
 (define (latest-xorg-release package)
   "Return the latest release of PACKAGE."
   (let ((uri (string->uri (origin-uri (package-source package)))))
@@ -774,6 +822,13 @@ the directory containing its source tarball."
    (pred (url-prefix-predicate "mirror://savannah/"))
    (latest latest-savannah-release)))
 
+(define %sourceforge-updater
+  (upstream-updater
+   (name 'sourceforge)
+   (description "Updater for packages hosted on sourceforge.net")
+   (pred (url-prefix-predicate "mirror://sourceforge/"))
+   (latest latest-sourceforge-release)))
+
 (define %xorg-updater
   (upstream-updater
    (name 'xorg)
-- 
2.31.1

[bug#47597] [PATCH 2/3] upstream: 'package-latest-release' tries all the matching updaters.

[Ludovic Courtès]

* guix/upstream.scm (package-latest-release): Try UPDATERS until one of
them returns an upstream source.  This is useful for packages with
several matching updaters, such a zlib ('sourceforge' and
'generic-html').
---
 guix/upstream.scm | 15 +++++++++------
 1 file changed, 9 insertions(+), 6 deletions(-)

diff --git a/guix/upstream.scm b/guix/upstream.scm
index accd8967d8..632e9ebc4f 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -264,12 +264,15 @@ them matches."
                                  #:optional
                                  (updaters (force %updaters)))
   "Return an upstream source to update PACKAGE, a <package> object, or #f if
-none of UPDATERS matches PACKAGE.  It is the caller's responsibility to ensure
-that the returned source is newer than the current one."
-  (match (lookup-updater package updaters)
-    ((? upstream-updater? updater)
-     ((upstream-updater-latest updater) package))
-    (_ #f)))
+none of UPDATERS matches PACKAGE.  When several updaters match PACKAGE, try
+them until one of them returns an upstream source.  It is the caller's
+responsibility to ensure that the returned source is newer than the current
+one."
+  (any (match-lambda
+         (($ <upstream-updater> name description pred latest)
+          (and (pred package)
+               (latest package))))
+       updaters))
 
 (define* (package-latest-release* package
                                   #:optional
-- 
2.31.1

[bug#47597] [PATCH 3/3] lint: refresh: Warn about missing or dysfunctional updaters.

[Ludovic Courtès]

This feedback should help us improve updaters.

* guix/lint.scm (check-for-updates): Return a warning when PACKAGE lacks
an updater or when the updater returns #f.
---
 guix/lint.scm | 41 ++++++++++++++++++++++++++---------------
 1 file changed, 26 insertions(+), 15 deletions(-)

diff --git a/guix/lint.scm b/guix/lint.scm
index cdd9dd14d7..a7d6bbba4f 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1191,21 +1191,32 @@ vulnerability records for PACKAGE by calling PACKAGE-VULNERABILITIES."
 
 (define (check-for-updates package)
   "Check if there is an update available for PACKAGE."
-  (match (with-networking-fail-safe
-          (format #f (G_ "while retrieving upstream info for '~a'")
-                  (package-name package))
-          #f
-          (package-latest-release* package))
-    ((? upstream-source? source)
-     (if (version>? (upstream-source-version source)
-                    (package-version package))
-         (list
-          (make-warning package
-                        (G_ "can be upgraded to ~a")
-                        (list (upstream-source-version source))
-                        #:field 'version))
-         '()))
-    (#f '()))) ; cannot find newer upstream release
+  (match (lookup-updater package)
+    (#f
+     (list (make-warning package (G_ "no updater for ~a")
+                         (list (package-name package))
+                         #:field 'source)))
+    ((? upstream-updater? updater)
+     (match (with-networking-fail-safe
+             (format #f (G_ "while retrieving upstream info for '~a'")
+                     (package-name package))
+             #f
+             (package-latest-release package))
+       ((? upstream-source? source)
+        (if (version>? (upstream-source-version source)
+                       (package-version package))
+            (list
+             (make-warning package
+                           (G_ "can be upgraded to ~a")
+                           (list (upstream-source-version source))
+                           #:field 'version))
+            '()))
+       (#f                                       ;cannot find upstream release
+        (list (make-warning package
+                            (G_ "updater '~a' failed to find \
+upstream releases")
+                            (list (upstream-updater-name updater))
+                            #:field 'source)))))))
 
 
 (define (check-archival package)
-- 
2.31.1

[bug#47597] [PATCH 0/3] Add SourceForge updater and lint warnings

[Mathieu Othacehe]

Hey Ludo,

> +    (catch #t
> +      (lambda ()
> +        (case (response-code (http-head uri))
> +          ((200 302) #t)
> +          (else #f)))
> +      (const #f)))

Any reason not to use "false-if-exception" here ...

> +         (response (catch #t (lambda () (http-head url))
> +                     (const #f))))

... and here?

Otherwise, I tested the whole patchset, seems fine :).

Thanks,

Mathieu

[bug#47597] [PATCH 0/3] Add SourceForge updater and lint warnings

[Ludovic Courtès]

Hi Mathieu,

Mathieu Othacehe <othacehe@gnu.org> skribis:

>> +    (catch #t
>> +      (lambda ()
>> +        (case (response-code (http-head uri))
>> +          ((200 302) #t)
>> +          (else #f)))
>> +      (const #f)))
>
> Any reason not to use "false-if-exception" here ...
>
>> +         (response (catch #t (lambda () (http-head url))
>> +                     (const #f))))
>
> ... and here?

No good reason, not sure what was on my mind.  I’ll adjust accordingly.

> Otherwise, I tested the whole patchset, seems fine :).

Cool, thank you!

Ludo’.

bug#47597: [PATCH 0/3] Add SourceForge updater and lint warnings

[Ludovic Courtès]

Pushed as 709f30b8e466b5f7155255be4f2cee008f8d01a9 with changes as
Mathieu suggested.  Thanks for your feedback!

Ludo’.

[bug#47597] [PATCH 0/3] Add SourceForge updater and lint warnings

[Léo Le Bouter via Guix-patches via]

[-- Attachment #1: Type: text/plain, Size: 207 bytes --]

Thanks a lot Ludo for this! Sourceforge updater was wondering why it
didnt exist maybe not possible but you did it!

Also linter to check if updaters are working correctly, really awesome
idea!

Léo

[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 833 bytes --]