;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 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))
+ #:select (download-to-store url-fetch))
#:use-module (guix gnupg)
#:use-module (guix packages)
#:use-module (guix ui)
#: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-prefix-predicate
coalesce-sources
upstream-updater
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
(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
(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))
+ (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)
- (latest-release package))
+ ((? upstream-updater? updater)
+ ((upstream-updater-latest updater) package))
(_ #f)))
(define (package-latest-release* package updaters)
(if ret
tarball
(begin
- (warning (_ "signature verification failed for `~a'~%")
+ (warning (G_ "signature verification failed for `~a'~%")
url)
- (warning (_ "(could be because the public key is not in your keyring)~%"))
+ (warning (G_ "(could be because the public key is not in your keyring)~%"))
#f))))))
(define (find2 pred lst1 lst2)
(()
(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)
- (file-extension (basename uri)))
+ (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)
;; 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 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 (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-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 (_ "~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