mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-15 19:35:25 -05:00
a1679b74c9
This reverts commits f63c79bf76
..f86f7e24b39928247729020df0134e2e1c4cde62 for more chillax reviewing.
See <https://issues.guix.gnu.org/51061#32>.
526 lines
22 KiB
Scheme
526 lines
22 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; 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.
|
||
;;;
|
||
;;; 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))
|
||
#: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?
|
||
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))))
|
||
|
||
;; 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."
|
||
(find (match-lambda
|
||
(($ <upstream-updater> name description pred latest)
|
||
(pred 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. When several updaters match PACKAGE, try
|
||
them until one of them returns an upstream source. It is the caller's
|
||
responsibility to ensure that the returned source is newer than the current
|
||
one."
|
||
(any (match-lambda
|
||
(($ <upstream-updater> name description pred latest)
|
||
(and (pred package)
|
||
(latest 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)
|
||
((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-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: 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 (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.
|
||
(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
|
||
#: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 #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
|