Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
98fefb21 | 2 | ;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org> |
f9bbf2a8 | 3 | ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> |
22189ed1 | 4 | ;;; |
233e7676 | 5 | ;;; This file is part of GNU Guix. |
22189ed1 | 6 | ;;; |
233e7676 | 7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
22189ed1 NK |
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 | ;;; | |
233e7676 | 12 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
22189ed1 NK |
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 | |
233e7676 | 18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
22189ed1 NK |
19 | |
20 | (define-module (guix gnu-maintenance) | |
21 | #:use-module (web uri) | |
22 | #:use-module (web client) | |
23 | #:use-module (web response) | |
24 | #:use-module (ice-9 regex) | |
f9bbf2a8 | 25 | #:use-module (ice-9 rdelim) |
98fefb21 | 26 | #:use-module (ice-9 match) |
22189ed1 NK |
27 | #:use-module (srfi srfi-1) |
28 | #:use-module (srfi srfi-11) | |
29 | #:use-module (srfi srfi-26) | |
98fefb21 | 30 | #:use-module (system foreign) |
1c9e7d65 | 31 | #:use-module (guix web) |
98fefb21 | 32 | #:use-module (guix ftp-client) |
98eb8cbe | 33 | #:use-module (guix ui) |
0d1e6ce4 | 34 | #:use-module (guix utils) |
ef010c0f | 35 | #:use-module (guix packages) |
0fdd3bea LC |
36 | #:use-module ((guix download) #:select (download-to-store)) |
37 | #:use-module (guix gnupg) | |
38 | #:use-module (rnrs io ports) | |
39 | #:use-module (guix base32) | |
40 | #:use-module ((guix build utils) | |
41 | #:select (substitute)) | |
f9bbf2a8 NK |
42 | #:export (gnu-package-name |
43 | gnu-package-mundane-name | |
44 | gnu-package-copyright-holder | |
45 | gnu-package-savannah | |
46 | gnu-package-fsd | |
47 | gnu-package-language | |
48 | gnu-package-logo | |
49 | gnu-package-doc-category | |
50 | gnu-package-doc-summary | |
51 | gnu-package-doc-urls | |
52 | gnu-package-download-url | |
53 | ||
54 | official-gnu-packages | |
55 | find-packages | |
ef010c0f | 56 | gnu-package? |
f9bbf2a8 | 57 | |
98fefb21 LC |
58 | releases |
59 | latest-release | |
0fdd3bea LC |
60 | gnu-package-name->name+version |
61 | package-update-path | |
62 | package-update | |
63 | update-package-source)) | |
98fefb21 LC |
64 | |
65 | ;;; Commentary: | |
66 | ;;; | |
67 | ;;; Code for dealing with the maintenance of GNU packages, such as | |
68 | ;;; auto-updates. | |
69 | ;;; | |
70 | ;;; Code: | |
71 | ||
72 | \f | |
73 | ;;; | |
74 | ;;; List of GNU packages. | |
75 | ;;; | |
22189ed1 | 76 | |
22189ed1 | 77 | (define %package-list-url |
1c9e7d65 LC |
78 | (string->uri |
79 | (string-append "http://cvs.savannah.gnu.org/" | |
80 | "viewvc/*checkout*/gnumaint/" | |
81 | "gnupackages.txt?root=womb"))) | |
22189ed1 | 82 | |
f9bbf2a8 NK |
83 | (define-record-type* <gnu-package-descriptor> |
84 | gnu-package-descriptor | |
85 | make-gnu-package-descriptor | |
86 | ||
87 | gnu-package-descriptor? | |
88 | ||
89 | (name gnu-package-name) | |
90 | (mundane-name gnu-package-mundane-name) | |
91 | (copyright-holder gnu-package-copyright-holder) | |
92 | (savannah gnu-package-savannah) | |
93 | (fsd gnu-package-fsd) | |
94 | (language gnu-package-language) | |
95 | (logo gnu-package-logo) | |
96 | (doc-category gnu-package-doc-category) | |
97 | (doc-summary gnu-package-doc-summary) | |
98 | (doc-urls gnu-package-doc-urls) | |
99 | (download-url gnu-package-download-url)) | |
100 | ||
22189ed1 | 101 | (define (official-gnu-packages) |
f9bbf2a8 NK |
102 | "Return a list of records, which are GNU packages." |
103 | (define (group-package-fields port state) | |
104 | ;; Return a list of alists. Each alist contains fields of a GNU | |
105 | ;; package. | |
106 | (let ((line (read-line port)) | |
107 | (field-rx (make-regexp "^([[:graph:]]+): (.*)$")) | |
108 | (doc-urls-rx (make-regexp "^doc-url: (.*)$")) | |
109 | (end-rx (make-regexp "^# End. .+Do not remove this line.+"))) | |
110 | ||
111 | (define (match-field str) | |
112 | ;; Packages are separated by empty strings. If STR is an | |
113 | ;; empty string, create a new list to store fields of a | |
114 | ;; different package. Otherwise, match and create a key-value | |
115 | ;; pair. | |
116 | (match str | |
117 | ("" | |
118 | (group-package-fields port (cons '() state))) | |
119 | (str | |
120 | (cond ((regexp-exec doc-urls-rx str) | |
121 | => | |
122 | (lambda (match) | |
123 | (if (equal? (assoc-ref (first state) "doc-urls") #f) | |
124 | (group-package-fields | |
125 | port (cons (cons (cons "doc-urls" | |
126 | (list | |
127 | (match:substring match 1))) | |
128 | (first state)) | |
129 | (drop state 1))) | |
130 | (group-package-fields | |
131 | port (cons (cons (cons "doc-urls" | |
132 | (cons (match:substring match 1) | |
133 | (assoc-ref (first state) | |
134 | "doc-urls"))) | |
135 | (assoc-remove! (first state) | |
136 | "doc-urls")) | |
137 | (drop state 1)))))) | |
138 | ((regexp-exec field-rx str) | |
139 | => | |
140 | (lambda (match) | |
141 | (group-package-fields | |
142 | port (cons (cons (cons (match:substring match 1) | |
143 | (match:substring match 2)) | |
144 | (first state)) | |
145 | (drop state 1))))) | |
146 | (else (group-package-fields port state)))))) | |
147 | ||
148 | (if (or (eof-object? line) | |
149 | (regexp-exec end-rx line)) ; don't include dummy fields | |
150 | (remove null-list? state) | |
151 | (match-field line)))) | |
152 | ||
153 | (define (alist->record alist make keys) | |
154 | ;; Apply MAKE, which should be a syntactic constructor, to the | |
155 | ;; values associated with KEYS in ALIST. | |
156 | (let ((args (map (cut assoc-ref alist <>) keys))) | |
157 | (apply make args))) | |
158 | ||
159 | (reverse | |
160 | (map (lambda (alist) | |
161 | (alist->record alist | |
162 | make-gnu-package-descriptor | |
163 | (list "package" "mundane-name" "copyright-holder" | |
164 | "savannah" "fsd" "language" "logo" | |
165 | "doc-category" "doc-summary" "doc-urls" | |
166 | "download-url"))) | |
1c9e7d65 | 167 | (group-package-fields (http-fetch %package-list-url #:text? #t) |
f9bbf2a8 | 168 | '(()))))) |
22189ed1 | 169 | |
f9bbf2a8 NK |
170 | (define (find-packages regexp) |
171 | "Find GNU packages which satisfy REGEXP." | |
172 | (let ((name-rx (make-regexp regexp))) | |
173 | (filter (lambda (package) | |
174 | (false-if-exception | |
175 | (regexp-exec name-rx (gnu-package-name package)))) | |
176 | (official-gnu-packages)))) | |
ef010c0f LC |
177 | |
178 | (define gnu-package? | |
179 | (memoize | |
65b96a0c LC |
180 | (let ((official-gnu-packages (memoize official-gnu-packages))) |
181 | (lambda (package) | |
182 | "Return true if PACKAGE is a GNU package. This procedure may access the | |
ef010c0f | 183 | network to check in GNU's database." |
65b96a0c LC |
184 | ;; TODO: Find a way to determine that a package is non-GNU without going |
185 | ;; through the network. | |
186 | (let ((url (and=> (package-source package) origin-uri)) | |
187 | (name (package-name package))) | |
188 | (or (and (string? url) (string-prefix? "mirror://gnu" url)) | |
189 | (and (member name (map gnu-package-name (official-gnu-packages))) | |
190 | #t))))))) | |
ef010c0f | 191 | |
98fefb21 LC |
192 | \f |
193 | ;;; | |
194 | ;;; Latest release. | |
195 | ;;; | |
196 | ||
197 | (define (ftp-server/directory project) | |
198 | "Return the FTP server and directory where PROJECT's tarball are | |
199 | stored." | |
200 | (define quirks | |
201 | '(("commoncpp2" "ftp.gnu.org" "/gnu/commoncpp") | |
202 | ("ucommon" "ftp.gnu.org" "/gnu/commoncpp") | |
203 | ("libzrtpcpp" "ftp.gnu.org" "/gnu/ccrtp") | |
204 | ("libosip2" "ftp.gnu.org" "/gnu/osip") | |
205 | ("libgcrypt" "ftp.gnupg.org" "/gcrypt/libgcrypt") | |
206 | ("libgpg-error" "ftp.gnupg.org" "/gcrypt/libgpg-error") | |
207 | ("libassuan" "ftp.gnupg.org" "/gcrypt/libassuan") | |
208 | ("gnupg" "ftp.gnupg.org" "/gcrypt/gnupg") | |
209 | ("freefont-ttf" "ftp.gnu.org" "/gnu/freefont") | |
210 | ("gnu-ghostscript" "ftp.gnu.org" "/gnu/ghostscript") | |
211 | ("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg") | |
212 | ("icecat" "ftp.gnu.org" "/gnu/gnuzilla") | |
213 | ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite") | |
0fdd3bea | 214 | ("glib" "ftp.gnome.org" "/pub/gnome/sources/glib") |
a4007c98 | 215 | ("gnutls" "ftp.gnutls.org" "/gcrypt/gnutls") |
98fefb21 LC |
216 | ("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz"))) |
217 | ||
218 | (match (assoc project quirks) | |
219 | ((_ server directory) | |
220 | (values server directory)) | |
221 | (_ | |
222 | (values "ftp.gnu.org" (string-append "/gnu/" project))))) | |
223 | ||
cac137aa LC |
224 | (define (sans-extension tarball) |
225 | "Return TARBALL without its .tar.* extension." | |
226 | (let ((end (string-contains tarball ".tar"))) | |
227 | (substring tarball 0 end))) | |
98fefb21 | 228 | |
d55a99fe LC |
229 | (define %tarball-rx |
230 | (make-regexp "^(.+)-([0-9]|[^-])*(-src)?\\.tar\\.")) | |
231 | ||
232 | (define %alpha-tarball-rx | |
233 | (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) | |
234 | ||
cac137aa LC |
235 | (define (release-file project file) |
236 | "Return #f if FILE is not a release tarball of PROJECT, otherwise return | |
237 | PACKAGE-VERSION." | |
238 | (and (not (string-suffix? ".sig" file)) | |
d55a99fe LC |
239 | (and=> (regexp-exec %tarball-rx file) |
240 | (lambda (match) | |
241 | ;; Filter out unrelated files, like `guile-www-1.1.1'. | |
242 | (equal? project (match:substring match 1)))) | |
cac137aa LC |
243 | (not (regexp-exec %alpha-tarball-rx file)) |
244 | (let ((s (sans-extension file))) | |
245 | (and (regexp-exec %package-name-rx s) s)))) | |
6a917ef7 | 246 | |
cac137aa LC |
247 | (define (releases project) |
248 | "Return the list of releases of PROJECT as a list of release name/directory | |
249 | pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). " | |
250 | ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp. | |
98fefb21 LC |
251 | (let-values (((server directory) (ftp-server/directory project))) |
252 | (define conn (ftp-open server)) | |
253 | ||
254 | (let loop ((directories (list directory)) | |
255 | (result '())) | |
6a917ef7 LC |
256 | (match directories |
257 | (() | |
258 | (ftp-close conn) | |
259 | result) | |
260 | ((directory rest ...) | |
261 | (let* ((files (ftp-list conn directory)) | |
262 | (subdirs (filter-map (match-lambda | |
263 | ((name 'directory . _) name) | |
264 | (_ #f)) | |
265 | files))) | |
266 | (loop (append (map (cut string-append directory "/" <>) | |
267 | subdirs) | |
268 | rest) | |
269 | (append | |
270 | ;; Filter out signatures, deltas, and files which | |
271 | ;; are potentially not releases of PROJECT--e.g., | |
272 | ;; in /gnu/guile, filter out guile-oops and | |
273 | ;; guile-www; in mit-scheme, filter out binaries. | |
274 | (filter-map (match-lambda | |
275 | ((file 'file . _) | |
cac137aa | 276 | (and=> (release-file project file) |
6a917ef7 LC |
277 | (cut cons <> directory))) |
278 | (_ #f)) | |
279 | files) | |
280 | result)))))))) | |
98fefb21 | 281 | |
98fefb21 LC |
282 | (define (latest-release project) |
283 | "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f." | |
cac137aa LC |
284 | (define (latest a b) |
285 | (if (version>? a b) a b)) | |
286 | ||
287 | (define contains-digit? | |
288 | (cut string-any char-set:digit <>)) | |
289 | ||
290 | (let-values (((server directory) (ftp-server/directory project))) | |
291 | (define conn (ftp-open server)) | |
292 | ||
293 | (let loop ((directory directory)) | |
294 | (let* ((entries (ftp-list conn directory)) | |
049b2f1d LC |
295 | |
296 | ;; Filter out sub-directories that do not contain digits---e.g., | |
297 | ;; /gnuzilla/lang and /gnupg/patches. | |
cac137aa | 298 | (subdirs (filter-map (match-lambda |
049b2f1d LC |
299 | (((? contains-digit? dir) 'directory . _) |
300 | dir) | |
cac137aa LC |
301 | (_ #f)) |
302 | entries))) | |
303 | (match subdirs | |
304 | (() | |
305 | ;; No sub-directories, so assume that tarballs are here. | |
306 | (let ((files (filter-map (match-lambda | |
307 | ((file 'file . _) | |
308 | (release-file project file)) | |
309 | (_ #f)) | |
310 | entries))) | |
311 | (and=> (reduce latest #f files) | |
312 | (cut cons <> directory)))) | |
313 | ((subdirs ...) | |
314 | ;; Assume that SUBDIRS correspond to versions, and jump into the | |
049b2f1d LC |
315 | ;; one with the highest version number. |
316 | (let ((target (reduce latest #f subdirs))) | |
cac137aa LC |
317 | (and target |
318 | (loop (string-append directory "/" target)))))))))) | |
98fefb21 LC |
319 | |
320 | (define %package-name-rx | |
321 | ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses | |
322 | ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed. | |
323 | (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?")) | |
324 | ||
325 | (define (gnu-package-name->name+version name+version) | |
326 | "Return the package name and version number extracted from NAME+VERSION." | |
327 | (let ((match (regexp-exec %package-name-rx name+version))) | |
328 | (if (not match) | |
329 | (values name+version #f) | |
330 | (values (match:substring match 1) (match:substring match 2))))) | |
331 | ||
0fdd3bea LC |
332 | \f |
333 | ;;; | |
334 | ;;; Auto-update. | |
335 | ;;; | |
336 | ||
337 | (define (package-update-path package) | |
338 | "Return an update path for PACKAGE, or #f if no update is needed." | |
339 | (and (gnu-package? package) | |
340 | (match (latest-release (package-name package)) | |
341 | ((name+version . directory) | |
342 | (let-values (((_ new-version) | |
343 | (package-name->name+version name+version))) | |
344 | (and (version>? name+version (package-full-name package)) | |
345 | `(,new-version . ,directory)))) | |
346 | (_ #f)))) | |
347 | ||
348 | (define* (download-tarball store project directory version | |
349 | #:optional (archive-type "gz")) | |
350 | "Download PROJECT's tarball over FTP and check its OpenPGP signature. On | |
351 | success, return the tarball file name." | |
352 | (let* ((server (ftp-server/directory project)) | |
353 | (base (string-append project "-" version ".tar." archive-type)) | |
354 | (url (string-append "ftp://" server "/" directory "/" base)) | |
355 | (sig-url (string-append url ".sig")) | |
356 | (tarball (download-to-store store url)) | |
357 | (sig (download-to-store store sig-url))) | |
358 | (let ((ret (gnupg-verify* sig tarball))) | |
359 | (if ret | |
360 | tarball | |
361 | (begin | |
dfb43e45 | 362 | (warning (_ "signature verification failed for `~a'~%") |
0fdd3bea | 363 | base) |
dfb43e45 | 364 | (warning (_ "(could be because the public key is not in your keyring)~%")) |
0fdd3bea LC |
365 | #f))))) |
366 | ||
367 | (define (package-update store package) | |
368 | "Return the new version and the file name of the new version tarball for | |
369 | PACKAGE, or #f and #f when PACKAGE is up-to-date." | |
370 | (match (package-update-path package) | |
371 | ((version . directory) | |
372 | (let-values (((name) | |
373 | (package-name package)) | |
374 | ((archive-type) | |
375 | (let ((source (package-source package))) | |
376 | (or (and (origin? source) | |
377 | (file-extension (origin-uri source))) | |
378 | "gz")))) | |
379 | (let ((tarball (download-tarball store name directory version | |
380 | archive-type))) | |
381 | (values version tarball)))) | |
382 | (_ | |
383 | (values #f #f)))) | |
384 | ||
385 | (define (update-package-source package version hash) | |
386 | "Modify the source file that defines PACKAGE to refer to VERSION, | |
387 | whose tarball has SHA256 HASH (a bytevector). Return the new version string | |
388 | if an update was made, and #f otherwise." | |
389 | (define (new-line line matches replacement) | |
390 | ;; Iterate over MATCHES and return the modified line based on LINE. | |
391 | ;; Replace each match with REPLACEMENT. | |
392 | (let loop ((m* matches) ; matches | |
393 | (o 0) ; offset in L | |
394 | (r '())) ; result | |
395 | (match m* | |
396 | (() | |
397 | (let ((r (cons (substring line o) r))) | |
398 | (string-concatenate-reverse r))) | |
399 | ((m . rest) | |
400 | (loop rest | |
401 | (match:end m) | |
402 | (cons* replacement | |
403 | (substring line o (match:start m)) | |
404 | r)))))) | |
405 | ||
406 | (define (update-source file old-version version | |
407 | old-hash hash) | |
408 | ;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION | |
409 | ;; and occurrences of OLD-HASH by HASH (base32 representation thereof). | |
410 | ||
411 | ;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in | |
412 | ;; different unrelated places, we may modify it more than needed, for | |
413 | ;; instance. We should try to make changes only within the sexp that | |
414 | ;; corresponds to the definition of PACKAGE. | |
415 | (let ((old-hash (bytevector->nix-base32-string old-hash)) | |
416 | (hash (bytevector->nix-base32-string hash))) | |
417 | (substitute file | |
418 | `((,(regexp-quote old-version) | |
419 | . ,(cut new-line <> <> version)) | |
420 | (,(regexp-quote old-hash) | |
421 | . ,(cut new-line <> <> hash)))) | |
422 | version)) | |
423 | ||
424 | (let ((name (package-name package)) | |
425 | (loc (package-field-location package 'version))) | |
426 | (if loc | |
427 | (let ((old-version (package-version package)) | |
428 | (old-hash (origin-sha256 (package-source package))) | |
429 | (file (and=> (location-file loc) | |
430 | (cut search-path %load-path <>)))) | |
431 | (if file | |
432 | (update-source file | |
433 | old-version version | |
434 | old-hash hash) | |
435 | (begin | |
436 | (warning (_ "~a: could not locate source file") | |
437 | (location-file loc)) | |
438 | #f))) | |
439 | (begin | |
440 | (format (current-error-port) | |
441 | (_ "~a: ~a: no `version' field in source; skipping~%") | |
c4ca12c1 LC |
442 | (location->string (package-location package)) |
443 | name))))) | |
0fdd3bea | 444 | |
98fefb21 | 445 | ;;; gnu-maintenance.scm ends here |