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