;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
#:use-module (web uri)
#:use-module (web client)
#:use-module (web response)
+ #:use-module (sxml simple)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (rnrs io ports)
#:use-module (system foreign)
#:use-module (guix http-client)
#:use-module (guix ftp-client)
#:use-module (guix utils)
+ #:use-module (guix memoization)
#:use-module (guix records)
#:use-module (guix upstream)
#:use-module (guix packages)
- #:use-module (gnu packages)
+ #:use-module (guix zlib)
#:export (gnu-package-name
gnu-package-mundane-name
gnu-package-copyright-holder
gnu-package-download-url
official-gnu-packages
- find-packages
+ find-package
gnu-package?
release-file?
gnu-package-name->name+version
%gnu-updater
- %gnome-updater
- %xorg-updater))
+ %gnu-ftp-updater
+ %xorg-updater
+ %kernel.org-updater))
;;; Commentary:
;;;
;;;
(define %gnumaint-base-url
- "http://cvs.savannah.gnu.org/viewvc/*checkout*/gnumaint/")
+ "https://web.cvs.savannah.gnu.org/viewvc/*checkout*/www/www/prep/gnumaint/")
(define %package-list-url
(string->uri
- (string-append %gnumaint-base-url "gnupackages.txt?root=womb")))
+ (string-append %gnumaint-base-url "rec/gnupackages.rec")))
(define %package-description-url
;; This file contains package descriptions in recutils format.
- ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>.
+ ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>
+ ;; and <https://lists.gnu.org/archive/html/guix-devel/2018-06/msg00362.html>.
(string->uri
- (string-append %gnumaint-base-url "pkgblurbs.txt?root=womb")))
+ (string-append %gnumaint-base-url "rec/pkgblurbs.rec")))
(define-record-type* <gnu-package-descriptor>
gnu-package-descriptor
(if (null? alist)
(reverse result)
(loop (recutils->alist port)
- (cons alist result)))))
+
+ ;; Ignore things like "%rec" (info "(recutils) Record
+ ;; Descriptors").
+ (if (assoc-ref alist "package")
+ (cons alist result)
+ result)))))
(define official-description
(let ((db (read-records (fetch %package-description-url #:text? #t))))
(alist->record `(("description" . ,(official-description name))
,@alist)
make-gnu-package-descriptor
- (list "package" "mundane-name" "copyright-holder"
+ (list "package" "mundane_name" "copyright_holder"
"savannah" "fsd" "language" "logo"
- "doc-category" "doc-summary" "description"
- "doc-url"
- "download-url")
- '("doc-url" "language"))))
+ "doc_category" "doc_summary" "description"
+ "doc_url"
+ "download_url")
+ '("doc_url" "language"))))
(let* ((port (fetch %package-list-url #:text? #t))
(lst (read-records port)))
(close-port port)
lst)))
-(define (find-packages regexp)
- "Find GNU packages which satisfy REGEXP."
- (let ((name-rx (make-regexp regexp)))
- (filter (lambda (package)
- (false-if-exception
- (regexp-exec name-rx (gnu-package-name package))))
- (official-gnu-packages))))
+(define (find-package name)
+ "Find GNU package called NAME and return it. Return #f if it was not
+found."
+ (find (lambda (package)
+ (string=? name (gnu-package-name package)))
+ (official-gnu-packages)))
(define gnu-package?
- (memoize
- (let ((official-gnu-packages (memoize official-gnu-packages)))
- (lambda (package)
- "Return true if PACKAGE is a GNU package. This procedure may access the
+ (let ((official-gnu-packages (memoize official-gnu-packages)))
+ (mlambdaq (package)
+ "Return true if PACKAGE is a GNU package. This procedure may access the
network to check in GNU's database."
- (define (mirror-type url)
- (let ((uri (string->uri url)))
- (and (eq? (uri-scheme uri) 'mirror)
- (cond
- ((member (uri-host uri)
- '("gnu" "gnupg" "gcc" "gnome"))
- ;; Definitely GNU.
- 'gnu)
- ((equal? (uri-host uri) "cran")
- ;; Possibly GNU: mirror://cran could be either GNU R itself
- ;; or a non-GNU package.
- #f)
- (else
- ;; Definitely non-GNU.
- 'non-gnu)))))
-
- (define (gnu-home-page? package)
- (and=> (package-home-page package)
- (lambda (url)
- (and=> (uri-host (string->uri url))
- (lambda (host)
- (member host '("www.gnu.org" "gnu.org")))))))
-
- (or (gnu-home-page? package)
- (let ((url (and=> (package-source package) origin-uri))
- (name (package-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)))))))))
+ (define (mirror-type url)
+ (let ((uri (string->uri url)))
+ (and (eq? (uri-scheme uri) 'mirror)
+ (cond
+ ((member (uri-host uri)
+ '("gnu" "gnupg" "gcc" "gnome"))
+ ;; Definitely GNU.
+ 'gnu)
+ ((equal? (uri-host uri) "cran")
+ ;; Possibly GNU: mirror://cran could be either GNU R itself
+ ;; or a non-GNU package.
+ #f)
+ (else
+ ;; Definitely non-GNU.
+ 'non-gnu)))))
+
+ (define (gnu-home-page? package)
+ (letrec-syntax ((>> (syntax-rules ()
+ ((_ value proc)
+ (and=> value proc))
+ ((_ value proc rest ...)
+ (and=> value
+ (lambda (next)
+ (>> (proc next) rest ...)))))))
+ (>> package package-home-page
+ string->uri uri-host
+ (lambda (host)
+ (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))))))))
\f
;;;
-;;; Latest release.
+;;; Latest FTP release.
;;;
-(define (ftp-server/directory project)
- "Return the FTP server and directory where PROJECT's tarball are
-stored."
- (define quirks
- '(("commoncpp2" "ftp.gnu.org" "/gnu/commoncpp")
- ("ucommon" "ftp.gnu.org" "/gnu/commoncpp")
- ("libzrtpcpp" "ftp.gnu.org" "/gnu/ccrtp")
- ("libosip2" "ftp.gnu.org" "/gnu/osip")
- ("libgcrypt" "ftp.gnupg.org" "/gcrypt/libgcrypt")
- ("libgpg-error" "ftp.gnupg.org" "/gcrypt/libgpg-error")
- ("libassuan" "ftp.gnupg.org" "/gcrypt/libassuan")
- ("gnupg" "ftp.gnupg.org" "/gcrypt/gnupg")
- ("freefont-ttf" "ftp.gnu.org" "/gnu/freefont")
- ("gnu-ghostscript" "ftp.gnu.org" "/gnu/ghostscript")
- ("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg")
- ("icecat" "ftp.gnu.org" "/gnu/gnuzilla")
- ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite")
- ("gnutls" "ftp.gnutls.org" "/gcrypt/gnutls")
-
- ;; FIXME: ftp.texmacs.org is currently outdated; texmacs.org refers to
- ;; its own http URL instead.
- ("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz")))
-
- (match (assoc project quirks)
- ((_ server directory)
- (values server directory))
- (_
- (values "ftp.gnu.org" (string-append "/gnu/" project)))))
-
-(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 (ftp-server/directory package)
+ "Return the FTP server and directory where PACKAGE's tarball are stored."
+ (let ((name (package-upstream-name package)))
+ (values (or (assoc-ref (package-properties package) 'ftp-server)
+ "ftp.gnu.org")
+ (or (assoc-ref (package-properties package) 'ftp-directory)
+ (string-append "/gnu/" name)))))
(define %tarball-rx
;; The .zip extensions is notably used for freefont-ttf.
(define (release-file? project file)
"Return #f if FILE is not a release tarball of PROJECT, otherwise return
true."
- (and (not (string-suffix? ".sig" file))
+ (and (not (member (file-extension file) '("sig" "sign" "asc")))
(and=> (regexp-exec %tarball-rx file)
(lambda (match)
;; Filter out unrelated files, like `guile-www-1.1.1'.
;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
+ ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
(and=> (match:substring match 1)
(lambda (name)
- (string-ci=? name project)))))
+ (or (string-ci=? name project)
+ (string-ci=? name
+ (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)
- "Return the list of releases of PROJECT as a list of release name/directory
-pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). "
+(define* (releases project
+ #:key
+ (server "ftp.gnu.org")
+ (directory (string-append "/gnu/" project)))
+ "Return the list of <upstream-release> of PROJECT as a list of release
+name/directory pairs."
;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
- (let-values (((server directory) (ftp-server/directory project)))
- (define conn (ftp-open server))
+ (define conn (ftp-open server))
- (let loop ((directories (list directory))
- (result '()))
- (match directories
- (()
- (ftp-close conn)
- (coalesce-sources result))
- ((directory rest ...)
- (let* ((files (ftp-list conn directory))
- (subdirs (filter-map (match-lambda
- ((name 'directory . _) name)
- (_ #f))
- files)))
- (define (file->url file)
- (string-append "ftp://" server directory "/" file))
-
- (define (file->source file)
- (let ((url (file->url file)))
- (upstream-source
- (package project)
- (version (tarball->version file))
- (urls (list url))
- (signature-urls (list (string-append url ".sig"))))))
-
- (loop (append (map (cut string-append directory "/" <>)
- subdirs)
- rest)
- (append
- ;; Filter out signatures, deltas, and files which
- ;; are potentially not releases of PROJECT--e.g.,
- ;; in /gnu/guile, filter out guile-oops and
- ;; guile-www; in mit-scheme, filter out binaries.
- (filter-map (match-lambda
- ((file 'file . _)
- (and (release-file? project file)
- (file->source file)))
- (_ #f))
- files)
- result))))))))
+ (let loop ((directories (list directory))
+ (result '()))
+ (match directories
+ (()
+ (ftp-close conn)
+ (coalesce-sources result))
+ ((directory rest ...)
+ (let* ((files (ftp-list conn directory))
+ (subdirs (filter-map (match-lambda
+ ((name 'directory . _) name)
+ (_ #f))
+ files)))
+ (define (file->url file)
+ (string-append "ftp://" server directory "/" file))
+
+ (define (file->source file)
+ (let ((url (file->url file)))
+ (upstream-source
+ (package project)
+ (version (tarball->version file))
+ (urls (list url))
+ (signature-urls (list (string-append url ".sig"))))))
+
+ (loop (append (map (cut string-append directory "/" <>)
+ subdirs)
+ rest)
+ (append
+ ;; Filter out signatures, deltas, and files which
+ ;; are potentially not releases of PROJECT--e.g.,
+ ;; in /gnu/guile, filter out guile-oops and
+ ;; guile-www; in mit-scheme, filter out binaries.
+ (filter-map (match-lambda
+ ((file 'file . _)
+ (and (release-file? project file)
+ (file->source file)))
+ (_ #f))
+ files)
+ result)))))))
(define* (latest-ftp-release project
#:key
(if (version>? (upstream-source-version a) (upstream-source-version b))
a b))
- (define contains-digit?
- (cut string-any char-set:digit <>))
-
(define patch-directory-name?
;; Return #t for patch directory names such as 'bash-4.2-patches'.
(cut string-suffix? "patches" <>))
(result #f))
(let* ((entries (ftp-list conn directory))
- ;; Filter out sub-directories that do not contain digits---e.g.,
- ;; /gnuzilla/lang and /gnupg/patches. Filter out "w32"
+ ;; Filter out things like /gnupg/patches. Filter out "w32"
;; directories as found on ftp.gnutls.org.
(subdirs (filter-map (match-lambda
(((? patch-directory-name? dir)
#f)
(("w32" 'directory . _)
#f)
- (((? contains-digit? dir) 'directory . _)
- (and (keep-file? dir) dir))
+ (("unstable" 'directory . _)
+ ;; As seen at ftp.gnupg.org/gcrypt/pinentry.
+ #f)
+ ((directory 'directory . _)
+ directory)
(_ #f))
entries))
(ftp-close conn)
result))))))
-(define (latest-release package . rest)
+(define* (latest-release package
+ #:key
+ (server "ftp.gnu.org")
+ (directory (string-append "/gnu/" package)))
"Return the <upstream-source> for the latest version of PACKAGE or #f.
-PACKAGE is the name of a GNU package. This procedure automatically uses the
-right FTP server and directory for PACKAGE."
- (let-values (((server directory) (ftp-server/directory package)))
- (apply latest-ftp-release package
- #:server server
- #:directory directory
- rest)))
+PACKAGE must be the canonical name of a GNU package."
+ (latest-ftp-release package
+ #:server server
+ #:directory directory))
(define-syntax-rule (false-if-ftp-error exp)
"Return #f if an FTP error is raise while evaluating EXP; return the result
#f)))
(define (latest-release* package)
- "Like 'latest-release', but ignore FTP errors that might occur when PACKAGE
-is not actually a GNU package, or not hosted on ftp.gnu.org, or not under that
-name (this is the case for \"emacs-auctex\", for instance.)"
- (false-if-ftp-error (latest-release package)))
+ "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP
+errors that might occur when PACKAGE is not actually a GNU package, or not
+hosted on ftp.gnu.org, or not under that name (this is the case for
+\"emacs-auctex\", for instance.)"
+ (let-values (((server directory)
+ (ftp-server/directory package)))
+ (false-if-ftp-error (latest-release (package-upstream-name package)
+ #:server server
+ #:directory directory))))
+
+\f
+;;;
+;;; 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)
+ (links '()))
+ (match sxml
+ (('a ('@ attributes ...) body ...)
+ (match (assq 'href attributes)
+ (#f (fold loop links body))
+ (('href url) (fold loop (cons url links) body))))
+ ((tag ('@ _ ...) body ...)
+ (fold loop links body))
+ ((tag body ...)
+ (fold loop links body))
+ (_
+ links))))
+
+(define* (latest-html-release package
+ #:key
+ (base-url "https://kernel.org/pub")
+ (directory (string-append "/" package))
+ (file->signature (cut string-append <> ".sig")))
+ "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)))
+ (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 (string-append base-url directory "/"
+ (file-sans-extension url)
+ ".sign")))))))
+
+ (define candidates
+ (filter-map url->release (html-links sxml)))
+
+ (close-port port)
+ (match candidates
+ (() #f)
+ ((first . _)
+ ;; Select the most recent release and return it.
+ (reduce (lambda (r1 r2)
+ (if (version>? (upstream-source-version r1)
+ (upstream-source-version r2))
+ r1 r2))
+ first
+ (coalesce-sources candidates))))))
+
+\f
+;;;
+;;; Updaters.
+;;;
+
+(define %gnu-file-list-uri
+ ;; URI of the file list for ftp.gnu.org.
+ (string->uri "https://ftp.gnu.org/find.txt.gz"))
+
+(define ftp.gnu.org-files
+ (mlambda ()
+ "Return the list of files available at ftp.gnu.org."
+
+ ;; XXX: Memoize the whole procedure to work around the fact that
+ ;; 'http-fetch/cached' caches the gzipped version.
+
+ (define (trim-leading-components str)
+ ;; Trim the leading ".", if any, in "./gnu/foo".
+ (string-trim str (char-set #\.)))
+
+ (define (string->lines str)
+ (string-tokenize str (char-set-complement (char-set #\newline))))
+
+ ;; Since https://ftp.gnu.org honors 'If-Modified-Since', the hard-coded
+ ;; TTL can be relatively short.
+ (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 15 60))))
+ (map trim-leading-components
+ (call-with-gzip-input-port port
+ (compose string->lines get-string-all))))))
+
+(define (latest-gnu-release package)
+ "Return the latest release of PACKAGE, a GNU package available via
+ftp.gnu.org.
+
+This method does not rely on FTP access at all; instead, it browses the file
+list available from %GNU-FILE-LIST-URI over HTTP(S)."
+ (let-values (((server directory)
+ (ftp-server/directory package))
+ ((name)
+ (package-upstream-name package)))
+ (let* ((files (ftp.gnu.org-files))
+ (relevant (filter (lambda (file)
+ (and (string-prefix? "/gnu" file)
+ (string-contains file directory)
+ (release-file? name (basename file))))
+ files)))
+ (match (sort relevant (lambda (file1 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=? (tarball-sans-extension
+ (basename file))
+ (tarball-sans-extension
+ (basename reference))))
+ tarballs)))
+ (upstream-source
+ (package name)
+ (version version)
+ (urls (map (lambda (file)
+ (string-append "mirror://gnu/"
+ (string-drop file
+ (string-length "/gnu/"))))
+ tarballs))
+ (signature-urls (map (cut string-append <> ".sig") urls)))))
+ (()
+ #f)))))
(define %package-name-rx
;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
(values name+version #f)
(values (match:substring match 1) (match:substring match 2)))))
+(define gnome-package?
+ (url-prefix-predicate "mirror://gnome/"))
+
(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."
- (and (not (string-prefix? "emacs-" (package-name package)))
+elpa.gnu.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))
(gnu-package? package)))
-(define (gnome-package? package)
- "Return true if PACKAGE is a GNOME package, hosted on gnome.org."
- (define gnome-uri?
- (match-lambda
- ((? string? uri)
- (string-prefix? "mirror://gnome/" uri))
- (_
- #f)))
-
- (match (package-source package)
- ((? origin? origin)
- (match (origin-uri origin)
- ((? gnome-uri?) #t)
- (_ #f)))
- (_ #f)))
-
-(define (latest-gnome-release package)
- "Return the latest release of PACKAGE, the name of a GNOME package."
- (define %not-dot
- (char-set-complement (char-set #\.)))
-
- (define (even-minor-version? version)
- (match (string-tokenize version %not-dot)
- (((= string->number major) (= string->number minor) . rest)
- (and minor (even? minor)))
- (_
- #t))) ;cross fingers
-
- (define (even-numbered? file)
- ;; Return true if FILE somehow denotes an even-numbered file name. The
- ;; trick here is that we want this to match both directories such as
- ;; "3.18.6" and actual file names such as "gtk+-3.18.6.tar.bz2".
- (let-values (((name version) (package-name->name+version file)))
- (even-minor-version? (or version name))))
-
- (false-if-ftp-error
- (latest-ftp-release package
- #:server "ftp.gnome.org"
- #:directory (string-append "/pub/gnome/sources/"
- (match package
- ("gconf" "GConf")
- (x x)))
-
-
- ;; <https://www.gnome.org/gnome-3/source/> explains
- ;; that odd minor version numbers represent development
- ;; releases, which we are usually not interested in.
- #:keep-file? even-numbered?
-
- ;; ftp.gnome.org provides no signatures, only
- ;; checksums.
- #:file->signature (const #f))))
-
-(define (xorg-package? package)
- "Return true if PACKAGE is an X.org package, developed by X.org."
- (define xorg-uri?
- (match-lambda
- ((? string? uri)
- (string-prefix? "mirror://xorg/" uri))
- (_
- #f)))
-
- (match (package-source package)
- ((? origin? origin)
- (match (origin-uri origin)
- ((? xorg-uri?) #t)
- (_ #f)))
- (_ #f)))
+(define gnu-hosted?
+ (url-prefix-predicate "mirror://gnu/"))
(define (latest-xorg-release package)
"Return the latest release of PACKAGE, the name of an X.org package."
- (let ((uri (string->uri (origin-uri (package-source (specification->package package))))))
+ (let ((uri (string->uri (origin-uri (package-source package)))))
(false-if-ftp-error
(latest-ftp-release
- package
+ (package-name package)
#:server "ftp.freedesktop.org"
#:directory
(string-append "/pub/xorg/" (dirname (uri-path uri)))))))
+(define (latest-kernel.org-release package)
+ "Return the latest release of PACKAGE, the name of a kernel.org package."
+ (define %kernel.org-base
+ ;; This URL and sub-directories thereof are nginx-generated directory
+ ;; listings suitable for 'latest-html-release'.
+ "https://mirrors.edge.kernel.org/pub")
+
+ (define (file->signature file)
+ (string-append (file-sans-extension file) ".sign"))
+
+ (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 %kernel.org-base
+ #:directory directory
+ #:file->signature file->signature)))
+
(define %gnu-updater
+ ;; This is for everything at ftp.gnu.org.
(upstream-updater
(name 'gnu)
(description "Updater for GNU packages")
- (pred pure-gnu-package?)
- (latest latest-release*)))
+ (pred gnu-hosted?)
+ (latest latest-gnu-release)))
-(define %gnome-updater
+(define %gnu-ftp-updater
+ ;; This is for GNU packages taken from alternate locations, such as
+ ;; alpha.gnu.org, ftp.gnupg.org, etc. It is obsolescent.
(upstream-updater
- (name 'gnome)
- (description "Updater for GNOME packages")
- (pred gnome-package?)
- (latest latest-gnome-release)))
+ (name 'gnu-ftp)
+ (description "Updater for GNU packages only available via FTP")
+ (pred (lambda (package)
+ (and (not (gnu-hosted? package))
+ (pure-gnu-package? package))))
+ (latest latest-release*)))
(define %xorg-updater
(upstream-updater
(name 'xorg)
(description "Updater for X.org packages")
- (pred xorg-package?)
+ (pred (url-prefix-predicate "mirror://xorg/"))
(latest latest-xorg-release)))
+(define %kernel.org-updater
+ (upstream-updater
+ (name 'kernel.org)
+ (description "Updater for packages hosted on kernel.org")
+ (pred (url-prefix-predicate "mirror://kernel.org/"))
+ (latest latest-kernel.org-release)))
+
;;; gnu-maintenance.scm ends here