;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
#: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
%gnu-updater
%gnu-ftp-updater
- %kde-updater
+ %savannah-updater
%xorg-updater
%kernel.org-updater))
;;;
(define %gnumaint-base-url
- "http://cvs.savannah.gnu.org/viewvc/*checkout*/womb/gnumaint/")
+ "https://web.cvs.savannah.gnu.org/viewvc/*checkout*/www/www/prep/gnumaint/")
(define %package-list-url
(string->uri
(member host '("www.gnu.org" "gnu.org"))))))
(or (gnu-home-page? package)
- (let ((url (and=> (package-source package) origin-uri))
- (name (package-upstream-name package)))
- (case (and (string? url) (mirror-type url))
- ((gnu) #t)
- ((non-gnu) #f)
- (else
- (and (member name (map gnu-package-name (official-gnu-packages)))
- #t))))))))
+ (match (package-source package)
+ ((? origin? origin)
+ (let ((url (origin-uri origin))
+ (name (package-upstream-name package)))
+ (case (and (string? url) (mirror-type url))
+ ((gnu) #t)
+ ((non-gnu) #f)
+ (else
+ (and (member name (map gnu-package-name (official-gnu-packages)))
+ #t)))))
+ (_ #f))))))
\f
;;;
(or (assoc-ref (package-properties package) 'ftp-directory)
(string-append "/gnu/" name)))))
-(define (sans-extension tarball)
- "Return TARBALL without its .tar.* or .zip extension."
- (let ((end (or (string-contains tarball ".tar")
- (string-contains tarball ".zip"))))
- (substring tarball 0 end)))
-
(define %tarball-rx
;; The .zip extensions is notably used for freefont-ttf.
;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
(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
(string-append project
"-src")))))))
(not (regexp-exec %alpha-tarball-rx file))
- (let ((s (sans-extension file)))
+ (let ((s (tarball-sans-extension file)))
(regexp-exec %package-name-rx s))))
(define (tarball->version tarball)
"Return the version TARBALL corresponds to. TARBALL is a file name like
\"coreutils-8.23.tar.xz\"."
(let-values (((name version)
- (gnu-package-name->name+version (sans-extension tarball))))
+ (gnu-package-name->name+version
+ (tarball-sans-extension tarball))))
version))
(define* (releases project
(and (string=? url (basename url)) ;relative reference?
(release-file? package url)
(let-values (((name version)
- (package-name->name+version (sans-extension url)
- #\-)))
+ (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 (string-append base-url directory "/"
- (file-sans-extension url)
- ".sign")))))))
+ (list (file->signature
+ (string-append base-url directory "/" url))))))))
(define candidates
(filter-map url->release (html-links sxml)))
(release-file? name (basename file))))
files)))
(match (sort relevant (lambda (file1 file2)
- (version>? (sans-extension (basename file1))
- (sans-extension (basename file2)))))
+ (version>? (tarball-sans-extension
+ (basename file1))
+ (tarball-sans-extension
+ (basename file2)))))
((and tarballs (reference _ ...))
(let* ((version (tarball->version reference))
(tarballs (filter (lambda (file)
- (string=? (sans-extension
+ (string=? (tarball-sans-extension
(basename file))
- (sans-extension
+ (tarball-sans-extension
(basename reference))))
tarballs)))
(upstream-source
(define gnu-hosted?
(url-prefix-predicate "mirror://gnu/"))
-(define (latest-kde-release package)
- "Return the latest release of PACKAGE, the name of an KDE.org package."
- (let ((uri (string->uri (origin-uri (package-source package)))))
- (false-if-ftp-error
- (latest-ftp-release
- (package-upstream-name package)
- #:server "mirrors.mit.edu"
- #:directory
- (string-append "/kde" (dirname (dirname (uri-path uri))))))))
+(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
(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.
(pure-gnu-package? package))))
(latest latest-release*)))
-(define %kde-updater
+(define %savannah-updater
(upstream-updater
- (name 'kde)
- (description "Updater for KDE packages")
- (pred (url-prefix-predicate "mirror://kde/"))
- (latest latest-kde-release)))
+ (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
HCoop / jackhill / guix / guix.git / blobdiff