You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

492 lines
20 KiB

;;; GNU Guix --- Functional package management for GNU
;;; 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.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix upstream)
#:use-module (guix records)
#:use-module (guix utils)
#:use-module (guix discovery)
#:use-module ((guix download)
#: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 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?
upstream-source-package
upstream-source-version
upstream-source-urls
upstream-source-signature-urls
upstream-source-archive-types
upstream-source-input-changes
url-predicate
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-latest-release
package-latest-release*
package-update
update-package-source))
;;; Commentary:
;;;
;;; This module provides tools to represent and manipulate a upstream source
;;; code, and to auto-update package recipes.
;;;
;;; Code:
;; Representation of upstream's source. There can be several URLs--e.g.,
;; tar.gz, tar.gz, etc. There can be correspond signature URLs, one per
;; source URL.
(define-record-type* <upstream-source>
upstream-source make-upstream-source
upstream-source?
(package upstream-source-package) ;string
(version upstream-source-version) ;string
(urls upstream-source-urls) ;list of strings
(signature-urls upstream-source-signature-urls ;#f | list of strings
(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-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)
(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\"."
(map file-extension (upstream-source-urls release)))
(define (coalesce-sources sources)
"Coalesce the elements of SOURCES, a list of <upstream-source>, that
correspond to the same version."
(define (same-version? r1 r2)
(string=? (upstream-source-version r1) (upstream-source-version r2)))
(define (release>? r1 r2)
(version>? (upstream-source-version r1) (upstream-source-version r2)))
(fold (lambda (release result)
(match result
((head . tail)
(if (same-version? release head)
(cons (upstream-source
(inherit release)
(urls (append (upstream-source-urls release)
(upstream-source-urls head)))
(signature-urls
(let ((one (upstream-source-signature-urls release))
(two (upstream-source-signature-urls head)))
(and one two (append one two)))))
tail)
(cons release result)))
(()
(list release))))
'()
(sort sources release>?)))
;;;
;;; Auto-update.
;;;
(define-record-type* <upstream-updater>
upstream-updater make-upstream-updater
upstream-updater?
(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."
(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)
((? 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; 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))
;; 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)
(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)))))))
(define (find2 pred lst1 lst2)
"Like 'find', but operate on items from both LST1 and LST2. Return two
values: the item from LST1 and the item from LST2 that match PRED."
(let loop ((lst1 lst1) (lst2 lst2))
(match lst1
((head1 . tail1)
(match lst2
((head2 . tail2)
(if (pred head1 head2)
(values head1 head2)
(loop tail1 tail2)))))
(()
(values #f #f)))))
(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 (((archive-type)
(match (and=> (package-source package) origin-uri)
((? string? 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
;; case, pick the first URL.
(or (not archive-type)
(string-suffix? archive-type url)))
urls
(or signature-urls (circular-list #f)))))
;; 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 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 #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
;; 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)))
(warning (package-location package)
(G_ "~a: no `version' field in source; skipping~%")
name))))
;;; upstream.scm ends here