Commit | Line | Data |
---|---|---|
0a7c5a09 | 1 | ;;; GNU Guix --- Functional package management for GNU |
3b2dc9ed | 2 | ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
7e6b490d | 3 | ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> |
0a7c5a09 LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix upstream) | |
21 | #:use-module (guix records) | |
22 | #:use-module (guix utils) | |
23 | #:use-module ((guix download) | |
24 | #:select (download-to-store)) | |
0a7c5a09 LC |
25 | #:use-module (guix gnupg) |
26 | #:use-module (guix packages) | |
27 | #:use-module (guix ui) | |
28 | #:use-module (guix base32) | |
8d5d0628 LC |
29 | #:use-module (guix gexp) |
30 | #:use-module (guix store) | |
31 | #:use-module ((guix derivations) | |
32 | #:select (built-derivations derivation->output-path)) | |
33 | #:use-module (guix monads) | |
0a7c5a09 LC |
34 | #:use-module (srfi srfi-1) |
35 | #:use-module (srfi srfi-9) | |
36 | #:use-module (srfi srfi-11) | |
37 | #:use-module (srfi srfi-26) | |
38 | #:use-module (ice-9 match) | |
39 | #:use-module (ice-9 regex) | |
40 | #:export (upstream-source | |
41 | upstream-source? | |
42 | upstream-source-package | |
43 | upstream-source-version | |
44 | upstream-source-urls | |
45 | upstream-source-signature-urls | |
3195e19d | 46 | upstream-source-archive-types |
0a7c5a09 LC |
47 | |
48 | coalesce-sources | |
49 | ||
50 | upstream-updater | |
51 | upstream-updater? | |
52 | upstream-updater-name | |
7e6b490d | 53 | upstream-updater-description |
0a7c5a09 LC |
54 | upstream-updater-predicate |
55 | upstream-updater-latest | |
56 | ||
e9c72306 LC |
57 | lookup-updater |
58 | ||
0a7c5a09 | 59 | download-tarball |
e9c72306 LC |
60 | package-latest-release |
61 | package-latest-release* | |
0a7c5a09 LC |
62 | package-update |
63 | update-package-source)) | |
64 | ||
65 | ;;; Commentary: | |
66 | ;;; | |
67 | ;;; This module provides tools to represent and manipulate a upstream source | |
68 | ;;; code, and to auto-update package recipes. | |
69 | ;;; | |
70 | ;;; Code: | |
71 | ||
72 | ;; Representation of upstream's source. There can be several URLs--e.g., | |
73 | ;; tar.gz, tar.gz, etc. There can be correspond signature URLs, one per | |
74 | ;; source URL. | |
75 | (define-record-type* <upstream-source> | |
76 | upstream-source make-upstream-source | |
77 | upstream-source? | |
78 | (package upstream-source-package) ;string | |
79 | (version upstream-source-version) ;string | |
80 | (urls upstream-source-urls) ;list of strings | |
81 | (signature-urls upstream-source-signature-urls ;#f | list of strings | |
82 | (default #f))) | |
83 | ||
84 | (define (upstream-source-archive-types release) | |
85 | "Return the available types of archives for RELEASE---a list of strings such | |
86 | as \"gz\" or \"xz\"." | |
87 | (map file-extension (upstream-source-urls release))) | |
88 | ||
89 | (define (coalesce-sources sources) | |
90 | "Coalesce the elements of SOURCES, a list of <upstream-source>, that | |
91 | correspond to the same version." | |
92 | (define (same-version? r1 r2) | |
93 | (string=? (upstream-source-version r1) (upstream-source-version r2))) | |
94 | ||
95 | (define (release>? r1 r2) | |
96 | (version>? (upstream-source-version r1) (upstream-source-version r2))) | |
97 | ||
98 | (fold (lambda (release result) | |
99 | (match result | |
100 | ((head . tail) | |
101 | (if (same-version? release head) | |
102 | (cons (upstream-source | |
103 | (inherit release) | |
104 | (urls (append (upstream-source-urls release) | |
105 | (upstream-source-urls head))) | |
106 | (signature-urls | |
6efa6f76 | 107 | (let ((one (upstream-source-signature-urls release)) |
f1eacbaf | 108 | (two (upstream-source-signature-urls head))) |
6efa6f76 | 109 | (and one two (append one two))))) |
0a7c5a09 LC |
110 | tail) |
111 | (cons release result))) | |
112 | (() | |
113 | (list release)))) | |
114 | '() | |
115 | (sort sources release>?))) | |
116 | ||
117 | \f | |
118 | ;;; | |
119 | ;;; Auto-update. | |
120 | ;;; | |
121 | ||
7e6b490d AK |
122 | (define-record-type* <upstream-updater> |
123 | upstream-updater make-upstream-updater | |
0a7c5a09 | 124 | upstream-updater? |
7e6b490d AK |
125 | (name upstream-updater-name) |
126 | (description upstream-updater-description) | |
127 | (pred upstream-updater-predicate) | |
128 | (latest upstream-updater-latest)) | |
0a7c5a09 LC |
129 | |
130 | (define (lookup-updater package updaters) | |
131 | "Return an updater among UPDATERS that matches PACKAGE, or #f if none of | |
132 | them matches." | |
133 | (any (match-lambda | |
3b2dc9ed | 134 | (($ <upstream-updater> name description pred latest) |
0a7c5a09 LC |
135 | (and (pred package) latest))) |
136 | updaters)) | |
137 | ||
e9c72306 | 138 | (define (package-latest-release package updaters) |
7d27a025 | 139 | "Return an upstream source to update PACKAGE, a <package> object, or #f if |
e9c72306 LC |
140 | none of UPDATERS matches PACKAGE. It is the caller's responsibility to ensure |
141 | that the returned source is newer than the current one." | |
0a7c5a09 LC |
142 | (match (lookup-updater package updaters) |
143 | ((? procedure? latest-release) | |
e9c72306 LC |
144 | (latest-release package)) |
145 | (_ #f))) | |
146 | ||
147 | (define (package-latest-release* package updaters) | |
148 | "Like 'package-latest-release', but ensure that the return source is newer | |
149 | than that of PACKAGE." | |
150 | (match (package-latest-release package updaters) | |
151 | ((and source ($ <upstream-source> name version)) | |
152 | (and (version>? version (package-version package)) | |
153 | source)) | |
154 | (_ | |
155 | #f))) | |
0a7c5a09 | 156 | |
8d5d0628 LC |
157 | (define (uncompressed-tarball name tarball) |
158 | "Return a derivation that decompresses TARBALL." | |
159 | (define (ref package) | |
160 | (module-ref (resolve-interface '(gnu packages compression)) | |
161 | package)) | |
162 | ||
163 | (define compressor | |
164 | (cond ((or (string-suffix? ".gz" tarball) | |
165 | (string-suffix? ".tgz" tarball)) | |
166 | (file-append (ref 'gzip) "/bin/gzip")) | |
167 | ((string-suffix? ".bz2" tarball) | |
168 | (file-append (ref 'bzip2) "/bin/bzip2")) | |
169 | ((string-suffix? ".xz" tarball) | |
170 | (file-append (ref 'xz) "/bin/xz")) | |
171 | ((string-suffix? ".lz" tarball) | |
172 | (file-append (ref 'lzip) "/bin/lzip")) | |
173 | (else | |
174 | (error "unknown archive type" tarball)))) | |
175 | ||
176 | (gexp->derivation (file-sans-extension name) | |
177 | #~(begin | |
178 | (copy-file #+tarball #+name) | |
179 | (and (zero? (system* #+compressor "-d" #+name)) | |
180 | (copy-file #+(file-sans-extension name) | |
181 | #$output))))) | |
182 | ||
0a7c5a09 LC |
183 | (define* (download-tarball store url signature-url |
184 | #:key (key-download 'interactive)) | |
185 | "Download the tarball at URL to the store; check its OpenPGP signature at | |
186 | SIGNATURE-URL, unless SIGNATURE-URL is false. On success, return the tarball | |
14959038 LC |
187 | file name; return #f on failure (network failure or authentication failure). |
188 | KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed | |
189 | values: 'interactive' (default), 'always', and 'never'." | |
0a7c5a09 LC |
190 | (let ((tarball (download-to-store store url))) |
191 | (if (not signature-url) | |
192 | tarball | |
8d5d0628 LC |
193 | (let* ((sig (download-to-store store signature-url)) |
194 | ||
195 | ;; Sometimes we get a signature over the uncompressed tarball. | |
196 | ;; In that case, decompress the tarball in the store so that we | |
197 | ;; can check the signature. | |
198 | (data (if (string-prefix? (basename url) | |
199 | (basename signature-url)) | |
200 | tarball | |
201 | (run-with-store store | |
202 | (mlet %store-monad ((drv (uncompressed-tarball | |
203 | (basename url) tarball))) | |
204 | (mbegin %store-monad | |
205 | (built-derivations (list drv)) | |
206 | (return (derivation->output-path drv))))))) | |
207 | ||
208 | (ret (gnupg-verify* sig data #:key-download key-download))) | |
0a7c5a09 LC |
209 | (if ret |
210 | tarball | |
211 | (begin | |
69daee23 | 212 | (warning (G_ "signature verification failed for `~a'~%") |
0a7c5a09 | 213 | url) |
69daee23 | 214 | (warning (G_ "(could be because the public key is not in your keyring)~%")) |
0a7c5a09 LC |
215 | #f)))))) |
216 | ||
217 | (define (find2 pred lst1 lst2) | |
218 | "Like 'find', but operate on items from both LST1 and LST2. Return two | |
219 | values: the item from LST1 and the item from LST2 that match PRED." | |
220 | (let loop ((lst1 lst1) (lst2 lst2)) | |
221 | (match lst1 | |
222 | ((head1 . tail1) | |
223 | (match lst2 | |
224 | ((head2 . tail2) | |
225 | (if (pred head1 head2) | |
226 | (values head1 head2) | |
227 | (loop tail1 tail2))))) | |
228 | (() | |
229 | (values #f #f))))) | |
230 | ||
231 | (define* (package-update store package updaters | |
232 | #:key (key-download 'interactive)) | |
233 | "Return the new version and the file name of the new version tarball for | |
234 | PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a | |
235 | download policy for missing OpenPGP keys; allowed values: 'always', 'never', | |
236 | and 'interactive' (default)." | |
e9c72306 | 237 | (match (package-latest-release* package updaters) |
0a7c5a09 LC |
238 | (($ <upstream-source> _ version urls signature-urls) |
239 | (let*-values (((name) | |
240 | (package-name package)) | |
241 | ((archive-type) | |
242 | (match (and=> (package-source package) origin-uri) | |
243 | ((? string? uri) | |
6976c681 | 244 | (file-extension (basename uri))) |
0a7c5a09 LC |
245 | (_ |
246 | "gz"))) | |
247 | ((url signature-url) | |
248 | (find2 (lambda (url sig-url) | |
af72a21a LC |
249 | ;; Some URIs lack a file extension, like |
250 | ;; 'https://crates.io/???/0.1/download'. In that | |
251 | ;; case, pick the first URL. | |
252 | (or (not archive-type) | |
253 | (string-suffix? archive-type url))) | |
0a7c5a09 LC |
254 | urls |
255 | (or signature-urls (circular-list #f))))) | |
256 | (let ((tarball (download-tarball store url signature-url | |
257 | #:key-download key-download))) | |
258 | (values version tarball)))) | |
259 | (#f | |
260 | (values #f #f)))) | |
261 | ||
262 | (define (update-package-source package version hash) | |
263 | "Modify the source file that defines PACKAGE to refer to VERSION, | |
264 | whose tarball has SHA256 HASH (a bytevector). Return the new version string | |
265 | if an update was made, and #f otherwise." | |
2b8e9d9e SB |
266 | (define (update-expression expr old-version version old-hash hash) |
267 | ;; Update package expression EXPR, replacing occurrences OLD-VERSION by | |
268 | ;; VERSION and occurrences of OLD-HASH by HASH (base32 representation | |
269 | ;; thereof). | |
0a7c5a09 LC |
270 | (let ((old-hash (bytevector->nix-base32-string old-hash)) |
271 | (hash (bytevector->nix-base32-string hash))) | |
2b8e9d9e SB |
272 | (string-replace-substring |
273 | (string-replace-substring expr old-hash hash) | |
274 | old-version version))) | |
275 | ||
276 | (let ((name (package-name package)) | |
277 | (version-loc (package-field-location package 'version))) | |
278 | (if version-loc | |
279 | (let* ((loc (package-location package)) | |
280 | (old-version (package-version package)) | |
281 | (old-hash (origin-sha256 (package-source package))) | |
282 | (file (and=> (location-file loc) | |
283 | (cut search-path %load-path <>)))) | |
0a7c5a09 | 284 | (if file |
2b8e9d9e SB |
285 | (and (edit-expression |
286 | ;; Be sure to use absolute filename. | |
287 | (assq-set! (location->source-properties loc) | |
288 | 'filename file) | |
289 | (cut update-expression <> | |
290 | old-version version old-hash hash)) | |
291 | version) | |
0a7c5a09 | 292 | (begin |
69daee23 | 293 | (warning (G_ "~a: could not locate source file") |
0a7c5a09 LC |
294 | (location-file loc)) |
295 | #f))) | |
296 | (begin | |
297 | (format (current-error-port) | |
69daee23 | 298 | (G_ "~a: ~a: no `version' field in source; skipping~%") |
0a7c5a09 LC |
299 | (location->string (package-location package)) |
300 | name))))) | |
301 | ||
302 | ;;; upstream.scm ends here |