06/11: gnu-maintenance: Add 'savannah' updater.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 7a6bb2fe5b69ca6d3fdd118c4d211cef94df6ddc
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Jul 20 20:36:53 2020 +0200

    gnu-maintenance: Add 'savannah' updater.
    
    * guix/gnu-maintenance.scm (savannah-package?, %savannah-base)
    (%savannah-updater): New variables.
    (latest-savannah-release): New procedure.
    (latest-xorg-release): Fix docstring.
---
 guix/gnu-maintenance.scm | 28 +++++++++++++++++++++++++++-
 1 file changed, 27 insertions(+), 1 deletion(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index a1273ab..702848e 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -62,6 +62,7 @@
 
             %gnu-updater
             %gnu-ftp-updater
+            %savannah-updater
             %xorg-updater
             %kernel.org-updater))
 
@@ -614,8 +615,26 @@ releases are on gnu.org."
 (define gnu-hosted?
   (url-prefix-predicate "mirror://gnu/"))
 
+(define savannah-package?
+  (url-prefix-predicate "mirror://savannah/"))
+
+(define %savannah-base
+  ;; One of the Savannah mirrors listed at
+  ;; <http://download0.savannah.gnu.org/mirmon/savannah/> that serves valid
+  ;; HTML (unlike <https://download.savannah.nongnu.org/releases>.)
+  "https://nongnu.freemirror.org/nongnu";)
+
+(define (latest-savannah-release package)
+  "Return the latest release of PACKAGE."
+  (let* ((uri       (string->uri (origin-uri (package-source package))))
+         (package   (package-upstream-name package))
+         (directory (dirname (uri-path uri))))
+    (latest-html-release package
+                         #:base-url %savannah-base
+                         #:directory directory)))
+
 (define (latest-xorg-release package)
-  "Return the latest release of PACKAGE, the name of an X.org package."
+  "Return the latest release of PACKAGE."
   (let ((uri (string->uri (origin-uri (package-source package)))))
     (false-if-ftp-error
      (latest-ftp-release
@@ -661,6 +680,13 @@ releases are on gnu.org."
                 (pure-gnu-package? package))))
    (latest latest-release*)))
 
+(define %savannah-updater
+  (upstream-updater
+   (name 'savannah)
+   (description "Updater for packages hosted on savannah.gnu.org")
+   (pred (url-prefix-predicate "mirror://savannah/"))
+   (latest latest-savannah-release)))
+
 (define %xorg-updater
   (upstream-updater
    (name 'xorg)