diff mbox series

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

Message ID 20210404210316.31198-1-ludo@gnu.org
State Accepted
Headers show
Series Add SourceForge updater and lint warnings | expand

Checks

Context Check Description
cbaines/comparison success View comparision
cbaines/git branch success View Git branch
cbaines/applying patch success View Laminar job
cbaines/issue success View issue

Commit Message

Ludovic Courtès April 4, 2021, 9:03 p.m. UTC 
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(+)

Comments

Mathieu Othacehe April 5, 2021, 3:38 p.m. UTC | #1 
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
Ludovic Courtès April 5, 2021, 4:03 p.m. UTC | #2 
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’.
Ludovic Courtès April 6, 2021, 10:01 p.m. UTC | #3 
Pushed as 709f30b8e466b5f7155255be4f2cee008f8d01a9 with changes as
Mathieu suggested.  Thanks for your feedback!

Ludo’.
diff mbox series

Patch

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)