1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
4 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
6 ;;; This file is part of GNU Guix.
8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
13 ;;; GNU Guix is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;;; GNU General Public License for more details.
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
21 (define-module (guix upstream)
22 #:use-module (guix records)
23 #:use-module (guix utils)
24 #:use-module (guix discovery)
25 #:use-module ((guix download)
26 #:select (download-to-store url-fetch))
27 #:use-module (guix gnupg)
28 #:use-module (guix packages)
29 #:use-module (guix diagnostics)
30 #:use-module (guix ui)
31 #:use-module (guix base32)
32 #:use-module (guix gexp)
33 #:use-module (guix store)
34 #:use-module ((guix derivations) #:select (built-derivations derivation->output-path))
35 #:autoload (gcrypt hash) (port-sha256)
36 #:use-module (guix monads)
37 #:use-module (srfi srfi-1)
38 #:use-module (srfi srfi-9)
39 #:use-module (srfi srfi-11)
40 #:use-module (srfi srfi-26)
41 #:use-module (srfi srfi-34)
42 #:use-module (srfi srfi-35)
43 #:use-module (rnrs bytevectors)
44 #:use-module (ice-9 match)
45 #:use-module (ice-9 regex)
46 #:export (upstream-source
48 upstream-source-package
49 upstream-source-version
51 upstream-source-signature-urls
52 upstream-source-archive-types
53 upstream-source-input-changes
62 upstream-updater-description
63 upstream-updater-predicate
64 upstream-updater-latest
66 upstream-input-change?
67 upstream-input-change-name
68 upstream-input-change-type
69 upstream-input-change-action
76 package-latest-release
77 package-latest-release*
79 update-package-source))
83 ;;; This module provides tools to represent and manipulate a upstream source
84 ;;; code, and to auto-update package recipes.
88 ;; Representation of upstream's source. There can be several URLs--e.g.,
89 ;; tar.gz, tar.gz, etc. There can be correspond signature URLs, one per
91 (define-record-type* <upstream-source>
92 upstream-source make-upstream-source
94 (package upstream-source-package) ;string
95 (version upstream-source-version) ;string
96 (urls upstream-source-urls) ;list of strings
97 (signature-urls upstream-source-signature-urls ;#f | list of strings
99 (input-changes upstream-source-input-changes
100 (default '()) (thunked)))
102 ;; Representation of an upstream input change.
103 (define-record-type* <upstream-input-change>
104 upstream-input-change make-upstream-input-change
105 upstream-input-change?
106 (name upstream-input-change-name) ;string
107 (type upstream-input-change-type) ;symbol: regular | native | propagated
108 (action upstream-input-change-action)) ;symbol: add | remove
110 (define (changed-inputs package package-sexp)
111 "Return a list of input changes for PACKAGE based on the newly imported
112 S-expression PACKAGE-SEXP."
114 ((and expr ('package fields ...))
115 (let* ((input->name (match-lambda ((name pkg . out) name)))
119 ('quasiquote ((label ('unquote sym)) ...)))) label)
123 ((path *** ('native-inputs
124 ('quasiquote ((label ('unquote sym)) ...)))) label)
128 ((path *** ('propagated-inputs
129 ('quasiquote ((label ('unquote sym)) ...)))) label)
132 (map input->name (package-inputs package)))
134 (map input->name (package-native-inputs package)))
136 (map input->name (package-propagated-inputs package))))
141 (upstream-input-change
147 ,(lset-difference equal?
148 new-regular current-regular))
150 ,(lset-difference equal?
151 current-regular new-regular))
153 ,(lset-difference equal?
154 new-native current-native))
156 ,(lset-difference equal?
157 current-native new-native))
159 ,(lset-difference equal?
160 new-propagated current-propagated))
162 ,(lset-difference equal?
163 current-propagated new-propagated))))))
166 (define* (url-predicate matching-url?)
167 "Return a predicate that returns true when passed a package whose source is
168 an <origin> with the URL-FETCH method, and one of its URLs passes
171 (match (package-source package)
173 (and (eq? (origin-method origin) url-fetch)
174 (match (origin-uri origin)
177 (((? string? urls) ...)
178 (any matching-url? urls))
183 (define (url-prefix-predicate prefix)
184 "Return a predicate that returns true when passed a package where one of its
185 source URLs starts with PREFIX."
186 (url-predicate (cut string-prefix? prefix <>)))
188 (define (upstream-source-archive-types release)
189 "Return the available types of archives for RELEASE---a list of strings such
190 as \"gz\" or \"xz\"."
191 (map file-extension (upstream-source-urls release)))
193 (define (coalesce-sources sources)
194 "Coalesce the elements of SOURCES, a list of <upstream-source>, that
195 correspond to the same version."
196 (define (same-version? r1 r2)
197 (string=? (upstream-source-version r1) (upstream-source-version r2)))
199 (define (release>? r1 r2)
200 (version>? (upstream-source-version r1) (upstream-source-version r2)))
202 (fold (lambda (release result)
205 (if (same-version? release head)
206 (cons (upstream-source
208 (urls (append (upstream-source-urls release)
209 (upstream-source-urls head)))
211 (let ((one (upstream-source-signature-urls release))
212 (two (upstream-source-signature-urls head)))
213 (and one two (append one two)))))
215 (cons release result)))
219 (sort sources release>?)))
226 (define-record-type* <upstream-updater>
227 upstream-updater make-upstream-updater
229 (name upstream-updater-name)
230 (description upstream-updater-description)
231 (pred upstream-updater-predicate)
232 (latest upstream-updater-latest))
234 (define (importer-modules)
235 "Return the list of importer modules."
236 (cons (resolve-interface '(guix gnu-maintenance))
237 (all-modules (map (lambda (entry)
238 `(,entry . "guix/import"))
240 #:warn warn-about-load-error)))
243 ;; The list of publically-known updaters.
244 (delay (fold-module-public-variables (lambda (obj result)
245 (if (upstream-updater? obj)
249 (importer-modules))))
251 ;; Tests need to mock this variable so mark it as "non-declarative".
252 (set! %updaters %updaters)
254 (define* (lookup-updater package
255 #:optional (updaters (force %updaters)))
256 "Return an updater among UPDATERS that matches PACKAGE, or #f if none of
259 (($ <upstream-updater> name description pred latest)
263 (define* (package-latest-release package
265 (updaters (force %updaters)))
266 "Return an upstream source to update PACKAGE, a <package> object, or #f if
267 none of UPDATERS matches PACKAGE. When several updaters match PACKAGE, try
268 them until one of them returns an upstream source. It is the caller's
269 responsibility to ensure that the returned source is newer than the current
272 (($ <upstream-updater> name description pred latest)
277 (define* (package-latest-release* package
279 (updaters (force %updaters)))
280 "Like 'package-latest-release', but ensure that the return source is newer
281 than that of PACKAGE."
282 (match (package-latest-release package updaters)
283 ((and source ($ <upstream-source> name version))
284 (and (version>? version (package-version package))
289 (define (uncompressed-tarball name tarball)
290 "Return a derivation that decompresses TARBALL."
291 (define (ref package)
292 (module-ref (resolve-interface '(gnu packages compression))
296 (cond ((or (string-suffix? ".gz" tarball)
297 (string-suffix? ".tgz" tarball))
298 (file-append (ref 'gzip) "/bin/gzip"))
299 ((string-suffix? ".bz2" tarball)
300 (file-append (ref 'bzip2) "/bin/bzip2"))
301 ((string-suffix? ".xz" tarball)
302 (file-append (ref 'xz) "/bin/xz"))
303 ((string-suffix? ".lz" tarball)
304 (file-append (ref 'lzip) "/bin/lzip"))
306 (error "unknown archive type" tarball))))
308 (gexp->derivation (file-sans-extension name)
310 (copy-file #+tarball #+name)
311 (and (zero? (system* #+compressor "-d" #+name))
312 (copy-file #+(file-sans-extension name)
315 (define* (download-tarball store url signature-url
316 #:key (key-download 'interactive))
317 "Download the tarball at URL to the store; check its OpenPGP signature at
318 SIGNATURE-URL, unless SIGNATURE-URL is false. On success, return the tarball
319 file name; return #f on failure (network failure or authentication failure).
320 KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
321 values: 'interactive' (default), 'always', and 'never'."
322 (let ((tarball (download-to-store store url)))
323 (if (not signature-url)
325 (let* ((sig (download-to-store store signature-url))
327 ;; Sometimes we get a signature over the uncompressed tarball.
328 ;; In that case, decompress the tarball in the store so that we
329 ;; can check the signature.
330 (data (if (string-prefix? (basename url)
331 (basename signature-url))
333 (run-with-store store
334 (mlet %store-monad ((drv (uncompressed-tarball
335 (basename url) tarball)))
337 (built-derivations (list drv))
338 (return (derivation->output-path drv))))))))
339 (let-values (((status data)
341 (gnupg-verify* sig data
342 #:key-download key-download)
343 (values 'missing-signature data))))
348 (warning (G_ "failed to download detached signature from ~a~%")
352 (warning (G_ "signature verification failed for '~a' (key: ~a)~%")
356 (warning (G_ "missing public key ~a for '~a'~%")
360 (define-gexp-compiler (upstream-source-compiler (source <upstream-source>)
362 "Download SOURCE from its first URL and lower it as a fixed-output
363 derivation that would fetch it."
364 (mlet* %store-monad ((url -> (first (upstream-source-urls source)))
366 -> (and=> (upstream-source-signature-urls source)
368 (tarball ((store-lift download-tarball) url signature)))
370 (raise (formatted-message (G_ "failed to fetch source from '~a'")
373 ;; Instead of returning TARBALL, return a fixed-output derivation that
374 ;; would be able to re-download it. In practice, since TARBALL is already
375 ;; in the store, no extra download will happen, but having the derivation
376 ;; in store improves provenance tracking.
377 (let ((hash (call-with-input-file tarball port-sha256)))
378 (url-fetch url 'sha256 hash (store-path-package-name tarball)
381 (define (find2 pred lst1 lst2)
382 "Like 'find', but operate on items from both LST1 and LST2. Return two
383 values: the item from LST1 and the item from LST2 that match PRED."
384 (let loop ((lst1 lst1) (lst2 lst2))
389 (if (pred head1 head2)
391 (loop tail1 tail2)))))
395 (define* (package-update/url-fetch store package source
397 "Return the version, tarball, and SOURCE, to update PACKAGE to
398 SOURCE, an <upstream-source>."
400 (($ <upstream-source> _ version urls signature-urls)
401 (let*-values (((archive-type)
402 (match (and=> (package-source package) origin-uri)
404 (let ((type (or (file-extension (basename uri)) "")))
405 ;; Sometimes we have URLs such as
406 ;; "https://github.com/…/tarball/v0.1", in which case
407 ;; we must not consider "1" as the extension.
408 (and (or (string-contains type "z")
409 (string=? type "tar"))
414 ;; Try to find a URL that matches ARCHIVE-TYPE.
415 (find2 (lambda (url sig-url)
416 ;; Some URIs lack a file extension, like
417 ;; 'https://crates.io/???/0.1/download'. In that
418 ;; case, pick the first URL.
419 (or (not archive-type)
420 (string-suffix? archive-type url)))
422 (or signature-urls (circular-list #f)))))
423 ;; If none of URLS matches ARCHIVE-TYPE, then URL is #f; in that case,
424 ;; pick up the first element of URLS.
425 (let ((tarball (download-tarball store
426 (or url (first urls))
427 (and (pair? signature-urls)
429 (first signature-urls)))
430 #:key-download key-download)))
431 (values version tarball source))))))
433 (define %method-updates
434 ;; Mapping of origin methods to source update procedures.
435 `((,url-fetch . ,package-update/url-fetch)))
437 (define* (package-update store package
438 #:optional (updaters (force %updaters))
439 #:key (key-download 'interactive))
440 "Return the new version, the file name of the new version tarball, and input
441 changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date.
442 KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
443 values: 'always', 'never', and 'interactive' (default)."
444 (match (package-latest-release* package updaters)
445 ((? upstream-source? source)
446 (let ((method (match (package-source package)
448 (origin-method origin))
451 (match (assq method %method-updates)
453 (raise (make-compound-condition
454 (formatted-message (G_ "cannot download for \
459 (location (package-location package)))))))
461 (update store package source
462 #:key-download key-download)))))
466 (define* (update-package-source package source hash)
467 "Modify the source file that defines PACKAGE to refer to SOURCE, an
468 <upstream-source> whose tarball has SHA256 HASH (a bytevector). Return the
469 new version string if an update was made, and #f otherwise."
470 (define (update-expression expr replacements)
471 ;; Apply REPLACEMENTS to package expression EXPR, a string. REPLACEMENTS
472 ;; must be a list of replacement pairs, either bytevectors or strings.
473 (fold (lambda (replacement str)
475 (((? bytevector? old-bv) . (? bytevector? new-bv))
476 (string-replace-substring
478 (bytevector->nix-base32-string old-bv)
479 (bytevector->nix-base32-string new-bv)))
481 (string-replace-substring str old new))))
485 (let ((name (package-name package))
486 (version (upstream-source-version source))
487 (version-loc (package-field-location package 'version)))
489 (let* ((loc (package-location package))
490 (old-version (package-version package))
491 (old-hash (content-hash-value
492 (origin-hash (package-source package))))
493 (old-url (match (origin-uri (package-source package))
494 ((? string? url) url)
496 (new-url (match (upstream-source-urls source)
497 ((first _ ...) first)))
498 (file (and=> (location-file loc)
499 (cut search-path %load-path <>))))
501 ;; Be sure to use absolute filename. Replace the URL directory
502 ;; when OLD-URL is available; this is useful notably for
503 ;; mirror://cpan/ URLs where the directory may change as a
504 ;; function of the person who uploads the package. Note that
505 ;; package definitions usually concatenate fragments of the URL,
506 ;; which is why we only attempt to replace a subset of the URL.
507 (let ((properties (assq-set! (location->source-properties loc)
509 (replacements `((,old-version . ,version)
511 ,@(if (and old-url new-url)
512 `((,(dirname old-url) .
515 (and (edit-expression properties
516 (cut update-expression <> replacements))
519 (warning (G_ "~a: could not locate source file")
522 (warning (package-location package)
523 (G_ "~a: no `version' field in source; skipping~%")
526 ;;; upstream.scm ends here