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