Commit | Line | Data |
---|---|---|
0a7c5a09 | 1 | ;;; GNU Guix --- Functional package management for GNU |
0bd1498f | 2 | ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
7e6b490d | 3 | ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> |
7e634c2f | 4 | ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> |
0a7c5a09 LC |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
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. | |
12 | ;;; | |
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. | |
17 | ;;; | |
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/>. | |
20 | ||
21 | (define-module (guix upstream) | |
22 | #:use-module (guix records) | |
23 | #:use-module (guix utils) | |
adf0c531 | 24 | #:use-module (guix discovery) |
0a7c5a09 | 25 | #:use-module ((guix download) |
0bd1498f | 26 | #:select (download-to-store url-fetch)) |
0a7c5a09 LC |
27 | #:use-module (guix gnupg) |
28 | #:use-module (guix packages) | |
29 | #:use-module (guix ui) | |
30 | #:use-module (guix base32) | |
8d5d0628 LC |
31 | #:use-module (guix gexp) |
32 | #:use-module (guix store) | |
33 | #:use-module ((guix derivations) | |
34 | #:select (built-derivations derivation->output-path)) | |
35 | #:use-module (guix monads) | |
0a7c5a09 LC |
36 | #:use-module (srfi srfi-1) |
37 | #:use-module (srfi srfi-9) | |
38 | #:use-module (srfi srfi-11) | |
39 | #:use-module (srfi srfi-26) | |
0bd1498f LC |
40 | #:use-module (srfi srfi-34) |
41 | #:use-module (srfi srfi-35) | |
42314ffa | 42 | #:use-module (rnrs bytevectors) |
0a7c5a09 LC |
43 | #:use-module (ice-9 match) |
44 | #:use-module (ice-9 regex) | |
45 | #:export (upstream-source | |
46 | upstream-source? | |
47 | upstream-source-package | |
48 | upstream-source-version | |
49 | upstream-source-urls | |
50 | upstream-source-signature-urls | |
3195e19d | 51 | upstream-source-archive-types |
7e634c2f | 52 | upstream-source-input-changes |
0a7c5a09 | 53 | |
97abc907 | 54 | url-prefix-predicate |
0a7c5a09 LC |
55 | coalesce-sources |
56 | ||
57 | upstream-updater | |
58 | upstream-updater? | |
59 | upstream-updater-name | |
7e6b490d | 60 | upstream-updater-description |
0a7c5a09 LC |
61 | upstream-updater-predicate |
62 | upstream-updater-latest | |
63 | ||
7e634c2f RW |
64 | upstream-input-change? |
65 | upstream-input-change-name | |
66 | upstream-input-change-type | |
67 | upstream-input-change-action | |
68 | changed-inputs | |
69 | ||
adf0c531 | 70 | %updaters |
e9c72306 LC |
71 | lookup-updater |
72 | ||
0a7c5a09 | 73 | download-tarball |
e9c72306 LC |
74 | package-latest-release |
75 | package-latest-release* | |
0a7c5a09 LC |
76 | package-update |
77 | update-package-source)) | |
78 | ||
79 | ;;; Commentary: | |
80 | ;;; | |
81 | ;;; This module provides tools to represent and manipulate a upstream source | |
82 | ;;; code, and to auto-update package recipes. | |
83 | ;;; | |
84 | ;;; Code: | |
85 | ||
86 | ;; Representation of upstream's source. There can be several URLs--e.g., | |
87 | ;; tar.gz, tar.gz, etc. There can be correspond signature URLs, one per | |
88 | ;; source URL. | |
89 | (define-record-type* <upstream-source> | |
90 | upstream-source make-upstream-source | |
91 | upstream-source? | |
92 | (package upstream-source-package) ;string | |
93 | (version upstream-source-version) ;string | |
94 | (urls upstream-source-urls) ;list of strings | |
95 | (signature-urls upstream-source-signature-urls ;#f | list of strings | |
7e634c2f RW |
96 | (default #f)) |
97 | (input-changes upstream-source-input-changes | |
98 | (default '()) (thunked))) | |
99 | ||
100 | ;; Representation of an upstream input change. | |
101 | (define-record-type* <upstream-input-change> | |
102 | upstream-input-change make-upstream-input-change | |
103 | upstream-input-change? | |
104 | (name upstream-input-change-name) ;string | |
105 | (type upstream-input-change-type) ;symbol: regular | native | propagated | |
106 | (action upstream-input-change-action)) ;symbol: add | remove | |
107 | ||
108 | (define (changed-inputs package package-sexp) | |
109 | "Return a list of input changes for PACKAGE based on the newly imported | |
110 | S-expression PACKAGE-SEXP." | |
111 | (match package-sexp | |
112 | ((and expr ('package fields ...)) | |
113 | (let* ((input->name (match-lambda ((name pkg . out) name))) | |
114 | (new-regular | |
115 | (match expr | |
116 | ((path *** ('inputs | |
117 | ('quasiquote ((label ('unquote sym)) ...)))) label) | |
118 | (_ '()))) | |
119 | (new-native | |
120 | (match expr | |
121 | ((path *** ('native-inputs | |
122 | ('quasiquote ((label ('unquote sym)) ...)))) label) | |
123 | (_ '()))) | |
124 | (new-propagated | |
125 | (match expr | |
126 | ((path *** ('propagated-inputs | |
127 | ('quasiquote ((label ('unquote sym)) ...)))) label) | |
128 | (_ '()))) | |
129 | (current-regular | |
130 | (map input->name (package-inputs package))) | |
131 | (current-native | |
132 | (map input->name (package-native-inputs package))) | |
133 | (current-propagated | |
134 | (map input->name (package-propagated-inputs package)))) | |
135 | (append-map | |
136 | (match-lambda | |
137 | ((action type names) | |
138 | (map (lambda (name) | |
139 | (upstream-input-change | |
140 | (name name) | |
141 | (type type) | |
142 | (action action))) | |
143 | names))) | |
144 | `((add regular | |
145 | ,(lset-difference equal? | |
146 | new-regular current-regular)) | |
147 | (remove regular | |
148 | ,(lset-difference equal? | |
149 | current-regular new-regular)) | |
150 | (add native | |
151 | ,(lset-difference equal? | |
152 | new-native current-native)) | |
153 | (remove native | |
154 | ,(lset-difference equal? | |
155 | current-native new-native)) | |
156 | (add propagated | |
157 | ,(lset-difference equal? | |
158 | new-propagated current-propagated)) | |
159 | (remove propagated | |
160 | ,(lset-difference equal? | |
161 | current-propagated new-propagated)))))) | |
162 | (_ '()))) | |
0a7c5a09 | 163 | |
97abc907 LC |
164 | (define (url-prefix-predicate prefix) |
165 | "Return a predicate that returns true when passed a package where one of its | |
166 | source URLs starts with PREFIX." | |
167 | (lambda (package) | |
168 | (define matching-uri? | |
169 | (match-lambda | |
170 | ((? string? uri) | |
171 | (string-prefix? prefix uri)) | |
172 | (_ | |
173 | #f))) | |
174 | ||
175 | (match (package-source package) | |
176 | ((? origin? origin) | |
177 | (match (origin-uri origin) | |
178 | ((? matching-uri?) #t) | |
179 | (_ #f))) | |
180 | (_ #f)))) | |
181 | ||
0a7c5a09 LC |
182 | (define (upstream-source-archive-types release) |
183 | "Return the available types of archives for RELEASE---a list of strings such | |
184 | as \"gz\" or \"xz\"." | |
185 | (map file-extension (upstream-source-urls release))) | |
186 | ||
187 | (define (coalesce-sources sources) | |
188 | "Coalesce the elements of SOURCES, a list of <upstream-source>, that | |
189 | correspond to the same version." | |
190 | (define (same-version? r1 r2) | |
191 | (string=? (upstream-source-version r1) (upstream-source-version r2))) | |
192 | ||
193 | (define (release>? r1 r2) | |
194 | (version>? (upstream-source-version r1) (upstream-source-version r2))) | |
195 | ||
196 | (fold (lambda (release result) | |
197 | (match result | |
198 | ((head . tail) | |
199 | (if (same-version? release head) | |
200 | (cons (upstream-source | |
201 | (inherit release) | |
202 | (urls (append (upstream-source-urls release) | |
203 | (upstream-source-urls head))) | |
204 | (signature-urls | |
6efa6f76 | 205 | (let ((one (upstream-source-signature-urls release)) |
f1eacbaf | 206 | (two (upstream-source-signature-urls head))) |
6efa6f76 | 207 | (and one two (append one two))))) |
0a7c5a09 LC |
208 | tail) |
209 | (cons release result))) | |
210 | (() | |
211 | (list release)))) | |
212 | '() | |
213 | (sort sources release>?))) | |
214 | ||
215 | \f | |
216 | ;;; | |
217 | ;;; Auto-update. | |
218 | ;;; | |
219 | ||
7e6b490d AK |
220 | (define-record-type* <upstream-updater> |
221 | upstream-updater make-upstream-updater | |
0a7c5a09 | 222 | upstream-updater? |
7e6b490d AK |
223 | (name upstream-updater-name) |
224 | (description upstream-updater-description) | |
225 | (pred upstream-updater-predicate) | |
226 | (latest upstream-updater-latest)) | |
0a7c5a09 | 227 | |
adf0c531 EF |
228 | (define (importer-modules) |
229 | "Return the list of importer modules." | |
230 | (cons (resolve-interface '(guix gnu-maintenance)) | |
231 | (all-modules (map (lambda (entry) | |
232 | `(,entry . "guix/import")) | |
3c0128b0 LC |
233 | %load-path) |
234 | #:warn warn-about-load-error))) | |
adf0c531 EF |
235 | |
236 | (define %updaters | |
237 | ;; The list of publically-known updaters. | |
238 | (delay (fold-module-public-variables (lambda (obj result) | |
239 | (if (upstream-updater? obj) | |
240 | (cons obj result) | |
241 | result)) | |
242 | '() | |
243 | (importer-modules)))) | |
244 | ||
0a7c5a09 LC |
245 | (define (lookup-updater package updaters) |
246 | "Return an updater among UPDATERS that matches PACKAGE, or #f if none of | |
247 | them matches." | |
7c101c4c LC |
248 | (find (match-lambda |
249 | (($ <upstream-updater> name description pred latest) | |
250 | (pred package))) | |
251 | updaters)) | |
0a7c5a09 | 252 | |
e9c72306 | 253 | (define (package-latest-release package updaters) |
7d27a025 | 254 | "Return an upstream source to update PACKAGE, a <package> object, or #f if |
e9c72306 LC |
255 | none of UPDATERS matches PACKAGE. It is the caller's responsibility to ensure |
256 | that the returned source is newer than the current one." | |
0a7c5a09 | 257 | (match (lookup-updater package updaters) |
7c101c4c LC |
258 | ((? upstream-updater? updater) |
259 | ((upstream-updater-latest updater) package)) | |
e9c72306 LC |
260 | (_ #f))) |
261 | ||
262 | (define (package-latest-release* package updaters) | |
263 | "Like 'package-latest-release', but ensure that the return source is newer | |
264 | than that of PACKAGE." | |
265 | (match (package-latest-release package updaters) | |
266 | ((and source ($ <upstream-source> name version)) | |
267 | (and (version>? version (package-version package)) | |
268 | source)) | |
269 | (_ | |
270 | #f))) | |
0a7c5a09 | 271 | |
8d5d0628 LC |
272 | (define (uncompressed-tarball name tarball) |
273 | "Return a derivation that decompresses TARBALL." | |
274 | (define (ref package) | |
275 | (module-ref (resolve-interface '(gnu packages compression)) | |
276 | package)) | |
277 | ||
278 | (define compressor | |
279 | (cond ((or (string-suffix? ".gz" tarball) | |
280 | (string-suffix? ".tgz" tarball)) | |
281 | (file-append (ref 'gzip) "/bin/gzip")) | |
282 | ((string-suffix? ".bz2" tarball) | |
283 | (file-append (ref 'bzip2) "/bin/bzip2")) | |
284 | ((string-suffix? ".xz" tarball) | |
285 | (file-append (ref 'xz) "/bin/xz")) | |
286 | ((string-suffix? ".lz" tarball) | |
287 | (file-append (ref 'lzip) "/bin/lzip")) | |
288 | (else | |
289 | (error "unknown archive type" tarball)))) | |
290 | ||
291 | (gexp->derivation (file-sans-extension name) | |
292 | #~(begin | |
293 | (copy-file #+tarball #+name) | |
294 | (and (zero? (system* #+compressor "-d" #+name)) | |
295 | (copy-file #+(file-sans-extension name) | |
296 | #$output))))) | |
297 | ||
0a7c5a09 LC |
298 | (define* (download-tarball store url signature-url |
299 | #:key (key-download 'interactive)) | |
300 | "Download the tarball at URL to the store; check its OpenPGP signature at | |
301 | SIGNATURE-URL, unless SIGNATURE-URL is false. On success, return the tarball | |
14959038 LC |
302 | file name; return #f on failure (network failure or authentication failure). |
303 | KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed | |
304 | values: 'interactive' (default), 'always', and 'never'." | |
0a7c5a09 LC |
305 | (let ((tarball (download-to-store store url))) |
306 | (if (not signature-url) | |
307 | tarball | |
8d5d0628 LC |
308 | (let* ((sig (download-to-store store signature-url)) |
309 | ||
310 | ;; Sometimes we get a signature over the uncompressed tarball. | |
311 | ;; In that case, decompress the tarball in the store so that we | |
312 | ;; can check the signature. | |
313 | (data (if (string-prefix? (basename url) | |
314 | (basename signature-url)) | |
315 | tarball | |
316 | (run-with-store store | |
317 | (mlet %store-monad ((drv (uncompressed-tarball | |
318 | (basename url) tarball))) | |
319 | (mbegin %store-monad | |
320 | (built-derivations (list drv)) | |
321 | (return (derivation->output-path drv))))))) | |
322 | ||
323 | (ret (gnupg-verify* sig data #:key-download key-download))) | |
0a7c5a09 LC |
324 | (if ret |
325 | tarball | |
326 | (begin | |
69daee23 | 327 | (warning (G_ "signature verification failed for `~a'~%") |
0a7c5a09 | 328 | url) |
69daee23 | 329 | (warning (G_ "(could be because the public key is not in your keyring)~%")) |
0a7c5a09 LC |
330 | #f)))))) |
331 | ||
332 | (define (find2 pred lst1 lst2) | |
333 | "Like 'find', but operate on items from both LST1 and LST2. Return two | |
334 | values: the item from LST1 and the item from LST2 that match PRED." | |
335 | (let loop ((lst1 lst1) (lst2 lst2)) | |
336 | (match lst1 | |
337 | ((head1 . tail1) | |
338 | (match lst2 | |
339 | ((head2 . tail2) | |
340 | (if (pred head1 head2) | |
341 | (values head1 head2) | |
342 | (loop tail1 tail2))))) | |
343 | (() | |
344 | (values #f #f))))) | |
345 | ||
0bd1498f LC |
346 | (define* (package-update/url-fetch store package source |
347 | #:key key-download) | |
1ee3d2dc | 348 | "Return the version, tarball, and SOURCE, to update PACKAGE to |
0bd1498f LC |
349 | SOURCE, an <upstream-source>." |
350 | (match source | |
1ee3d2dc | 351 | (($ <upstream-source> _ version urls signature-urls) |
0bd1498f | 352 | (let*-values (((archive-type) |
0a7c5a09 LC |
353 | (match (and=> (package-source package) origin-uri) |
354 | ((? string? uri) | |
618f0582 LC |
355 | (let ((type (file-extension (basename uri)))) |
356 | ;; Sometimes we have URLs such as | |
357 | ;; "https://github.com/…/tarball/v0.1", in which case | |
358 | ;; we must not consider "1" as the extension. | |
359 | (and (or (string-contains type "z") | |
360 | (string=? type "tar")) | |
361 | type))) | |
0a7c5a09 LC |
362 | (_ |
363 | "gz"))) | |
364 | ((url signature-url) | |
0ea009db | 365 | ;; Try to find a URL that matches ARCHIVE-TYPE. |
0a7c5a09 | 366 | (find2 (lambda (url sig-url) |
af72a21a LC |
367 | ;; Some URIs lack a file extension, like |
368 | ;; 'https://crates.io/???/0.1/download'. In that | |
369 | ;; case, pick the first URL. | |
370 | (or (not archive-type) | |
371 | (string-suffix? archive-type url))) | |
0a7c5a09 LC |
372 | urls |
373 | (or signature-urls (circular-list #f))))) | |
0ea009db LC |
374 | ;; If none of URLS matches ARCHIVE-TYPE, then URL is #f; in that case, |
375 | ;; pick up the first element of URLS. | |
376 | (let ((tarball (download-tarball store | |
377 | (or url (first urls)) | |
378 | (and (pair? signature-urls) | |
379 | (or signature-url | |
380 | (first signature-urls))) | |
0a7c5a09 | 381 | #:key-download key-download))) |
1ee3d2dc | 382 | (values version tarball source)))))) |
0bd1498f LC |
383 | |
384 | (define %method-updates | |
385 | ;; Mapping of origin methods to source update procedures. | |
386 | `((,url-fetch . ,package-update/url-fetch))) | |
387 | ||
388 | (define* (package-update store package updaters | |
389 | #:key (key-download 'interactive)) | |
390 | "Return the new version, the file name of the new version tarball, and input | |
391 | changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date. | |
392 | KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed | |
393 | values: 'always', 'never', and 'interactive' (default)." | |
394 | (match (package-latest-release* package updaters) | |
395 | ((? upstream-source? source) | |
396 | (let ((method (match (package-source package) | |
397 | ((? origin? origin) | |
398 | (origin-method origin)) | |
399 | (_ | |
400 | #f)))) | |
401 | (match (assq method %method-updates) | |
402 | (#f | |
403 | (raise (condition (&message | |
404 | (message (format #f (G_ "cannot download for \ | |
405 | this method: ~s") | |
406 | method))) | |
407 | (&error-location | |
408 | (location (package-location package)))))) | |
409 | ((_ . update) | |
410 | (update store package source | |
411 | #:key-download key-download))))) | |
0a7c5a09 | 412 | (#f |
7e634c2f | 413 | (values #f #f #f)))) |
0a7c5a09 | 414 | |
42314ffa LC |
415 | (define* (update-package-source package source hash) |
416 | "Modify the source file that defines PACKAGE to refer to SOURCE, an | |
417 | <upstream-source> whose tarball has SHA256 HASH (a bytevector). Return the | |
418 | new version string if an update was made, and #f otherwise." | |
419 | (define (update-expression expr replacements) | |
420 | ;; Apply REPLACEMENTS to package expression EXPR, a string. REPLACEMENTS | |
421 | ;; must be a list of replacement pairs, either bytevectors or strings. | |
422 | (fold (lambda (replacement str) | |
423 | (match replacement | |
424 | (((? bytevector? old-bv) . (? bytevector? new-bv)) | |
425 | (string-replace-substring | |
426 | str | |
427 | (bytevector->nix-base32-string old-bv) | |
428 | (bytevector->nix-base32-string new-bv))) | |
429 | ((old . new) | |
430 | (string-replace-substring str old new)))) | |
431 | expr | |
432 | replacements)) | |
2b8e9d9e SB |
433 | |
434 | (let ((name (package-name package)) | |
42314ffa | 435 | (version (upstream-source-version source)) |
2b8e9d9e SB |
436 | (version-loc (package-field-location package 'version))) |
437 | (if version-loc | |
438 | (let* ((loc (package-location package)) | |
439 | (old-version (package-version package)) | |
440 | (old-hash (origin-sha256 (package-source package))) | |
42314ffa LC |
441 | (old-url (match (origin-uri (package-source package)) |
442 | ((? string? url) url) | |
443 | (_ #f))) | |
444 | (new-url (match (upstream-source-urls source) | |
445 | ((first _ ...) first))) | |
2b8e9d9e SB |
446 | (file (and=> (location-file loc) |
447 | (cut search-path %load-path <>)))) | |
0a7c5a09 | 448 | (if file |
42314ffa LC |
449 | ;; Be sure to use absolute filename. Replace the URL directory |
450 | ;; when OLD-URL is available; this is useful notably for | |
451 | ;; mirror://cpan/ URLs where the directory may change as a | |
452 | ;; function of the person who uploads the package. Note that | |
453 | ;; package definitions usually concatenate fragments of the URL, | |
454 | ;; which is why we only attempt to replace a subset of the URL. | |
455 | (let ((properties (assq-set! (location->source-properties loc) | |
456 | 'filename file)) | |
457 | (replacements `((,old-version . ,version) | |
458 | (,old-hash . ,hash) | |
459 | ,@(if (and old-url new-url) | |
460 | `((,(dirname old-url) . | |
461 | ,(dirname new-url))) | |
462 | '())))) | |
463 | (and (edit-expression properties | |
464 | (cut update-expression <> replacements)) | |
465 | version)) | |
0a7c5a09 | 466 | (begin |
69daee23 | 467 | (warning (G_ "~a: could not locate source file") |
0a7c5a09 LC |
468 | (location-file loc)) |
469 | #f))) | |
470 | (begin | |
471 | (format (current-error-port) | |
69daee23 | 472 | (G_ "~a: ~a: no `version' field in source; skipping~%") |
0a7c5a09 LC |
473 | (location->string (package-location package)) |
474 | name))))) | |
475 | ||
476 | ;;; upstream.scm ends here |