gnu: surgescript: Update to 0.5.4.4.

[jackhill/guix/guix.git] / guix / gnu-maintenance.scm

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index a1273ab..08b2bcf 100644 (file)
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -36,7 +36,7 @@
   #:use-module (guix records)
   #:use-module (guix upstream)
   #:use-module (guix packages)
-  #:use-module (guix zlib)
+  #:use-module (zlib)
   #:export (gnu-package-name
             gnu-package-mundane-name
             gnu-package-copyright-holder
@@ -62,6 +62,7 @@
 
             %gnu-updater
             %gnu-ftp-updater
+            %savannah-updater
             %xorg-updater
             %kernel.org-updater))
 
@@ -239,7 +240,7 @@ network to check in GNU's database."
   (make-regexp "^([^.]+)-([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)"))
 
 (define %alpha-tarball-rx
-  (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
+  (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 
 (define (release-file? project file)
   "Return #f if FILE is not a release tarball of PROJECT, otherwise return
@@ -614,8 +615,51 @@ releases are on gnu.org."
 (define gnu-hosted?
   (url-prefix-predicate "mirror://gnu/"))
 
+(define (url-prefix-rewrite old new)
+  "Return a one-argument procedure that rewrites URL prefix OLD to NEW."
+  (lambda (url)
+    (if (string-prefix? old url)
+        (string-append new (string-drop url (string-length old)))
+        url)))
+
+(define (adjusted-upstream-source source rewrite-url)
+  "Rewrite URLs in SOURCE by apply REWRITE-URL to each of them."
+  (upstream-source
+   (inherit source)
+   (urls (map rewrite-url (upstream-source-urls source)))
+   (signature-urls (and=> (upstream-source-signature-urls source)
+                          (lambda (urls)
+                            (map rewrite-url urls))))))
+
+(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
+                     (match (origin-uri (package-source package))
+                       ((? string? uri) uri)
+                       ((uri mirrors ...) uri))))
+         (package   (package-upstream-name package))
+         (directory (dirname (uri-path uri)))
+         (rewrite   (url-prefix-rewrite %savannah-base
+                                        "mirror://savannah")))
+    ;; Note: We use the default 'file->signature', which adds ".sig", but not
+    ;; all projects on Savannah follow that convention: some use ".asc" and
+    ;; perhaps some lack signatures altogether.
+    (and=> (latest-html-release package
+                                #:base-url %savannah-base
+                                #:directory directory)
+           (cut adjusted-upstream-source <> rewrite))))
+
 (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
@@ -634,13 +678,19 @@ releases are on gnu.org."
   (define (file->signature file)
     (string-append (file-sans-extension file) ".sign"))
 
-  (let* ((uri       (string->uri (origin-uri (package-source package))))
+  (let* ((uri       (string->uri
+                     (match (origin-uri (package-source package))
+                       ((? string? uri) uri)
+                       ((uri mirrors ...) uri))))
          (package   (package-upstream-name package))
-         (directory (dirname (uri-path uri))))
-    (latest-html-release package
-                         #:base-url %kernel.org-base
-                         #:directory directory
-                         #:file->signature file->signature)))
+         (directory (dirname (uri-path uri)))
+         (rewrite   (url-prefix-rewrite %kernel.org-base
+                                        "mirror://kernel.org")))
+    (and=> (latest-html-release package
+                                #:base-url %kernel.org-base
+                                #:directory directory
+                                #:file->signature file->signature)
+           (cut adjusted-upstream-source <> rewrite))))
 
 (define %gnu-updater
   ;; This is for everything at ftp.gnu.org.
@@ -661,6 +711,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)