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.scm91
1 files changed, 77 insertions, 14 deletions
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 031a899a6c..fece84b341 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -31,7 +31,7 @@
#:use-module (srfi srfi-34)
#:use-module (rnrs io ports)
#:use-module (system foreign)
- #:use-module (guix http-client)
+ #:use-module ((guix http-client) #:hide (open-socket-for-uri))
#:use-module (guix ftp-client)
#:use-module (guix utils)
#:use-module (guix memoization)
@@ -66,6 +66,7 @@
%gnu-updater
%gnu-ftp-updater
%savannah-updater
+ %sourceforge-updater
%xorg-updater
%kernel.org-updater
%generic-html-updater))
@@ -242,7 +243,7 @@ network to check in GNU's database."
;; 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".
;; Accept underscores as in "PKG_1.2.tar.gz" for some non-GNU packages.
- (make-regexp "^([^.]+)[-_]([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)"))
+ (make-regexp "^([^.]+)[-_]([0-9]|[^-])+(-(src|[sS]ource|gnu[0-9]))?\\.(tar\\.|zip$)"))
(define %alpha-tarball-rx
(make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
@@ -595,7 +596,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|\\.src|\\.orig)?"))
(define (gnu-package-name->name+version name+version)
"Return the package name and version number extracted from NAME+VERSION."
@@ -637,9 +638,6 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
(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
@@ -663,6 +661,59 @@ 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 port)
+ ;; Return true if URI is reachable.
+ (false-if-exception
+ (case (response-code (http-head uri #:port port #:keep-alive? #t))
+ ((200 302) #t)
+ (else #f))))
+
+ (let* ((name (package-upstream-name package))
+ (base (string-append "https://sourceforge.net/projects/"
+ name "/files"))
+ (url (string-append base "/latest/download"))
+ (uri (string->uri url))
+ (port (false-if-exception (open-socket-for-uri uri)))
+ (response (and port
+ (http-head uri #:port port #:keep-alive? #t))))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (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 port)
+ (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)))))))))))
+ (lambda ()
+ (when port
+ (close-port port))))))
+
(define (latest-xorg-release package)
"Return the latest release of PACKAGE."
(let ((uri (string->uri (origin-uri (package-source package)))))
@@ -706,14 +757,19 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
"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 http-url?
+ (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)))))))))
+
+ (lambda (package)
+ (or (assoc-ref (package-properties package) 'release-monitoring-url)
+ (http-url? package)))))
(define (latest-html-updatable-release package)
"Return the latest release of PACKAGE. Do that by crawling the HTML page of
@@ -772,6 +828,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)