;;; 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, 2021 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.
;;;
#:use-module (guix utils)
#:use-module (guix discovery)
#:use-module ((guix download)
- #:select (download-to-store))
+ #:select (download-to-store url-fetch))
#:use-module (guix gnupg)
#:use-module (guix packages)
+ #:use-module (guix diagnostics)
#: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 derivations) #:select (built-derivations derivation->output-path))
+ #:autoload (gcrypt hash) (port-sha256)
#: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-urls
upstream-source-signature-urls
upstream-source-archive-types
+ upstream-source-input-changes
+ url-predicate
url-prefix-predicate
coalesce-sources
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
(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)))
-(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)))
+;; 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-predicate matching-url?)
+ "Return a predicate that returns true when passed a package whose source is
+an <origin> with the URL-FETCH method, and one of its URLs passes
+MATCHING-URL?."
+ (lambda (package)
(match (package-source package)
((? origin? origin)
- (match (origin-uri origin)
- ((? matching-uri?) #t)
- (_ #f)))
+ (and (eq? (origin-method origin) url-fetch)
+ (match (origin-uri origin)
+ ((? string? url)
+ (matching-url? url))
+ (((? string? urls) ...)
+ (any matching-url? urls))
+ (_
+ #f))))
(_ #f))))
+(define (url-prefix-predicate prefix)
+ "Return a predicate that returns true when passed a package where one of its
+source URLs starts with PREFIX."
+ (url-predicate (cut string-prefix? prefix <>)))
+
(define (upstream-source-archive-types release)
"Return the available types of archives for RELEASE---a list of strings such
as \"gz\" or \"xz\"."
'()
(importer-modules))))
-(define (lookup-updater package updaters)
+;; Tests need to mock this variable so mark it as "non-declarative".
+(set! %updaters %updaters)
+
+(define* (lookup-updater package
+ #:optional (updaters (force %updaters)))
"Return an updater among UPDATERS that matches PACKAGE, or #f if none of
them matches."
- (any (match-lambda
- (($ <upstream-updater> name description pred latest)
- (and (pred package) latest)))
- updaters))
+ (find (match-lambda
+ (($ <upstream-updater> name description pred latest)
+ (pred package)))
+ updaters))
-(define (package-latest-release package updaters)
+(define* (package-latest-release package
+ #:optional
+ (updaters (force %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)
- (latest-release package))
+ ((? upstream-updater? updater)
+ ((upstream-updater-latest updater) package))
(_ #f)))
-(define (package-latest-release* package updaters)
+(define* (package-latest-release* package
+ #:optional
+ (updaters (force %updaters)))
"Like 'package-latest-release', but ensure that the return source is newer
than that of PACKAGE."
(match (package-latest-release package updaters)
(basename url) tarball)))
(mbegin %store-monad
(built-derivations (list drv))
- (return (derivation->output-path drv)))))))
+ (return (derivation->output-path drv))))))))
+ (let-values (((status data)
+ (if sig
+ (gnupg-verify* sig data
+ #:key-download key-download)
+ (values 'missing-signature data))))
+ (match status
+ ('valid-signature
+ tarball)
+ ('missing-signature
+ (warning (G_ "failed to download detached signature from ~a~%")
+ signature-url)
+ #f)
+ ('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)))))))
- (ret (gnupg-verify* sig data #:key-download key-download)))
- (if ret
- tarball
- (begin
- (warning (G_ "signature verification failed for `~a'~%")
- url)
- (warning (G_ "(could be because the public key is not in your keyring)~%"))
- #f))))))
+(define-gexp-compiler (upstream-source-compiler (source <upstream-source>)
+ system target)
+ "Download SOURCE from its first URL and lower it as a fixed-output
+derivation that would fetch it."
+ (mlet* %store-monad ((url -> (first (upstream-source-urls source)))
+ (signature
+ -> (and=> (upstream-source-signature-urls source)
+ first))
+ (tarball ((store-lift download-tarball) url signature)))
+ (unless tarball
+ (raise (formatted-message (G_ "failed to fetch source from '~a'")
+ url)))
+
+ ;; Instead of returning TARBALL, return a fixed-output derivation that
+ ;; would be able to re-download it. In practice, since TARBALL is already
+ ;; in the store, no extra download will happen, but having the derivation
+ ;; in store improves provenance tracking.
+ (let ((hash (call-with-input-file tarball port-sha256)))
+ (url-fetch url 'sha256 hash (store-path-package-name tarball)
+ #:system system))))
(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-latest-release* 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)
- (let ((type (file-extension (basename uri))))
+ (let ((type (or (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.
(_
"gz")))
((url signature-url)
+ ;; Try to find a URL that matches ARCHIVE-TYPE.
(find2 (lambda (url sig-url)
;; Some URIs lack a file extension, like
;; 'https://crates.io/???/0.1/download'. In that
(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
+ #:optional (updaters (force %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 (make-compound-condition
+ (formatted-message (G_ "cannot download for \
+this method: ~s")
+ method)
+ (condition
+ (&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 (update-expression expr old-version version old-hash hash)
- ;; Update package expression EXPR, replacing occurrences OLD-VERSION by
- ;; VERSION and occurrences of OLD-HASH by HASH (base32 representation
- ;; thereof).
- (let ((old-hash (bytevector->nix-base32-string old-hash))
- (hash (bytevector->nix-base32-string hash)))
- (string-replace-substring
- (string-replace-substring expr old-hash hash)
- old-version version)))
+ (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 (origin-sha256 (package-source 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
- (and (edit-expression
- ;; Be sure to use absolute filename.
- (assq-set! (location->source-properties loc)
- 'filename file)
- (cut update-expression <>
- old-version version old-hash hash))
- version)
+ ;; 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 (G_ "~a: could not locate source file")
(location-file loc))
#f)))
- (begin
- (format (current-error-port)
- (G_ "~a: ~a: no `version' field in source; skipping~%")
- (location->string (package-location package))
- name)))))
+ (warning (package-location package)
+ (G_ "~a: no `version' field in source; skipping~%")
+ name))))
;;; upstream.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff