;;; 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, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix upstream)
#:use-module (guix records)
#:use-module (guix utils)
+ #:use-module (guix discovery)
#:use-module ((guix download)
- #:select (download-to-store))
- #:use-module ((guix build utils)
- #:select (substitute))
+ #:select (download-to-store url-fetch))
#:use-module (guix gnupg)
#:use-module (guix packages)
#:use-module (guix ui)
#:use-module (guix base32)
+ #:use-module (guix gexp)
+ #:use-module (guix store)
+ #:use-module ((guix derivations)
+ #:select (built-derivations derivation->output-path))
+ #:use-module (guix monads)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:export (upstream-source
upstream-source-version
upstream-source-urls
upstream-source-signature-urls
+ upstream-source-archive-types
+ upstream-source-input-changes
+ url-prefix-predicate
coalesce-sources
upstream-updater
upstream-updater?
upstream-updater-name
+ upstream-updater-description
upstream-updater-predicate
upstream-updater-latest
+ upstream-input-change?
+ upstream-input-change-name
+ upstream-input-change-type
+ upstream-input-change-action
+ changed-inputs
+
+ %updaters
+ lookup-updater
+
download-tarball
- package-update-path
+ package-latest-release
+ package-latest-release*
package-update
update-package-source))
(version upstream-source-version) ;string
(urls upstream-source-urls) ;list of strings
(signature-urls upstream-source-signature-urls ;#f | list of strings
- (default #f)))
+ (default #f))
+ (input-changes upstream-source-input-changes
+ (default '()) (thunked)))
+
+;; Representation of an upstream input change.
+(define-record-type* <upstream-input-change>
+ upstream-input-change make-upstream-input-change
+ upstream-input-change?
+ (name upstream-input-change-name) ;string
+ (type upstream-input-change-type) ;symbol: regular | native | propagated
+ (action upstream-input-change-action)) ;symbol: add | remove
+
+(define (changed-inputs package package-sexp)
+ "Return a list of input changes for PACKAGE based on the newly imported
+S-expression PACKAGE-SEXP."
+ (match package-sexp
+ ((and expr ('package fields ...))
+ (let* ((input->name (match-lambda ((name pkg . out) name)))
+ (new-regular
+ (match expr
+ ((path *** ('inputs
+ ('quasiquote ((label ('unquote sym)) ...)))) label)
+ (_ '())))
+ (new-native
+ (match expr
+ ((path *** ('native-inputs
+ ('quasiquote ((label ('unquote sym)) ...)))) label)
+ (_ '())))
+ (new-propagated
+ (match expr
+ ((path *** ('propagated-inputs
+ ('quasiquote ((label ('unquote sym)) ...)))) label)
+ (_ '())))
+ (current-regular
+ (map input->name (package-inputs package)))
+ (current-native
+ (map input->name (package-native-inputs package)))
+ (current-propagated
+ (map input->name (package-propagated-inputs package))))
+ (append-map
+ (match-lambda
+ ((action type names)
+ (map (lambda (name)
+ (upstream-input-change
+ (name name)
+ (type type)
+ (action action)))
+ names)))
+ `((add regular
+ ,(lset-difference equal?
+ new-regular current-regular))
+ (remove regular
+ ,(lset-difference equal?
+ current-regular new-regular))
+ (add native
+ ,(lset-difference equal?
+ new-native current-native))
+ (remove native
+ ,(lset-difference equal?
+ current-native new-native))
+ (add propagated
+ ,(lset-difference equal?
+ new-propagated current-propagated))
+ (remove propagated
+ ,(lset-difference equal?
+ current-propagated new-propagated))))))
+ (_ '())))
+
+(define (url-prefix-predicate prefix)
+ "Return a predicate that returns true when passed a package where one of its
+source URLs starts with PREFIX."
+ (lambda (package)
+ (define matching-uri?
+ (match-lambda
+ ((? string? uri)
+ (string-prefix? prefix uri))
+ (_
+ #f)))
+
+ (match (package-source package)
+ ((? origin? origin)
+ (match (origin-uri origin)
+ ((? matching-uri?) #t)
+ (_ #f)))
+ (_ #f))))
(define (upstream-source-archive-types release)
"Return the available types of archives for RELEASE---a list of strings such
(urls (append (upstream-source-urls release)
(upstream-source-urls head)))
(signature-urls
- (append (upstream-source-signature-urls release)
- (upstream-source-signature-urls head))))
+ (let ((one (upstream-source-signature-urls release))
+ (two (upstream-source-signature-urls head)))
+ (and one two (append one two)))))
tail)
(cons release result)))
(()
;;; Auto-update.
;;;
-(define-record-type <upstream-updater>
- (upstream-updater name pred latest)
+(define-record-type* <upstream-updater>
+ upstream-updater make-upstream-updater
upstream-updater?
- (name upstream-updater-name)
- (pred upstream-updater-predicate)
- (latest upstream-updater-latest))
+ (name upstream-updater-name)
+ (description upstream-updater-description)
+ (pred upstream-updater-predicate)
+ (latest upstream-updater-latest))
+
+(define (importer-modules)
+ "Return the list of importer modules."
+ (cons (resolve-interface '(guix gnu-maintenance))
+ (all-modules (map (lambda (entry)
+ `(,entry . "guix/import"))
+ %load-path)
+ #:warn warn-about-load-error)))
+
+(define %updaters
+ ;; The list of publically-known updaters.
+ (delay (fold-module-public-variables (lambda (obj result)
+ (if (upstream-updater? obj)
+ (cons obj result)
+ result))
+ '()
+ (importer-modules))))
(define (lookup-updater package updaters)
"Return an updater among UPDATERS that matches PACKAGE, or #f if none of
them matches."
- (any (match-lambda
- (($ <upstream-updater> _ pred latest)
- (and (pred package) latest)))
- updaters))
-
-(define (package-update-path package updaters)
- "Return an upstream source to update PACKAGE to, or #f if no update is
-needed or known."
+ (find (match-lambda
+ (($ <upstream-updater> name description pred latest)
+ (pred package)))
+ updaters))
+
+(define (package-latest-release package updaters)
+ "Return an upstream source to update PACKAGE, a <package> object, or #f if
+none of UPDATERS matches PACKAGE. It is the caller's responsibility to ensure
+that the returned source is newer than the current one."
(match (lookup-updater package updaters)
- ((? procedure? latest-release)
- (match (latest-release (package-name package))
- ((and source ($ <upstream-source> name version))
- (and (version>? version (package-version package))
- source))
- (_ #f)))
- (#f #f)))
+ ((? upstream-updater? updater)
+ ((upstream-updater-latest updater) package))
+ (_ #f)))
+
+(define (package-latest-release* package updaters)
+ "Like 'package-latest-release', but ensure that the return source is newer
+than that of PACKAGE."
+ (match (package-latest-release package updaters)
+ ((and source ($ <upstream-source> name version))
+ (and (version>? version (package-version package))
+ source))
+ (_
+ #f)))
+
+(define (uncompressed-tarball name tarball)
+ "Return a derivation that decompresses TARBALL."
+ (define (ref package)
+ (module-ref (resolve-interface '(gnu packages compression))
+ package))
+
+ (define compressor
+ (cond ((or (string-suffix? ".gz" tarball)
+ (string-suffix? ".tgz" tarball))
+ (file-append (ref 'gzip) "/bin/gzip"))
+ ((string-suffix? ".bz2" tarball)
+ (file-append (ref 'bzip2) "/bin/bzip2"))
+ ((string-suffix? ".xz" tarball)
+ (file-append (ref 'xz) "/bin/xz"))
+ ((string-suffix? ".lz" tarball)
+ (file-append (ref 'lzip) "/bin/lzip"))
+ (else
+ (error "unknown archive type" tarball))))
+
+ (gexp->derivation (file-sans-extension name)
+ #~(begin
+ (copy-file #+tarball #+name)
+ (and (zero? (system* #+compressor "-d" #+name))
+ (copy-file #+(file-sans-extension name)
+ #$output)))))
(define* (download-tarball store url signature-url
#:key (key-download 'interactive))
"Download the tarball at URL to the store; check its OpenPGP signature at
SIGNATURE-URL, unless SIGNATURE-URL is false. On success, return the tarball
-file name. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys;
-allowed values: 'interactive' (default), 'always', and 'never'."
+file name; return #f on failure (network failure or authentication failure).
+KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
+values: 'interactive' (default), 'always', and 'never'."
(let ((tarball (download-to-store store url)))
(if (not signature-url)
tarball
- (let* ((sig (download-to-store store signature-url))
- (ret (gnupg-verify* sig tarball #:key-download key-download)))
- (if ret
- tarball
- (begin
- (warning (_ "signature verification failed for `~a'~%")
- url)
- (warning (_ "(could be because the public key is not in your keyring)~%"))
- #f))))))
+ (let* ((sig (download-to-store store signature-url))
+
+ ;; Sometimes we get a signature over the uncompressed tarball.
+ ;; In that case, decompress the tarball in the store so that we
+ ;; can check the signature.
+ (data (if (string-prefix? (basename url)
+ (basename signature-url))
+ tarball
+ (run-with-store store
+ (mlet %store-monad ((drv (uncompressed-tarball
+ (basename url) tarball)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (return (derivation->output-path drv))))))))
+ (let-values (((status data)
+ (gnupg-verify* sig data #:key-download key-download)))
+ (match status
+ ('valid-signature
+ tarball)
+ ('invalid-signature
+ (warning (G_ "signature verification failed for '~a' (key: ~a)~%")
+ url data)
+ #f)
+ ('missing-key
+ (warning (G_ "missing public key ~a for '~a'~%")
+ data url)
+ #f)))))))
(define (find2 pred lst1 lst2)
"Like 'find', but operate on items from both LST1 and LST2. Return two
(()
(values #f #f)))))
-(define* (package-update store package updaters
- #:key (key-download 'interactive))
- "Return the new version and the file name of the new version tarball for
-PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a
-download policy for missing OpenPGP keys; allowed values: 'always', 'never',
-and 'interactive' (default)."
- (match (package-update-path package updaters)
+(define* (package-update/url-fetch store package source
+ #:key key-download)
+ "Return the version, tarball, and SOURCE, to update PACKAGE to
+SOURCE, an <upstream-source>."
+ (match source
(($ <upstream-source> _ version urls signature-urls)
- (let*-values (((name)
- (package-name package))
- ((archive-type)
+ (let*-values (((archive-type)
(match (and=> (package-source package) origin-uri)
((? string? uri)
- (or (file-extension uri) "gz"))
+ (let ((type (file-extension (basename uri))))
+ ;; Sometimes we have URLs such as
+ ;; "https://github.com/…/tarball/v0.1", in which case
+ ;; we must not consider "1" as the extension.
+ (and (or (string-contains type "z")
+ (string=? type "tar"))
+ type)))
(_
"gz")))
((url signature-url)
+ ;; Try to find a URL that matches ARCHIVE-TYPE.
(find2 (lambda (url sig-url)
- (string-suffix? archive-type url))
+ ;; Some URIs lack a file extension, like
+ ;; 'https://crates.io/???/0.1/download'. In that
+ ;; case, pick the first URL.
+ (or (not archive-type)
+ (string-suffix? archive-type url)))
urls
(or signature-urls (circular-list #f)))))
- (let ((tarball (download-tarball store url signature-url
+ ;; If none of URLS matches ARCHIVE-TYPE, then URL is #f; in that case,
+ ;; pick up the first element of URLS.
+ (let ((tarball (download-tarball store
+ (or url (first urls))
+ (and (pair? signature-urls)
+ (or signature-url
+ (first signature-urls)))
#:key-download key-download)))
- (values version tarball))))
+ (values version tarball source))))))
+
+(define %method-updates
+ ;; Mapping of origin methods to source update procedures.
+ `((,url-fetch . ,package-update/url-fetch)))
+
+(define* (package-update store package updaters
+ #:key (key-download 'interactive))
+ "Return the new version, the file name of the new version tarball, and input
+changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date.
+KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
+values: 'always', 'never', and 'interactive' (default)."
+ (match (package-latest-release* package updaters)
+ ((? upstream-source? source)
+ (let ((method (match (package-source package)
+ ((? origin? origin)
+ (origin-method origin))
+ (_
+ #f))))
+ (match (assq method %method-updates)
+ (#f
+ (raise (condition (&message
+ (message (format #f (G_ "cannot download for \
+this method: ~s")
+ method)))
+ (&error-location
+ (location (package-location package))))))
+ ((_ . update)
+ (update store package source
+ #:key-download key-download)))))
(#f
- (values #f #f))))
-
-(define (update-package-source package version hash)
- "Modify the source file that defines PACKAGE to refer to VERSION,
-whose tarball has SHA256 HASH (a bytevector). Return the new version string
-if an update was made, and #f otherwise."
- (define (new-line line matches replacement)
- ;; Iterate over MATCHES and return the modified line based on LINE.
- ;; Replace each match with REPLACEMENT.
- (let loop ((m* matches) ; matches
- (o 0) ; offset in L
- (r '())) ; result
- (match m*
- (()
- (let ((r (cons (substring line o) r)))
- (string-concatenate-reverse r)))
- ((m . rest)
- (loop rest
- (match:end m)
- (cons* replacement
- (substring line o (match:start m))
- r))))))
-
- (define (update-source file old-version version
- old-hash hash)
- ;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION
- ;; and occurrences of OLD-HASH by HASH (base32 representation thereof).
-
- ;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in
- ;; different unrelated places, we may modify it more than needed, for
- ;; instance. We should try to make changes only within the sexp that
- ;; corresponds to the definition of PACKAGE.
- (let ((old-hash (bytevector->nix-base32-string old-hash))
- (hash (bytevector->nix-base32-string hash)))
- (substitute file
- `((,(regexp-quote old-version)
- . ,(cut new-line <> <> version))
- (,(regexp-quote old-hash)
- . ,(cut new-line <> <> hash))))
- version))
-
- (let ((name (package-name package))
- (loc (package-field-location package 'version)))
- (if loc
- (let ((old-version (package-version package))
- (old-hash (origin-sha256 (package-source package)))
- (file (and=> (location-file loc)
- (cut search-path %load-path <>))))
+ (values #f #f #f))))
+
+(define* (update-package-source package source hash)
+ "Modify the source file that defines PACKAGE to refer to SOURCE, an
+<upstream-source> whose tarball has SHA256 HASH (a bytevector). Return the
+new version string if an update was made, and #f otherwise."
+ (define (update-expression expr replacements)
+ ;; Apply REPLACEMENTS to package expression EXPR, a string. REPLACEMENTS
+ ;; must be a list of replacement pairs, either bytevectors or strings.
+ (fold (lambda (replacement str)
+ (match replacement
+ (((? bytevector? old-bv) . (? bytevector? new-bv))
+ (string-replace-substring
+ str
+ (bytevector->nix-base32-string old-bv)
+ (bytevector->nix-base32-string new-bv)))
+ ((old . new)
+ (string-replace-substring str old new))))
+ expr
+ replacements))
+
+ (let ((name (package-name package))
+ (version (upstream-source-version source))
+ (version-loc (package-field-location package 'version)))
+ (if version-loc
+ (let* ((loc (package-location package))
+ (old-version (package-version package))
+ (old-hash (content-hash-value
+ (origin-hash (package-source package))))
+ (old-url (match (origin-uri (package-source package))
+ ((? string? url) url)
+ (_ #f)))
+ (new-url (match (upstream-source-urls source)
+ ((first _ ...) first)))
+ (file (and=> (location-file loc)
+ (cut search-path %load-path <>))))
(if file
- (update-source file
- old-version version
- old-hash hash)
+ ;; Be sure to use absolute filename. Replace the URL directory
+ ;; when OLD-URL is available; this is useful notably for
+ ;; mirror://cpan/ URLs where the directory may change as a
+ ;; function of the person who uploads the package. Note that
+ ;; package definitions usually concatenate fragments of the URL,
+ ;; which is why we only attempt to replace a subset of the URL.
+ (let ((properties (assq-set! (location->source-properties loc)
+ 'filename file))
+ (replacements `((,old-version . ,version)
+ (,old-hash . ,hash)
+ ,@(if (and old-url new-url)
+ `((,(dirname old-url) .
+ ,(dirname new-url)))
+ '()))))
+ (and (edit-expression properties
+ (cut update-expression <> replacements))
+ version))
(begin
- (warning (_ "~a: could not locate source file")
+ (warning (G_ "~a: could not locate source file")
(location-file loc))
#f)))
(begin
(format (current-error-port)
- (_ "~a: ~a: no `version' field in source; skipping~%")
+ (G_ "~a: ~a: no `version' field in source; skipping~%")
(location->string (package-location package))
name)))))
HCoop / jackhill / guix / guix.git / blobdiff