summaryrefslogtreecommitdiff
path: root/guix/gnu-maintenance.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/gnu-maintenance.scm')
-rw-r--r--guix/gnu-maintenance.scm162
1 files changed, 110 insertions, 52 deletions
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 0da6fc19b6..031a899a6c 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
@@ -28,6 +28,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
#:use-module (rnrs io ports)
#:use-module (system foreign)
#:use-module (guix http-client)
@@ -37,7 +38,8 @@
#:use-module (guix records)
#:use-module (guix upstream)
#:use-module (guix packages)
- #:use-module (zlib)
+ #:autoload (zlib) (call-with-gzip-input-port)
+ #:autoload (htmlprag) (html->sxml) ;from Guile-Lib
#:export (gnu-package-name
gnu-package-mundane-name
gnu-package-copyright-holder
@@ -65,7 +67,8 @@
%gnu-ftp-updater
%savannah-updater
%xorg-updater
- %kernel.org-updater))
+ %kernel.org-updater
+ %generic-html-updater))
;;; Commentary:
;;;
@@ -238,7 +241,8 @@ network to check in GNU's database."
;; The .zip extensions is notably used for freefont-ttf.
;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2".
- (make-regexp "^([^.]+)-([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)"))
+ ;; Accept underscores as in "PKG_1.2.tar.gz" for some non-GNU packages.
+ (make-regexp "^([^.]+)[-_]([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)"))
(define %alpha-tarball-rx
(make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
@@ -246,7 +250,9 @@ network to check in GNU's database."
(define (release-file? project file)
"Return #f if FILE is not a release tarball of PROJECT, otherwise return
true."
- (and (not (member (file-extension file) '("sig" "sign" "asc")))
+ (and (not (member (file-extension file)
+ '("sig" "sign" "asc"
+ "md5sum" "sha1sum" "sha256sum")))
(and=> (regexp-exec %tarball-rx file)
(lambda (match)
;; Filter out unrelated files, like `guile-www-1.1.1'.
@@ -322,16 +328,11 @@ name/directory pairs."
#:key
(server "ftp.gnu.org")
(directory (string-append "/gnu/" project))
- (keep-file? (const #t))
- (file->signature (cut string-append <> ".sig"))
- (ftp-open ftp-open) (ftp-close ftp-close))
+ (file->signature (cut string-append <> ".sig")))
"Return an <upstream-source> for the latest release of PROJECT on SERVER
under DIRECTORY, or #f. Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP
connections; this can be useful to reuse connections.
-KEEP-FILE? is a predicate to decide whether to enter a directory and to
-consider a given file (source tarball) as a valid candidate based on its name.
-
FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
return the corresponding signature URL, or #f it signatures are unavailable."
(define (latest a b)
@@ -345,7 +346,7 @@ return the corresponding signature URL, or #f it signatures are unavailable."
;; Return #t for patch directory names such as 'bash-4.2-patches'.
(cut string-suffix? "patches" <>))
- (define conn (ftp-open server))
+ (define conn (ftp-open server #:timeout 5))
(define (file->url directory file)
(string-append "ftp://" server directory "/" file))
@@ -389,7 +390,6 @@ return the corresponding signature URL, or #f it signatures are unavailable."
(releases (filter-map (match-lambda
((file 'file . _)
(and (release-file? project file)
- (keep-file? file)
(file->source directory file)))
(_ #f))
entries)))
@@ -447,18 +447,6 @@ hosted on ftp.gnu.org, or not under that name (this is the case for
;;; Latest HTTP release.
;;;
-(define (html->sxml port)
- "Read HTML from PORT and return the corresponding SXML tree."
- (let ((str (get-string-all port)))
- (catch #t
- (lambda ()
- ;; XXX: This is the poor developer's HTML-to-XML converter. It's good
- ;; enough for directory listings at <https://kernel.org/pub> but if
- ;; needed we could resort to (htmlprag) from Guile-Lib.
- (call-with-input-string (string-replace-substring str "<hr>" "<hr />")
- xml->sxml))
- (const '(html))))) ;parse error
-
(define (html-links sxml)
"Return the list of links found in SXML, the SXML tree of an HTML page."
(let loop ((sxml sxml)
@@ -479,33 +467,47 @@ hosted on ftp.gnu.org, or not under that name (this is the case for
#:key
(base-url "https://kernel.org/pub")
(directory (string-append "/" package))
- (file->signature (cut string-append <> ".sig")))
+ file->signature)
"Return an <upstream-source> for the latest release of PACKAGE (a string) on
SERVER under DIRECTORY, or #f. BASE-URL should be the URL of an HTML page,
typically a directory listing as found on 'https://kernel.org/pub'.
-FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
-return the corresponding signature URL, or #f it signatures are unavailable."
- (let* ((uri (string->uri (string-append base-url directory "/")))
- (port (http-fetch/cached uri #:ttl 3600))
- (sxml (html->sxml port)))
+When FILE->SIGNATURE is omitted or #f, guess the detached signature file name,
+if any. Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
+file URL and must return the corresponding signature URL, or #f it signatures
+are unavailable."
+ (let* ((uri (string->uri (if (string-null? directory)
+ base-url
+ (string-append base-url directory "/"))))
+ (port (http-fetch/cached uri #:ttl 3600))
+ (sxml (html->sxml port))
+ (links (delete-duplicates (html-links sxml))))
+ (define (file->signature/guess url)
+ (let ((base (basename url)))
+ (any (lambda (link)
+ (any (lambda (extension)
+ (and (string=? (string-append base extension)
+ (basename link))
+ (string-append url extension)))
+ '(".asc" ".sig" ".sign")))
+ links)))
+
(define (url->release url)
- (and (string=? url (basename url)) ;relative reference?
- (release-file? package url)
- (let-values (((name version)
- (package-name->name+version
- (tarball-sans-extension url)
- #\-)))
- (upstream-source
- (package name)
- (version version)
- (urls (list (string-append base-url directory "/" url)))
- (signature-urls
- (list (file->signature
- (string-append base-url directory "/" url))))))))
+ (let* ((base (basename url))
+ (url (if (string=? base url)
+ (string-append base-url directory "/" url)
+ url)))
+ (and (release-file? package base)
+ (let ((version (tarball->version base)))
+ (upstream-source
+ (package package)
+ (version version)
+ (urls (list url))
+ (signature-urls
+ (list ((or file->signature file->signature/guess) url))))))))
(define candidates
- (filter-map url->release (html-links sxml)))
+ (filter-map url->release links))
(close-port port)
(match candidates
@@ -593,7 +595,7 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)."
(define %package-name-rx
;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
- (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
+ (make-regexp "^(.*)[-_](([0-9]|\\.)+)(-src)?"))
(define (gnu-package-name->name+version name+version)
"Return the package name and version number extracted from NAME+VERSION."
@@ -608,11 +610,12 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)."
(define (pure-gnu-package? package)
"Return true if PACKAGE is a non-Emacs and non-GNOME GNU package. This
excludes AucTeX, for instance, whose releases are now uploaded to
-elpa.gnu.org, and all the GNOME packages; EMMS is included though, because its
-releases are on gnu.org."
+elpa.gnu.org, GNU Radio, which has releases at www.gnuradio.org, and all the
+GNOME packages; EMMS is included though, because its releases are on gnu.org."
(and (or (not (string-prefix? "emacs-" (package-name package)))
(gnu-hosted? package))
(not (gnome-package? package))
+ (not (string-prefix? "gnuradio" (package-name package)))
(gnu-package? package)))
(define gnu-hosted?
@@ -621,7 +624,7 @@ releases are on gnu.org."
(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)
+ (if (and url (string-prefix? old url))
(string-append new (string-drop url (string-length old)))
url)))
@@ -653,9 +656,8 @@ releases are on gnu.org."
(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.
+ ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
+ ;; or whichever detached signature naming scheme PACKAGE uses.
(and=> (latest-html-release package
#:base-url %savannah-base
#:directory directory)
@@ -695,6 +697,55 @@ releases are on gnu.org."
#:file->signature file->signature)
(cut adjusted-upstream-source <> rewrite))))
+(define html-updatable-package?
+ ;; Return true if the given package may be handled by the generic HTML
+ ;; updater.
+ (let ((hosting-sites '("github.com" "github.io" "gitlab.com"
+ "notabug.org" "sr.ht"
+ "gforge.inria.fr" "gitlab.inria.fr"
+ "ftp.gnu.org" "download.savannah.gnu.org"
+ "pypi.org" "crates.io" "rubygems.org"
+ "bioconductor.org")))
+ (url-predicate (lambda (url)
+ (match (string->uri url)
+ (#f #f)
+ (uri
+ (let ((scheme (uri-scheme uri))
+ (host (uri-host uri)))
+ (and (memq scheme '(http https))
+ (not (member host hosting-sites))))))))))
+
+(define (latest-html-updatable-release package)
+ "Return the latest release of PACKAGE. Do that by crawling the HTML page of
+the directory containing its source tarball."
+ (let* ((uri (string->uri
+ (match (origin-uri (package-source package))
+ ((? string? url) url)
+ ((url _ ...) url))))
+ (custom (assoc-ref (package-properties package)
+ 'release-monitoring-url))
+ (base (or custom
+ (string-append (symbol->string (uri-scheme uri))
+ "://" (uri-host uri))))
+ (directory (if custom
+ ""
+ (dirname (uri-path uri))))
+ (package (package-upstream-name package)))
+ (catch #t
+ (lambda ()
+ (guard (c ((http-get-error? c) #f))
+ (latest-html-release package
+ #:base-url base
+ #:directory directory)))
+ (lambda (key . args)
+ ;; Return false and move on upon connection failures and bogus HTTP
+ ;; servers.
+ (unless (memq key '(gnutls-error tls-certificate-error
+ system-error
+ bad-header bad-header-component))
+ (apply throw key args))
+ #f))))
+
(define %gnu-updater
;; This is for everything at ftp.gnu.org.
(upstream-updater
@@ -735,4 +786,11 @@ releases are on gnu.org."
(pred (url-prefix-predicate "mirror://kernel.org/"))
(latest latest-kernel.org-release)))
+(define %generic-html-updater
+ (upstream-updater
+ (name 'generic-html)
+ (description "Updater that crawls HTML pages.")
+ (pred html-updatable-package?)
+ (latest latest-html-updatable-release)))
+
;;; gnu-maintenance.scm ends here
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-08 13:28:28 +0000