;;; 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 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)
%gnu-updater
%gnu-ftp-updater
- %kde-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
\f
;;;
-;;; Latest release.
+;;; Latest FTP release.
;;;
(define (ftp-server/directory package)
(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".
(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'.
(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
#: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"))
(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))))
- #:file->signature (const #f)))))
-
(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 package)))))
(define (latest-kernel.org-release package)
"Return the latest release of PACKAGE, the name of a kernel.org package."
- (let ((uri (string->uri (origin-uri (package-source package)))))
- (false-if-ftp-error
- (latest-ftp-release
- (package-name package)
- #:server "ftp.free.fr" ;a mirror reachable over FTP
- #:directory (string-append "/mirrors/ftp.kernel.org"
- (dirname (uri-path uri)))
-
- ;; kernel.org provides "foo-x.y.tar.sign" files, which are signatures of
- ;; the uncompressed tarball.
- #:file->signature (lambda (tarball)
- (string-append (file-sans-extension tarball)
- ".sign"))))))
+ (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.
(pure-gnu-package? package))))
(latest latest-release*)))
-(define %kde-updater
- (upstream-updater
- (name 'kde)
- (description "Updater for KDE packages")
- (pred (url-prefix-predicate "mirror://kde/"))
- (latest latest-kde-release)))
-
(define %xorg-updater
(upstream-updater
(name 'xorg)
HCoop / jackhill / guix / guix.git / blobdiff