Commit | Line | Data |
---|---|---|
0a7c5a09 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 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)) | |
25 | #:use-module ((guix build utils) | |
26 | #:select (substitute)) | |
27 | #:use-module (guix gnupg) | |
28 | #:use-module (guix packages) | |
29 | #:use-module (guix ui) | |
30 | #:use-module (guix base32) | |
31 | #:use-module (srfi srfi-1) | |
32 | #:use-module (srfi srfi-9) | |
33 | #:use-module (srfi srfi-11) | |
34 | #:use-module (srfi srfi-26) | |
35 | #:use-module (ice-9 match) | |
36 | #:use-module (ice-9 regex) | |
37 | #:export (upstream-source | |
38 | upstream-source? | |
39 | upstream-source-package | |
40 | upstream-source-version | |
41 | upstream-source-urls | |
42 | upstream-source-signature-urls | |
43 | ||
44 | coalesce-sources | |
45 | ||
46 | upstream-updater | |
47 | upstream-updater? | |
48 | upstream-updater-name | |
7e6b490d | 49 | upstream-updater-description |
0a7c5a09 LC |
50 | upstream-updater-predicate |
51 | upstream-updater-latest | |
52 | ||
53 | download-tarball | |
54 | package-update-path | |
55 | package-update | |
56 | update-package-source)) | |
57 | ||
58 | ;;; Commentary: | |
59 | ;;; | |
60 | ;;; This module provides tools to represent and manipulate a upstream source | |
61 | ;;; code, and to auto-update package recipes. | |
62 | ;;; | |
63 | ;;; Code: | |
64 | ||
65 | ;; Representation of upstream's source. There can be several URLs--e.g., | |
66 | ;; tar.gz, tar.gz, etc. There can be correspond signature URLs, one per | |
67 | ;; source URL. | |
68 | (define-record-type* <upstream-source> | |
69 | upstream-source make-upstream-source | |
70 | upstream-source? | |
71 | (package upstream-source-package) ;string | |
72 | (version upstream-source-version) ;string | |
73 | (urls upstream-source-urls) ;list of strings | |
74 | (signature-urls upstream-source-signature-urls ;#f | list of strings | |
75 | (default #f))) | |
76 | ||
77 | (define (upstream-source-archive-types release) | |
78 | "Return the available types of archives for RELEASE---a list of strings such | |
79 | as \"gz\" or \"xz\"." | |
80 | (map file-extension (upstream-source-urls release))) | |
81 | ||
82 | (define (coalesce-sources sources) | |
83 | "Coalesce the elements of SOURCES, a list of <upstream-source>, that | |
84 | correspond to the same version." | |
85 | (define (same-version? r1 r2) | |
86 | (string=? (upstream-source-version r1) (upstream-source-version r2))) | |
87 | ||
88 | (define (release>? r1 r2) | |
89 | (version>? (upstream-source-version r1) (upstream-source-version r2))) | |
90 | ||
91 | (fold (lambda (release result) | |
92 | (match result | |
93 | ((head . tail) | |
94 | (if (same-version? release head) | |
95 | (cons (upstream-source | |
96 | (inherit release) | |
97 | (urls (append (upstream-source-urls release) | |
98 | (upstream-source-urls head))) | |
99 | (signature-urls | |
100 | (append (upstream-source-signature-urls release) | |
101 | (upstream-source-signature-urls head)))) | |
102 | tail) | |
103 | (cons release result))) | |
104 | (() | |
105 | (list release)))) | |
106 | '() | |
107 | (sort sources release>?))) | |
108 | ||
109 | \f | |
110 | ;;; | |
111 | ;;; Auto-update. | |
112 | ;;; | |
113 | ||
7e6b490d AK |
114 | (define-record-type* <upstream-updater> |
115 | upstream-updater make-upstream-updater | |
0a7c5a09 | 116 | upstream-updater? |
7e6b490d AK |
117 | (name upstream-updater-name) |
118 | (description upstream-updater-description) | |
119 | (pred upstream-updater-predicate) | |
120 | (latest upstream-updater-latest)) | |
0a7c5a09 LC |
121 | |
122 | (define (lookup-updater package updaters) | |
123 | "Return an updater among UPDATERS that matches PACKAGE, or #f if none of | |
124 | them matches." | |
125 | (any (match-lambda | |
7e6b490d | 126 | (($ <upstream-updater> _ _ pred latest) |
0a7c5a09 LC |
127 | (and (pred package) latest))) |
128 | updaters)) | |
129 | ||
130 | (define (package-update-path package updaters) | |
131 | "Return an upstream source to update PACKAGE to, or #f if no update is | |
132 | needed or known." | |
133 | (match (lookup-updater package updaters) | |
134 | ((? procedure? latest-release) | |
135 | (match (latest-release (package-name package)) | |
136 | ((and source ($ <upstream-source> name version)) | |
137 | (and (version>? version (package-version package)) | |
138 | source)) | |
139 | (_ #f))) | |
140 | (#f #f))) | |
141 | ||
142 | (define* (download-tarball store url signature-url | |
143 | #:key (key-download 'interactive)) | |
144 | "Download the tarball at URL to the store; check its OpenPGP signature at | |
145 | SIGNATURE-URL, unless SIGNATURE-URL is false. On success, return the tarball | |
146 | file name. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; | |
147 | allowed values: 'interactive' (default), 'always', and 'never'." | |
148 | (let ((tarball (download-to-store store url))) | |
149 | (if (not signature-url) | |
150 | tarball | |
151 | (let* ((sig (download-to-store store signature-url)) | |
152 | (ret (gnupg-verify* sig tarball #:key-download key-download))) | |
153 | (if ret | |
154 | tarball | |
155 | (begin | |
156 | (warning (_ "signature verification failed for `~a'~%") | |
157 | url) | |
158 | (warning (_ "(could be because the public key is not in your keyring)~%")) | |
159 | #f)))))) | |
160 | ||
161 | (define (find2 pred lst1 lst2) | |
162 | "Like 'find', but operate on items from both LST1 and LST2. Return two | |
163 | values: the item from LST1 and the item from LST2 that match PRED." | |
164 | (let loop ((lst1 lst1) (lst2 lst2)) | |
165 | (match lst1 | |
166 | ((head1 . tail1) | |
167 | (match lst2 | |
168 | ((head2 . tail2) | |
169 | (if (pred head1 head2) | |
170 | (values head1 head2) | |
171 | (loop tail1 tail2))))) | |
172 | (() | |
173 | (values #f #f))))) | |
174 | ||
175 | (define* (package-update store package updaters | |
176 | #:key (key-download 'interactive)) | |
177 | "Return the new version and the file name of the new version tarball for | |
178 | PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a | |
179 | download policy for missing OpenPGP keys; allowed values: 'always', 'never', | |
180 | and 'interactive' (default)." | |
181 | (match (package-update-path package updaters) | |
182 | (($ <upstream-source> _ version urls signature-urls) | |
183 | (let*-values (((name) | |
184 | (package-name package)) | |
185 | ((archive-type) | |
186 | (match (and=> (package-source package) origin-uri) | |
187 | ((? string? uri) | |
188 | (or (file-extension uri) "gz")) | |
189 | (_ | |
190 | "gz"))) | |
191 | ((url signature-url) | |
192 | (find2 (lambda (url sig-url) | |
193 | (string-suffix? archive-type url)) | |
194 | urls | |
195 | (or signature-urls (circular-list #f))))) | |
196 | (let ((tarball (download-tarball store url signature-url | |
197 | #:key-download key-download))) | |
198 | (values version tarball)))) | |
199 | (#f | |
200 | (values #f #f)))) | |
201 | ||
202 | (define (update-package-source package version hash) | |
203 | "Modify the source file that defines PACKAGE to refer to VERSION, | |
204 | whose tarball has SHA256 HASH (a bytevector). Return the new version string | |
205 | if an update was made, and #f otherwise." | |
206 | (define (new-line line matches replacement) | |
207 | ;; Iterate over MATCHES and return the modified line based on LINE. | |
208 | ;; Replace each match with REPLACEMENT. | |
209 | (let loop ((m* matches) ; matches | |
210 | (o 0) ; offset in L | |
211 | (r '())) ; result | |
212 | (match m* | |
213 | (() | |
214 | (let ((r (cons (substring line o) r))) | |
215 | (string-concatenate-reverse r))) | |
216 | ((m . rest) | |
217 | (loop rest | |
218 | (match:end m) | |
219 | (cons* replacement | |
220 | (substring line o (match:start m)) | |
221 | r)))))) | |
222 | ||
223 | (define (update-source file old-version version | |
224 | old-hash hash) | |
225 | ;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION | |
226 | ;; and occurrences of OLD-HASH by HASH (base32 representation thereof). | |
227 | ||
228 | ;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in | |
229 | ;; different unrelated places, we may modify it more than needed, for | |
230 | ;; instance. We should try to make changes only within the sexp that | |
231 | ;; corresponds to the definition of PACKAGE. | |
232 | (let ((old-hash (bytevector->nix-base32-string old-hash)) | |
233 | (hash (bytevector->nix-base32-string hash))) | |
234 | (substitute file | |
235 | `((,(regexp-quote old-version) | |
236 | . ,(cut new-line <> <> version)) | |
237 | (,(regexp-quote old-hash) | |
238 | . ,(cut new-line <> <> hash)))) | |
239 | version)) | |
240 | ||
241 | (let ((name (package-name package)) | |
242 | (loc (package-field-location package 'version))) | |
243 | (if loc | |
244 | (let ((old-version (package-version package)) | |
245 | (old-hash (origin-sha256 (package-source package))) | |
246 | (file (and=> (location-file loc) | |
247 | (cut search-path %load-path <>)))) | |
248 | (if file | |
249 | (update-source file | |
250 | old-version version | |
251 | old-hash hash) | |
252 | (begin | |
253 | (warning (_ "~a: could not locate source file") | |
254 | (location-file loc)) | |
255 | #f))) | |
256 | (begin | |
257 | (format (current-error-port) | |
258 | (_ "~a: ~a: no `version' field in source; skipping~%") | |
259 | (location->string (package-location package)) | |
260 | name))))) | |
261 | ||
262 | ;;; upstream.scm ends here |