me/guix
Archived
1
0
Fork 0
Code Activity

gnu-maintenance: Allow updating to a specific version.

Browse source 
* guix/gnu-maintenance.scm
  (latest-ftp-release): Rename to … (import-ftp-release) … this,
  add #:version argument.
  If version is given, try to find the respective version.
  (latest-html-release): Rename to … (import-html-release) … this,
  add #:version argument.
  If version is given, try to find the respective version.
  (latest-gnu-release): Rename to … (import-gnu-release) … this,
  add #:version argument. Refactor to first select archives for
  respective package, the find the requested or latest version, then create
  the upstream-source.
  (latest-release): Rename to … (import-release) … this,
  add #:version argument, pass on to … (import-ftp-release) … this.
  (import-release*): Rename to … (import-release*) … this,
  add #:version argument, pass on to … (latest-release) … this.
  (latest-savannah-release): Rename to … (import-savannah-release) … this,
  add keword-argument version, pass on to … (import-html-release) … this.
  (latest-xorg-release): Rename to … (import-xorg-release) … this,
  add keword-argument version, pass on to … (import-ftp-release) … this.
  (latest-kernel.org-release): Rename to … (import-kernel.org-release) … this,
  add #:version argument, pass on to … (import-html-release) … this.
  (latest-html-updatable-release): Rename to … (import-html-updatable-release)
  … this, add #:version argument, pass on to … (import-html-release) … this.
* guix/import/gnu.scm(gnu->guix-package): Adjust function call.
This commit is contained in:
Hartmut Goebel 2022-06-24 22:53:24 +02:00
parent abc72eeac0
commit 53af560543
No known key found for this signature in database
GPG key ID: 634A8DFFD3F631DF
2 changed files with 106 additions and 69 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

173
guix/gnu-maintenance.scm
View file

@ -66,7 +66,7 @@
release-file? release-file?
releases releases
latest-release import-release
gnu-release-archive-types gnu-release-archive-types
gnu-package-name->name+version gnu-package-name->name+version
@ -333,14 +333,17 @@ name/directory pairs."
files) files)
result))))))) result)))))))
(define* (latest-ftp-release project (define* (import-ftp-release project
#:key #:key
(version #f)
(server "ftp.gnu.org") (server "ftp.gnu.org")
(directory (string-append "/gnu/" project)) (directory (string-append "/gnu/" project))
(file->signature (cut string-append <> ".sig"))) (file->signature (cut string-append <> ".sig")))
"Return an <upstream-source> for the latest release of PROJECT on SERVER "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 under DIRECTORY, or #f. Optionally include a VERSION string to fetch a specific version.
connections; this can be useful to reuse connections.
Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP connections; this can be
useful to reuse connections.
FILE->SIGNATURE must be a procedure; it is passed a source file URL and must 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." return the corresponding signature URL, or #f it signatures are unavailable."
@ -407,8 +410,12 @@ return the corresponding signature URL, or #f it signatures are unavailable."
;; Assume that SUBDIRS correspond to versions, and jump into the ;; Assume that SUBDIRS correspond to versions, and jump into the
;; one with the highest version number. ;; one with the highest version number.
(let* ((release (reduce latest-release #f (let* ((release (if version
(coalesce-sources releases))) (find (lambda (upstream)
(string=? (upstream-source-version upstream) version))
(coalesce-sources releases))
(reduce latest-release #f
(coalesce-sources releases))))
(result (if (and result release) (result (if (and result release)
(latest-release release result) (latest-release release result)
(or release result))) (or release result)))
@ -420,13 +427,16 @@ return the corresponding signature URL, or #f it signatures are unavailable."
(ftp-close conn) (ftp-close conn)
result)))))) result))))))
(define* (latest-release package (define* (import-release package
#:key #:key
(version #f)
(server "ftp.gnu.org") (server "ftp.gnu.org")
(directory (string-append "/gnu/" package))) (directory (string-append "/gnu/" package)))
"Return the <upstream-source> for the latest version of PACKAGE or #f. "Return the <upstream-source> for the latest version of PACKAGE or #f.
PACKAGE must be the canonical name of a GNU package." PACKAGE must be the canonical name of a GNU package. Optionally include a
(latest-ftp-release package VERSION string to fetch a specific version."
(import-ftp-release package
#:version version
#:server server #:server server
#:directory directory)) #:directory directory))
@ -442,14 +452,15 @@ of EXP otherwise."
(close-port port)) (close-port port))
#f))) #f)))
(define (latest-release* package) (define* (import-release* package #:key (version #f))
"Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP "Like 'import-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 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 hosted on ftp.gnu.org, or not under that name (this is the case for
\"emacs-auctex\", for instance.)" \"emacs-auctex\", for instance.)"
(let-values (((server directory) (let-values (((server directory)
(ftp-server/directory package))) (ftp-server/directory package)))
(false-if-ftp-error (latest-release (package-upstream-name package) (false-if-ftp-error (import-release (package-upstream-name package)
#:version version
#:server server #:server server
#:directory directory)))) #:directory directory))))
@ -474,14 +485,18 @@ hosted on ftp.gnu.org, or not under that name (this is the case for
(_ (_
links)))) links))))
(define* (latest-html-release package (define* (import-html-release package
#:key #:key
(version #f)
(base-url "https://kernel.org/pub") (base-url "https://kernel.org/pub")
(directory (string-append "/" package)) (directory (string-append "/" package))
file->signature) file->signature)
"Return an <upstream-source> for the latest release of PACKAGE (a string) on "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, SERVER under DIRECTORY, or #f. Optionally include a VERSION string to fetch a
typically a directory listing as found on 'https://kernel.org/pub'. specific version.
BASE-URL should be the URL of an HTML page, typically a directory listing as
found on 'https://kernel.org/pub'.
When FILE->SIGNATURE is omitted or #f, guess the detached signature file name, 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 if any. Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
@ -554,13 +569,18 @@ are unavailable."
(match candidates (match candidates
(() #f) (() #f)
((first . _) ((first . _)
;; Select the most recent release and return it. (if version
(reduce (lambda (r1 r2) ;; find matching release version and return it
(if (version>? (upstream-source-version r1) (find (lambda (upstream)
(upstream-source-version r2)) (string=? (upstream-source-version upstream) version))
r1 r2)) (coalesce-sources candidates))
first ;; Select the most recent release and return it.
(coalesce-sources candidates)))))) (reduce (lambda (r1 r2)
(if (version>? (upstream-source-version r1)
(upstream-source-version r2))
r1 r2))
first
(coalesce-sources candidates)))))))
;;; ;;;
@ -592,9 +612,9 @@ are unavailable."
(call-with-gzip-input-port port (call-with-gzip-input-port port
(compose string->lines get-string-all)))))) (compose string->lines get-string-all))))))
(define (latest-gnu-release package) (define* (import-gnu-release package #:key (version #f))
"Return the latest release of PACKAGE, a GNU package available via "Return the latest release of PACKAGE, a GNU package available via
ftp.gnu.org. ftp.gnu.org. Optionally include a VERSION string to fetch a specific version.
This method does not rely on FTP access at all; instead, it browses the file 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)." list available from %GNU-FILE-LIST-URI over HTTP(S)."
@ -604,42 +624,50 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)."
(define (better-tarball? tarball1 tarball2) (define (better-tarball? tarball1 tarball2)
(string=? (file-extension tarball1) archive-type)) (string=? (file-extension tarball1) archive-type))
(define (find-latest-tarball-version tarballs)
(fold (lambda (file1 file2)
(if (and file2
(version>? (tarball-sans-extension (basename file2))
(tarball-sans-extension (basename file1))))
file2
file1))
#f
tarballs))
(let-values (((server directory) (let-values (((server directory)
(ftp-server/directory package)) (ftp-server/directory package))
((name) ((name)
(package-upstream-name package))) (package-upstream-name package)))
(let* ((files (ftp.gnu.org-files)) (let* ((files (ftp.gnu.org-files))
;; select tarballs for this package
(relevant (filter (lambda (file) (relevant (filter (lambda (file)
(and (string-prefix? "/gnu" file) (and (string-prefix? "/gnu" file)
(string-contains file directory) (string-contains file directory)
(release-file? name (basename file)))) (release-file? name (basename file))))
files))) files))
(match (sort relevant (lambda (file1 file2) ;; find latest version
(version>? (tarball-sans-extension (version (or version
(basename file1)) (and (not (null? relevant))
(tarball-sans-extension (tarball->version
(basename file2))))) (find-latest-tarball-version relevant)))))
((and tarballs (reference _ ...)) ;; find tarballs matching this version
(let* ((version (tarball->version reference)) (tarballs (filter (lambda (file)
(tarballs (filter (lambda (file) (string=? version (tarball->version file)))
(string=? (tarball-sans-extension relevant)))
(basename file)) (match tarballs
(tarball-sans-extension (() #f)
(basename reference)))) (_
tarballs))) (upstream-source
(upstream-source (package name)
(package name) (version version)
(version version) (urls (map (lambda (file)
(urls (map (lambda (file) (string-append "mirror://gnu/"
(string-append "mirror://gnu/" (string-drop file
(string-drop file (string-length "/gnu/"))))
(string-length "/gnu/"))))
;; Sort so that the tarball with the same compression ;; Sort so that the tarball with the same compression
;; format as currently used in PACKAGE comes first. ;; format as currently used in PACKAGE comes first.
(sort tarballs better-tarball?))) (sort tarballs better-tarball?)))
(signature-urls (map (cut string-append <> ".sig") urls))))) (signature-urls (map (cut string-append <> ".sig") urls))))))))
(()
#f)))))
(define %package-name-rx (define %package-name-rx
;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
@ -693,8 +721,9 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
;; HTML (unlike <https://download.savannah.nongnu.org/releases>.) ;; HTML (unlike <https://download.savannah.nongnu.org/releases>.)
"https://de.freedif.org/savannah/") "https://de.freedif.org/savannah/")
(define (latest-savannah-release package) (define* (import-savannah-release package #:key (version #f))
"Return the latest release of PACKAGE." "Return the latest release of PACKAGE. Optionally include a VERSION string
to fetch a specific version."
(let* ((uri (string->uri (let* ((uri (string->uri
(match (origin-uri (package-source package)) (match (origin-uri (package-source package))
((? string? uri) uri) ((? string? uri) uri)
@ -703,12 +732,14 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
(directory (dirname (uri-path uri)))) (directory (dirname (uri-path uri))))
;; Note: We use the default 'file->signature', which adds ".sig", ".asc", ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
;; or whichever detached signature naming scheme PACKAGE uses. ;; or whichever detached signature naming scheme PACKAGE uses.
(latest-html-release package (import-html-release package
#:version version
#:base-url %savannah-base #:base-url %savannah-base
#:directory directory))) #:directory directory)))
(define* (latest-sourceforge-release package #:key (version #f)) (define* (latest-sourceforge-release package #:key (version #f))
"Return the latest release of PACKAGE." "Return the latest release of PACKAGE. Optionally include a VERSION string
to fetch a specific version."
(define (uri-append uri extension) (define (uri-append uri extension)
;; Return URI with EXTENSION appended. ;; Return URI with EXTENSION appended.
(build-uri (uri-scheme uri) (build-uri (uri-scheme uri)
@ -766,21 +797,24 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
(when port (when port
(close-port port)))))) (close-port port))))))
(define (latest-xorg-release package) (define* (import-xorg-release package #:key (version #f))
"Return the latest release of PACKAGE." "Return the latest release of PACKAGE. Optionally include a VERSION string
to fetch a specific version."
(let ((uri (string->uri (origin-uri (package-source package))))) (let ((uri (string->uri (origin-uri (package-source package)))))
(false-if-ftp-error (false-if-ftp-error
(latest-ftp-release (import-ftp-release
(package-name package) (package-name package)
#:version version
#:server "ftp.freedesktop.org" #:server "ftp.freedesktop.org"
#:directory #:directory
(string-append "/pub/xorg/" (dirname (uri-path uri))))))) (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
(define (latest-kernel.org-release package) (define* (import-kernel.org-release package #:key (version #f))
"Return the latest release of PACKAGE, the name of a kernel.org package." "Return the latest release of PACKAGE, the name of a kernel.org package.
Optionally include a VERSION string to fetch a specific version."
(define %kernel.org-base (define %kernel.org-base
;; This URL and sub-directories thereof are nginx-generated directory ;; This URL and sub-directories thereof are nginx-generated directory
;; listings suitable for 'latest-html-release'. ;; listings suitable for 'import-html-release'.
"https://mirrors.edge.kernel.org/pub") "https://mirrors.edge.kernel.org/pub")
(define (file->signature file) (define (file->signature file)
@ -792,7 +826,8 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
((uri mirrors ...) uri)))) ((uri mirrors ...) uri))))
(package (package-upstream-name package)) (package (package-upstream-name package))
(directory (dirname (uri-path uri)))) (directory (dirname (uri-path uri))))
(latest-html-release package (import-html-release package
#:version version
#:base-url %kernel.org-base #:base-url %kernel.org-base
#:directory directory #:directory directory
#:file->signature file->signature))) #:file->signature file->signature)))
@ -819,9 +854,10 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
(or (assoc-ref (package-properties package) 'release-monitoring-url) (or (assoc-ref (package-properties package) 'release-monitoring-url)
(http-url? package))))) (http-url? package)))))
(define (latest-html-updatable-release package) (define* (import-html-updatable-release package #:key (version #f))
"Return the latest release of PACKAGE. Do that by crawling the HTML page of "Return the latest release of PACKAGE. Do that by crawling the HTML page of
the directory containing its source tarball." the directory containing its source tarball. Optionally include a VERSION
string to fetch a specific version."
(let* ((uri (string->uri (let* ((uri (string->uri
(match (origin-uri (package-source package)) (match (origin-uri (package-source package))
((? string? url) url) ((? string? url) url)
@ -838,7 +874,8 @@ the directory containing its source tarball."
(catch #t (catch #t
(lambda () (lambda ()
(guard (c ((http-get-error? c) #f)) (guard (c ((http-get-error? c) #f))
(latest-html-release package (import-html-release package
#:version version
#:base-url base #:base-url base
#:directory directory))) #:directory directory)))
(lambda (key . args) (lambda (key . args)
@ -856,7 +893,7 @@ the directory containing its source tarball."
(name 'gnu) (name 'gnu)
(description "Updater for GNU packages") (description "Updater for GNU packages")
(pred gnu-hosted?) (pred gnu-hosted?)
(import latest-gnu-release))) (import import-gnu-release)))
(define %gnu-ftp-updater (define %gnu-ftp-updater
;; This is for GNU packages taken from alternate locations, such as ;; This is for GNU packages taken from alternate locations, such as
@ -867,14 +904,14 @@ the directory containing its source tarball."
(pred (lambda (package) (pred (lambda (package)
(and (not (gnu-hosted? package)) (and (not (gnu-hosted? package))
(pure-gnu-package? package)))) (pure-gnu-package? package))))
(import latest-release*))) (import import-release*)))
(define %savannah-updater (define %savannah-updater
(upstream-updater (upstream-updater
(name 'savannah) (name 'savannah)
(description "Updater for packages hosted on savannah.gnu.org") (description "Updater for packages hosted on savannah.gnu.org")
(pred (url-prefix-predicate "mirror://savannah/")) (pred (url-prefix-predicate "mirror://savannah/"))
(import latest-savannah-release))) (import import-savannah-release)))
(define %sourceforge-updater (define %sourceforge-updater
(upstream-updater (upstream-updater
@ -888,20 +925,20 @@ the directory containing its source tarball."
(name 'xorg) (name 'xorg)
(description "Updater for X.org packages") (description "Updater for X.org packages")
(pred (url-prefix-predicate "mirror://xorg/")) (pred (url-prefix-predicate "mirror://xorg/"))
(import latest-xorg-release))) (import import-xorg-release)))
(define %kernel.org-updater (define %kernel.org-updater
(upstream-updater (upstream-updater
(name 'kernel.org) (name 'kernel.org)
(description "Updater for packages hosted on kernel.org") (description "Updater for packages hosted on kernel.org")
(pred (url-prefix-predicate "mirror://kernel.org/")) (pred (url-prefix-predicate "mirror://kernel.org/"))
(import latest-kernel.org-release))) (import import-kernel.org-release)))
(define %generic-html-updater (define %generic-html-updater
(upstream-updater (upstream-updater
(name 'generic-html) (name 'generic-html)
(description "Updater that crawls HTML pages.") (description "Updater that crawls HTML pages.")
(pred html-updatable-package?) (pred html-updatable-package?)
(import latest-html-updatable-release))) (import import-html-updatable-release)))
;;; gnu-maintenance.scm ends here ;;; gnu-maintenance.scm ends here

2
guix/import/gnu.scm
View file

@ -117,7 +117,7 @@ details.)"
(unless package (unless package
(raise (formatted-message (G_ "no GNU package found for ~a") name))) (raise (formatted-message (G_ "no GNU package found for ~a") name)))
(match (latest-release name) (match (import-release name)
((? upstream-source? release) ((? upstream-source? release)
(let ((version (upstream-source-version release))) (let ((version (upstream-source-version release)))
(gnu-package->sexp package release #:key-download key-download))) (gnu-package->sexp package release #:key-download key-download)))