pyrox.dev
1#!/bin/sh
2# This is actually -*- mode: scheme; coding: utf-8; -*- text.
3main='(module-ref (resolve-module '\''(gnupdate)) '\'gnupdate')'
4exec ${GUILE-guile} -L "$PWD" -l "$0" \
5 -c "(apply $main (command-line))" "$@"
6!#
7;;; GNUpdate -- Update GNU packages in Nixpkgs.
8;;; Copyright (C) 2010, 2011 Ludovic Courtès <ludo@gnu.org>
9;;;
10;;; This program is free software: you can redistribute it and/or modify
11;;; it under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation, either version 3 of the License, or
13;;; (at your option) any later version.
14;;;
15;;; This program is distributed in the hope that it will be useful,
16;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
22
23(cond-expand (guile-2 #t)
24 (else (error "GNU Guile 2.0 is required")))
25
26(define-module (gnupdate)
27 #:use-module (sxml ssax)
28 #:use-module (ice-9 popen)
29 #:use-module (ice-9 match)
30 #:use-module (ice-9 rdelim)
31 #:use-module (ice-9 format)
32 #:use-module (ice-9 regex)
33 #:use-module (ice-9 vlist)
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 (srfi srfi-37)
39 #:use-module (system foreign)
40 #:use-module (rnrs bytevectors)
41 #:export (gnupdate))
42
43
44;;;
45;;; SNix.
46;;;
47
48(define-record-type <location>
49 (make-location file line column)
50 location?
51 (file location-file)
52 (line location-line)
53 (column location-column))
54
55(define (->loc line column path)
56 (and line column path
57 (make-location path (string->number line) (string->number column))))
58
59;; Nix object types visible in the XML output of `nix-instantiate' and
60;; mapping to S-expressions (we map to sexps, not records, so that we
61;; can do pattern matching):
62;;
63;; at (at varpat attrspat)
64;; attr (attribute loc name value)
65;; attrs (attribute-set attributes)
66;; attrspat (attribute-set-pattern patterns)
67;; bool #f|#t
68;; derivation (derivation drv-path out-path attributes)
69;; ellipsis '...
70;; expr (snix loc body ...)
71;; function (function loc at|attrspat|varpat)
72;; int int
73;; list list
74;; null 'null
75;; path string
76;; string string
77;; unevaluated 'unevaluated
78;; varpat (varpat name)
79;;
80;; Initially ATTRIBUTES in `derivation' and `attribute-set' was a promise;
81;; however, handling `repeated' nodes makes it impossible to do anything
82;; lazily because the whole SXML tree has to be traversed to maintain the
83;; list of known derivations.
84
85(define (xml-element->snix elem attributes body derivations)
86 ;; Return an SNix element corresponding to XML element ELEM.
87
88 (define (loc)
89 (->loc (assq-ref attributes 'line)
90 (assq-ref attributes 'column)
91 (assq-ref attributes 'path)))
92
93 (case elem
94 ((at)
95 (values `(at ,(car body) ,(cadr body)) derivations))
96 ((attr)
97 (let ((name (assq-ref attributes 'name)))
98 (cond ((null? body)
99 (values `(attribute-pattern ,name) derivations))
100 ((and (pair? body) (null? (cdr body)))
101 (values `(attribute ,(loc) ,name ,(car body))
102 derivations))
103 (else
104 (error "invalid attribute body" name (loc) body)))))
105 ((attrs)
106 (values `(attribute-set ,(reverse body)) derivations))
107 ((attrspat)
108 (values `(attribute-set-pattern ,body) derivations))
109 ((bool)
110 (values (string-ci=? "true" (assq-ref attributes 'value))
111 derivations))
112 ((derivation)
113 (let ((drv-path (assq-ref attributes 'drvPath))
114 (out-path (assq-ref attributes 'outPath)))
115 (if (equal? body '(repeated))
116 (let ((body (vhash-assoc drv-path derivations)))
117 (if (pair? body)
118 (values `(derivation ,drv-path ,out-path ,(cdr body))
119 derivations)
120
121 ;; DRV-PATH hasn't been encountered yet but may be later
122 ;; (see <http://article.gmane.org/gmane.linux.distributions.nixos/5946>.)
123 ;; Return an `unresolved' node.
124 (values `(unresolved
125 ,(lambda (derivations)
126 (let ((body (vhash-assoc drv-path derivations)))
127 (if (pair? body)
128 `(derivation ,drv-path ,out-path
129 ,(cdr body))
130 (error "no previous occurrence of derivation"
131 drv-path)))))
132 derivations)))
133 (values `(derivation ,drv-path ,out-path ,body)
134 (vhash-cons drv-path body derivations)))))
135 ((ellipsis)
136 (values '... derivations))
137 ((expr)
138 (values `(snix ,(loc) ,@body) derivations))
139 ((function)
140 (values `(function ,(loc) ,body) derivations))
141 ((int)
142 (values (string->number (assq-ref attributes 'value))
143 derivations))
144 ((list)
145 (values body derivations))
146 ((null)
147 (values 'null derivations))
148 ((path)
149 (values (assq-ref attributes 'value) derivations))
150 ((repeated)
151 (values 'repeated derivations))
152 ((string)
153 (values (assq-ref attributes 'value) derivations))
154 ((unevaluated)
155 (values 'unevaluated derivations))
156 ((varpat)
157 (values `(varpat ,(assq-ref attributes 'name)) derivations))
158 (else (error "unhandled Nix XML element" elem))))
159
160(define (resolve snix derivations)
161 "Return a new SNix tree where `unresolved' nodes from SNIX have been
162replaced by the result of their application to DERIVATIONS, a vhash."
163 (let loop ((node snix)
164 (seen vlist-null))
165 (if (vhash-assq node seen)
166 (values node seen)
167 (match node
168 (('unresolved proc)
169 (let ((n (proc derivations)))
170 (values n seen)))
171 ((tag body ...)
172 (let ((body+seen (fold (lambda (n body+seen)
173 (call-with-values
174 (lambda ()
175 (loop n (cdr body+seen)))
176 (lambda (n* seen)
177 (cons (cons n* (car body+seen))
178 (vhash-consq n #t seen)))))
179 (cons '() (vhash-consq node #t seen))
180 body)))
181 (values (cons tag (reverse (car body+seen)))
182 (vhash-consq node #t (cdr body+seen)))))
183 (anything
184 (values anything seen))))))
185
186(define xml->snix
187 ;; Return the SNix represention of TREE, an SXML tree as returned by
188 ;; parsing the XML output of `nix-instantiate' on Nixpkgs.
189 (let ((parse
190 (ssax:make-parser NEW-LEVEL-SEED
191 (lambda (elem-gi attributes namespaces expected-content
192 seed)
193 (cons '() (cdr seed)))
194
195 FINISH-ELEMENT
196 (lambda (elem-gi attributes namespaces parent-seed
197 seed)
198 (let ((snix (car seed))
199 (derivations (cdr seed)))
200 (let-values (((snix derivations)
201 (xml-element->snix elem-gi
202 attributes
203 snix
204 derivations)))
205 (cons (cons snix (car parent-seed))
206 derivations))))
207
208 CHAR-DATA-HANDLER
209 (lambda (string1 string2 seed)
210 ;; Discard inter-node strings, which are blanks.
211 seed))))
212 (lambda (port)
213 (match (parse port (cons '() vlist-null))
214 (((snix) . derivations)
215 (resolve snix derivations))))))
216
217(define (call-with-package snix proc)
218 (match snix
219 (('attribute _ (and attribute-name (? string?))
220 ('derivation _ _ body))
221 ;; Ugly pattern matching.
222 (let ((meta
223 (any (lambda (attr)
224 (match attr
225 (('attribute _ "meta" ('attribute-set metas)) metas)
226 (_ #f)))
227 body))
228 (package-name
229 (any (lambda (attr)
230 (match attr
231 (('attribute _ "name" (and name (? string?)))
232 name)
233 (_ #f)))
234 body))
235 (location
236 (any (lambda (attr)
237 (match attr
238 (('attribute loc "name" (? string?))
239 loc)
240 (_ #f)))
241 body))
242 (src
243 (any (lambda (attr)
244 (match attr
245 (('attribute _ "src" src)
246 src)
247 (_ #f)))
248 body)))
249 (proc attribute-name package-name location meta src)))))
250
251(define (call-with-src snix proc)
252 ;; Assume SNIX contains the SNix expression for the value of an `src'
253 ;; attribute, as returned by `call-with-package', and call PROC with the
254 ;; relevant SRC information, or #f if SNIX doesn't match.
255 (match snix
256 (('derivation _ _ body)
257 (let ((name
258 (any (lambda (attr)
259 (match attr
260 (('attribute _ "name" (and name (? string?)))
261 name)
262 (_ #f)))
263 body))
264 (output-hash
265 (any (lambda (attr)
266 (match attr
267 (('attribute _ "outputHash" (and hash (? string?)))
268 hash)
269 (_ #f)))
270 body))
271 (urls
272 (any (lambda (attr)
273 (match attr
274 (('attribute _ "urls" (and urls (? pair?)))
275 urls)
276 (_ #f)))
277 body)))
278 (proc name output-hash urls)))
279 (_ (proc #f #f #f))))
280
281(define (src->values snix)
282 (call-with-src snix values))
283
284(define (attribute-value attribute)
285 ;; Return the value of ATTRIBUTE.
286 (match attribute
287 (('attribute _ _ value) value)))
288
289(define (derivation-source derivation)
290 ;; Return the "src" attribute of DERIVATION or #f if not found.
291 (match derivation
292 (('derivation _ _ (attributes ...))
293 (find-attribute-by-name "src" attributes))))
294
295(define (derivation-output-path derivation)
296 ;; Return the output path of DERIVATION.
297 (match derivation
298 (('derivation _ out-path _)
299 out-path)
300 (_ #f)))
301
302(define (source-output-path src)
303 ;; Return the output path of SRC, the "src" attribute of a derivation.
304 (derivation-output-path (attribute-value src)))
305
306(define (derivation-source-output-path derivation)
307 ;; Return the output path of the "src" attribute of DERIVATION or #f if
308 ;; DERIVATION lacks an "src" attribute.
309 (and=> (derivation-source derivation) source-output-path))
310
311(define* (open-nixpkgs nixpkgs #:optional attribute)
312 ;; Return an input pipe to the XML representation of Nixpkgs. When
313 ;; ATTRIBUTE is true, only that attribute is considered.
314 (let ((script (string-append nixpkgs
315 "/maintainers/scripts/eval-release.nix")))
316 (apply open-pipe* OPEN_READ
317 "nix-instantiate" "--strict" "--eval-only" "--xml"
318 `(,@(if attribute
319 `("-A" ,attribute)
320 '())
321 ,script))))
322
323(define (pipe-failed? pipe)
324 "Close pipe and return its status if it failed."
325 (let ((status (close-pipe pipe)))
326 (if (or (status:term-sig status)
327 (not (= (status:exit-val status) 0)))
328 status
329 #f)))
330
331(define (memoize proc)
332 "Return a memoizing version of PROC."
333 (let ((cache (make-hash-table)))
334 (lambda args
335 (let ((results (hash-ref cache args)))
336 (if results
337 (apply values results)
338 (let ((results (call-with-values (lambda ()
339 (apply proc args))
340 list)))
341 (hash-set! cache args results)
342 (apply values results)))))))
343
344(define nix-prefetch-url
345 (memoize
346 (lambda (url)
347 "Download URL in the Nix store and return the base32-encoded SHA256 hash of
348the file at URL."
349 (let* ((pipe (open-pipe* OPEN_READ "nix-prefetch-url" url))
350 (hash (read-line pipe)))
351 (if (or (pipe-failed? pipe)
352 (eof-object? hash))
353 (values #f #f)
354 (let* ((pipe (open-pipe* OPEN_READ "nix-store" "--print-fixed-path"
355 "sha256" hash (basename url)))
356 (path (read-line pipe)))
357 (if (or (pipe-failed? pipe)
358 (eof-object? path))
359 (values #f #f)
360 (values (string-trim-both hash) (string-trim-both path)))))))))
361
362(define (update-nix-expression file
363 old-version old-hash
364 new-version new-hash)
365 ;; Modify FILE in-place. Ugly: we call out to sed(1).
366 (let ((cmd (format #f "sed -i \"~a\" -e 's/~A/~a/g ; s/~A/~A/g'"
367 file
368 (regexp-quote old-version) new-version
369 old-hash
370 (or new-hash "new hash not available, check the log"))))
371 (format #t "running `~A'...~%" cmd)
372 (system cmd)))
373
374(define (find-attribute-by-name name attributes)
375 ;; Return attribute NAME in ATTRIBUTES, a list of SNix attributes, or #f if
376 ;; NAME cannot be found.
377 (find (lambda (a)
378 (match a
379 (('attribute _ (? (cut string=? <> name)) _)
380 a)
381 (_ #f)))
382 attributes))
383
384(define (find-package-by-attribute-name name packages)
385 ;; Return the package bound to attribute NAME in PACKAGES, a list of
386 ;; packages (SNix attributes), or #f if NAME cannot be found.
387 (find (lambda (package)
388 (match package
389 (('attribute _ (? (cut string=? <> name))
390 ('derivation _ _ _))
391 package)
392 (_ #f)))
393 packages))
394
395(define (stdenv-package packages)
396 ;; Return the `stdenv' package from PACKAGES, a list of SNix attributes.
397 (find-package-by-attribute-name "stdenv" packages))
398
399(define (package-requisites package)
400 ;; Return the list of derivations required to build PACKAGE (including that
401 ;; of PACKAGE) by recurring into its derivation attributes.
402 (let loop ((snix package)
403 (result '()))
404 (match snix
405 (('attribute _ _ body)
406 (loop body result))
407 (('derivation _ out-path body)
408 (if (any (lambda (d)
409 (match d
410 (('derivation _ (? (cut string=? out-path <>)) _) #t)
411 (_ #f)))
412 result)
413 result
414 (loop body (cons snix result))))
415 ((things ...)
416 (fold loop result things))
417 (_ result))))
418
419(define (package-source-output-path package)
420 ;; Return the output path of the "src" derivation of PACKAGE.
421 (derivation-source-output-path (attribute-value package)))
422
423
424;;;
425;;; GnuPG interface.
426;;;
427
428(define %gpg-command "gpg2")
429(define %openpgp-key-server "keys.gnupg.net")
430
431(define (gnupg-verify sig file)
432 "Verify signature SIG for FILE. Return a status s-exp if GnuPG failed."
433
434 (define (status-line->sexp line)
435 ;; See file `doc/DETAILS' in GnuPG.
436 (define sigid-rx
437 (make-regexp
438 "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
439 (define goodsig-rx
440 (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
441 (define validsig-rx
442 (make-regexp
443 "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
444 (define expkeysig-rx ; good signature, but expired key
445 (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
446 (define errsig-rx
447 (make-regexp
448 "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)"))
449
450 (cond ((regexp-exec sigid-rx line)
451 =>
452 (lambda (match)
453 `(signature-id ,(match:substring match 1) ; sig id
454 ,(match:substring match 2) ; date
455 ,(string->number ; timestamp
456 (match:substring match 3)))))
457 ((regexp-exec goodsig-rx line)
458 =>
459 (lambda (match)
460 `(good-signature ,(match:substring match 1) ; key id
461 ,(match:substring match 2)))) ; user name
462 ((regexp-exec validsig-rx line)
463 =>
464 (lambda (match)
465 `(valid-signature ,(match:substring match 1) ; fingerprint
466 ,(match:substring match 2) ; sig creation date
467 ,(string->number ; timestamp
468 (match:substring match 3)))))
469 ((regexp-exec expkeysig-rx line)
470 =>
471 (lambda (match)
472 `(expired-key-signature ,(match:substring match 1) ; fingerprint
473 ,(match:substring match 2)))) ; user name
474 ((regexp-exec errsig-rx line)
475 =>
476 (lambda (match)
477 `(signature-error ,(match:substring match 1) ; key id or fingerprint
478 ,(match:substring match 2) ; pubkey algo
479 ,(match:substring match 3) ; hash algo
480 ,(match:substring match 4) ; sig class
481 ,(string->number ; timestamp
482 (match:substring match 5))
483 ,(let ((rc
484 (string->number ; return code
485 (match:substring match 6))))
486 (case rc
487 ((9) 'missing-key)
488 ((4) 'unknown-algorithm)
489 (else rc))))))
490 (else
491 `(unparsed-line ,line))))
492
493 (define (parse-status input)
494 (let loop ((line (read-line input))
495 (result '()))
496 (if (eof-object? line)
497 (reverse result)
498 (loop (read-line input)
499 (cons (status-line->sexp line) result)))))
500
501 (let* ((pipe (open-pipe* OPEN_READ %gpg-command "--status-fd=1"
502 "--verify" sig file))
503 (status (parse-status pipe)))
504 ;; Ignore PIPE's exit status since STATUS above should contain all the
505 ;; info we need.
506 (close-pipe pipe)
507 status))
508
509(define (gnupg-status-good-signature? status)
510 "If STATUS, as returned by `gnupg-verify', denotes a good signature, return
511a key-id/user pair; return #f otherwise."
512 (any (lambda (sexp)
513 (match sexp
514 (((or 'good-signature 'expired-key-signature) key-id user)
515 (cons key-id user))
516 (_ #f)))
517 status))
518
519(define (gnupg-status-missing-key? status)
520 "If STATUS denotes a missing-key error, then return the key-id of the
521missing key."
522 (any (lambda (sexp)
523 (match sexp
524 (('signature-error key-id _ ...)
525 key-id)
526 (_ #f)))
527 status))
528
529(define (gnupg-receive-keys key-id)
530 (system* %gpg-command "--keyserver" %openpgp-key-server "--recv-keys" key-id))
531
532(define (gnupg-verify* sig file)
533 "Like `gnupg-verify', but try downloading the public key if it's missing.
534Return #t if the signature was good, #f otherwise."
535 (let ((status (gnupg-verify sig file)))
536 (or (gnupg-status-good-signature? status)
537 (let ((missing (gnupg-status-missing-key? status)))
538 (and missing
539 (begin
540 ;; Download the missing key and try again.
541 (gnupg-receive-keys missing)
542 (gnupg-status-good-signature? (gnupg-verify sig file))))))))
543
544
545;;;
546;;; FTP client.
547;;;
548
549(define-record-type <ftp-connection>
550 (%make-ftp-connection socket addrinfo)
551 ftp-connection?
552 (socket ftp-connection-socket)
553 (addrinfo ftp-connection-addrinfo))
554
555(define %ftp-ready-rx
556 (make-regexp "^([0-9]{3}) (.+)$"))
557
558(define (%ftp-listen port)
559 (let loop ((line (read-line port)))
560 (cond ((eof-object? line) (values line #f))
561 ((regexp-exec %ftp-ready-rx line)
562 =>
563 (lambda (match)
564 (values (string->number (match:substring match 1))
565 (match:substring match 2))))
566 (else
567 (loop (read-line port))))))
568
569(define (%ftp-command command expected-code port)
570 (format port "~A~A~A" command (string #\return) (string #\newline))
571 (let-values (((code message) (%ftp-listen port)))
572 (if (eqv? code expected-code)
573 message
574 (throw 'ftp-error port command code message))))
575
576(define (%ftp-login user pass port)
577 (let ((command (string-append "USER " user (string #\newline))))
578 (display command port)
579 (let-values (((code message) (%ftp-listen port)))
580 (case code
581 ((230) #t)
582 ((331) (%ftp-command (string-append "PASS " pass) 230 port))
583 (else (throw 'ftp-error port command code message))))))
584
585(define (ftp-open host)
586 (catch 'getaddrinfo-error
587 (lambda ()
588 (let* ((ai (car (getaddrinfo host "ftp")))
589 (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
590 (addrinfo:protocol ai))))
591 (connect s (addrinfo:addr ai))
592 (setvbuf s _IOLBF)
593 (let-values (((code message) (%ftp-listen s)))
594 (if (eqv? code 220)
595 (begin
596 ;(%ftp-command "OPTS UTF8 ON" 200 s)
597 (%ftp-login "anonymous" "ludo@example.com" s)
598 (%make-ftp-connection s ai))
599 (begin
600 (format (current-error-port) "FTP to `~a' failed: ~A: ~A~%"
601 host code message)
602 (close s)
603 #f)))))
604 (lambda (key errcode)
605 (format (current-error-port) "failed to resolve `~a': ~a~%"
606 host (gai-strerror errcode))
607 #f)))
608
609(define (ftp-close conn)
610 (close (ftp-connection-socket conn)))
611
612(define (ftp-chdir conn dir)
613 (%ftp-command (string-append "CWD " dir) 250
614 (ftp-connection-socket conn)))
615
616(define (ftp-pasv conn)
617 (define %pasv-rx
618 (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)"))
619
620 (let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn))))
621 (cond ((regexp-exec %pasv-rx message)
622 =>
623 (lambda (match)
624 (+ (* (string->number (match:substring match 5)) 256)
625 (string->number (match:substring match 6)))))
626 (else
627 (throw 'ftp-error conn "PASV" 227 message)))))
628
629
630(define* (ftp-list conn #:optional directory)
631 (define (address-with-port sa port)
632 (let ((fam (sockaddr:fam sa))
633 (addr (sockaddr:addr sa)))
634 (cond ((= fam AF_INET)
635 (make-socket-address fam addr port))
636 ((= fam AF_INET6)
637 (make-socket-address fam addr port
638 (sockaddr:flowinfo sa)
639 (sockaddr:scopeid sa)))
640 (else #f))))
641
642 (if directory
643 (ftp-chdir conn directory))
644
645 (let* ((port (ftp-pasv conn))
646 (ai (ftp-connection-addrinfo conn))
647 (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
648 (addrinfo:protocol ai))))
649 (connect s (address-with-port (addrinfo:addr ai) port))
650 (setvbuf s _IOLBF)
651
652 (dynamic-wind
653 (lambda () #t)
654 (lambda ()
655 (%ftp-command "LIST" 150 (ftp-connection-socket conn))
656
657 (let loop ((line (read-line s))
658 (result '()))
659 (cond ((eof-object? line) (reverse result))
660 ((regexp-exec %ftp-ready-rx line)
661 =>
662 (lambda (match)
663 (let ((code (string->number (match:substring match 1))))
664 (if (= 126 code)
665 (reverse result)
666 (throw 'ftp-error conn "LIST" code)))))
667 (else
668 (loop (read-line s)
669 (match (reverse (string-tokenize line))
670 ((file _ ... permissions)
671 (let ((type (case (string-ref permissions 0)
672 ((#\d) 'directory)
673 (else 'file))))
674 (cons (list file type) result)))
675 ((file _ ...)
676 (cons (cons file 'file) result))))))))
677 (lambda ()
678 (close s)
679 (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
680 (or (eqv? code 226)
681 (throw 'ftp-error conn "LIST" code message)))))))
682
683
684;;;
685;;; GNU.
686;;;
687
688(define %ignored-package-attributes
689 ;; Attribute name of packages to be ignored.
690 '("bash" "bashReal" "bashInteractive" ;; the full versioned name is incorrect
691 "autoconf213"
692 "automake17x"
693 "automake19x"
694 "automake110x"
695 "bison1875"
696 "bison23"
697 "bison24"
698 "bison" ;; = 2.4
699 "ccrtp_1_8"
700 "emacs22"
701 "emacsSnapshot"
702 "gcc295"
703 "gcc33"
704 "gcc34"
705 "gcc40"
706 "gcc41"
707 "gcc42"
708 "gcc43"
709 "gcc44"
710 "gcc45"
711 "gcc45_real"
712 "gcc45_realCross"
713 "gfortran45"
714 "gcj45"
715 "gcc46"
716 "gcc46_real"
717 "gcc46_realCross"
718 "gfortran46"
719 "gcj46"
720 "glibc25"
721 "glibc27"
722 "glibc29"
723 "guile_1_8"
724 "icecat3"
725 "icecat3Xul" ;; redundant with `icecat'
726 "icecatWrapper"
727 "icecat3Wrapper"
728 "icecatXulrunner3"
729 "libzrtpcpp_1_6"
730 "parted_2_3"
731 ))
732
733(define (gnu? package)
734 ;; Return true if PACKAGE (a snix expression) is a GNU package (according
735 ;; to a simple heuristic.) Otherwise return #f.
736 (match package
737 (('attribute _ _ ('derivation _ _ body))
738 (any (lambda (attr)
739 (match attr
740 (('attribute _ "meta" ('attribute-set metas))
741 (any (lambda (attr)
742 (match attr
743 (('attribute _ "description" value)
744 (string-prefix? "GNU" value))
745 (('attribute _ "homepage" (? string? value))
746 (or (string-contains value "gnu.org")
747 (string-contains value "gnupg.org")))
748 (('attribute _ "homepage" ((? string? value) ...))
749 (any (cut string-contains <> "www.gnu.org") value))
750 (_ #f)))
751 metas))
752 (_ #f)))
753 body))
754 (_ #f)))
755
756(define (gnu-packages packages)
757 (fold (lambda (package gnu)
758 (match package
759 (('attribute _ "emacs23Packages" emacs-packages)
760 ;; XXX: Should prepend `emacs23Packages.' to attribute names.
761 (append (gnu-packages emacs-packages) gnu))
762 (('attribute _ attribute-name ('derivation _ _ body))
763 (if (member attribute-name %ignored-package-attributes)
764 gnu
765 (if (gnu? package)
766 (cons package gnu)
767 gnu)))
768 (_ gnu)))
769 '()
770 packages))
771
772(define (ftp-server/directory project)
773 (define quirks
774 '(("commoncpp2" "ftp.gnu.org" "/gnu/commoncpp" #f)
775 ("ucommon" "ftp.gnu.org" "/gnu/commoncpp" #f)
776 ("libzrtpcpp" "ftp.gnu.org" "/gnu/ccrtp" #f)
777 ("libosip2" "ftp.gnu.org" "/gnu/osip" #f)
778 ("libgcrypt" "ftp.gnupg.org" "/gcrypt" #t)
779 ("libgpg-error" "ftp.gnupg.org" "/gcrypt" #t)
780 ("libassuan" "ftp.gnupg.org" "/gcrypt" #t)
781 ("freefont-ttf" "ftp.gnu.org" "/gnu/freefont" #f)
782 ("gnupg" "ftp.gnupg.org" "/gcrypt" #t)
783 ("gnu-ghostscript" "ftp.gnu.org" "/gnu/ghostscript" #f)
784 ("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg" #f)
785 ("icecat" "ftp.gnu.org" "/gnu/gnuzilla" #f)
786 ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite" #f)
787 ("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz" #f)))
788
789 (let ((quirk (assoc project quirks)))
790 (match quirk
791 ((_ server directory subdir?)
792 (values server (if (not subdir?)
793 directory
794 (string-append directory "/" project))))
795 (_
796 (values "ftp.gnu.org" (string-append "/gnu/" project))))))
797
798(define (nixpkgs->gnu-name project)
799 (define quirks
800 '(("gcc-wrapper" . "gcc")
801 ("ghostscript" . "gnu-ghostscript") ;; ../ghostscript/gnu-ghoscript-X.Y.tar.gz
802 ("gnum4" . "m4")
803 ("gnugrep" . "grep")
804 ("gnumake" . "make")
805 ("gnused" . "sed")
806 ("gnutar" . "tar")
807 ("mitscheme" . "mit-scheme")
808 ("texmacs" . "TeXmacs")))
809
810 (or (assoc-ref quirks project) project))
811
812(define (releases project)
813 "Return the list of releases of PROJECT as a list of release name/directory
814pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). "
815 ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
816 (define release-rx
817 (make-regexp (string-append "^" project
818 "-([0-9]|[^-])*(-src)?\\.tar\\.")))
819
820 (define alpha-rx
821 (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
822
823 (define (sans-extension tarball)
824 (let ((end (string-contains tarball ".tar")))
825 (substring tarball 0 end)))
826
827 (catch 'ftp-error
828 (lambda ()
829 (let-values (((server directory) (ftp-server/directory project)))
830 (define conn (ftp-open server))
831
832 (let loop ((directories (list directory))
833 (result '()))
834 (if (null? directories)
835 (begin
836 (ftp-close conn)
837 result)
838 (let* ((directory (car directories))
839 (files (ftp-list conn directory))
840 (subdirs (filter-map (lambda (file)
841 (match file
842 ((name 'directory . _) name)
843 (_ #f)))
844 files)))
845 (loop (append (map (cut string-append directory "/" <>)
846 subdirs)
847 (cdr directories))
848 (append
849 ;; Filter out signatures, deltas, and files which are potentially
850 ;; not releases of PROJECT (e.g., in /gnu/guile, filter out
851 ;; guile-oops and guile-www; in mit-scheme, filter out
852 ;; binaries).
853 (filter-map (lambda (file)
854 (match file
855 ((file 'file . _)
856 (and (not (string-suffix? ".sig" file))
857 (regexp-exec release-rx file)
858 (not (regexp-exec alpha-rx file))
859 (let ((s (sans-extension file)))
860 (and (regexp-exec
861 %package-name-rx s)
862 (cons s directory)))))
863 (_ #f)))
864 files)
865 result)))))))
866 (lambda (key subr message . args)
867 (format (current-error-port)
868 "failed to get release list for `~A': ~S ~S~%"
869 project message args)
870 '())))
871
872(define version-string>?
873 (let ((strverscmp
874 (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
875 (error "could not find `strverscmp' (from GNU libc)"))))
876 (pointer->procedure int sym (list '* '*)))))
877 (lambda (a b)
878 (> (strverscmp (string->pointer a) (string->pointer b)) 0))))
879
880(define (latest-release project)
881 "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f."
882 (let ((releases (releases project)))
883 (and (not (null? releases))
884 (fold (lambda (release latest)
885 (if (version-string>? (car release) (car latest))
886 release
887 latest))
888 '("" . "")
889 releases))))
890
891(define %package-name-rx
892 ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
893 ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
894 (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
895
896(define (package/version name+version)
897 "Return the package name and version number extracted from NAME+VERSION."
898 (let ((match (regexp-exec %package-name-rx name+version)))
899 (if (not match)
900 (values name+version #f)
901 (values (match:substring match 1) (match:substring match 2)))))
902
903(define (file-extension file)
904 (let ((dot (string-rindex file #\.)))
905 (and dot (substring file (+ 1 dot) (string-length file)))))
906
907(define (packages-to-update gnu-packages)
908 (define (unpack latest)
909 (call-with-values (lambda ()
910 (package/version (car latest)))
911 (lambda (name version)
912 (list name version (cdr latest)))))
913
914 (fold (lambda (pkg result)
915 (call-with-package pkg
916 (lambda (attribute name+version location meta src)
917 (let-values (((name old-version)
918 (package/version name+version)))
919 (let ((latest (latest-release (nixpkgs->gnu-name name))))
920 (if (not latest)
921 (begin
922 (format #t "~A [unknown latest version]~%"
923 name+version)
924 result)
925 (match (unpack latest)
926 ((_ (? (cut string=? old-version <>)) _)
927 (format #t "~A [up to date]~%" name+version)
928 result)
929 ((project new-version directory)
930 (let-values (((old-name old-hash old-urls)
931 (src->values src)))
932 (format #t "~A -> ~A [~A]~%"
933 name+version (car latest)
934 (and (pair? old-urls) (car old-urls)))
935 (let* ((url (and (pair? old-urls)
936 (car old-urls)))
937 (new-hash (fetch-gnu project directory
938 new-version
939 (if url
940 (file-extension url)
941 "gz"))))
942 (cons (list name attribute
943 old-version old-hash
944 new-version new-hash
945 location)
946 result)))))))))))
947 '()
948 gnu-packages))
949
950(define (fetch-gnu project directory version archive-type)
951 "Download PROJECT's tarball over FTP."
952 (let* ((server (ftp-server/directory project))
953 (base (string-append project "-" version ".tar." archive-type))
954 (url (string-append "ftp://" server "/" directory "/" base))
955 (sig (string-append base ".sig"))
956 (sig-url (string-append url ".sig")))
957 (let-values (((hash path) (nix-prefetch-url url)))
958 (pk 'prefetch-url url hash path)
959 (and hash path
960 (begin
961 (false-if-exception (delete-file sig))
962 (system* "wget" sig-url)
963 (if (file-exists? sig)
964 (let ((ret (gnupg-verify* sig path)))
965 (false-if-exception (delete-file sig))
966 (if ret
967 hash
968 (begin
969 (format (current-error-port)
970 "signature verification failed for `~a'~%"
971 base)
972 (format (current-error-port)
973 "(could be because the public key is not in your keyring)~%")
974 #f)))
975 (begin
976 (format (current-error-port)
977 "no signature for `~a'~%" base)
978 hash)))))))
979
980
981;;;
982;;; Main program.
983;;;
984
985(define %options
986 ;; Specifications of the command-line options.
987 (list (option '(#\h "help") #f #f
988 (lambda (opt name arg result)
989 (format #t "Usage: gnupdate [OPTIONS...]~%")
990 (format #t "GNUpdate -- update Nix expressions of GNU packages in Nixpkgs~%")
991 (format #t "~%")
992 (format #t " -x, --xml=FILE Read XML output of `nix-instantiate'~%")
993 (format #t " from FILE.~%")
994 (format #t " -A, --attribute=ATTR~%")
995 (format #t " Update only the package pointed to by attribute~%")
996 (format #t " ATTR.~%")
997 (format #t " -s, --select=SET Update only packages from SET, which may~%")
998 (format #t " be either `all', `stdenv', or `non-stdenv'.~%")
999 (format #t " -d, --dry-run Don't actually update Nix expressions~%")
1000 (format #t " -h, --help Give this help list.~%~%")
1001 (format #t "Report bugs to <ludo@gnu.org>~%")
1002 (exit 0)))
1003 (option '(#\A "attribute") #t #f
1004 (lambda (opt name arg result)
1005 (alist-cons 'attribute arg result)))
1006 (option '(#\s "select") #t #f
1007 (lambda (opt name arg result)
1008 (cond ((string-ci=? arg "stdenv")
1009 (alist-cons 'filter 'stdenv result))
1010 ((string-ci=? arg "non-stdenv")
1011 (alist-cons 'filter 'non-stdenv result))
1012 ((string-ci=? arg "all")
1013 (alist-cons 'filter #f result))
1014 (else
1015 (format (current-error-port)
1016 "~A: unrecognized selection type~%"
1017 arg)
1018 (exit 1)))))
1019
1020 (option '(#\d "dry-run") #f #f
1021 (lambda (opt name arg result)
1022 (alist-cons 'dry-run #t result)))
1023
1024 (option '(#\x "xml") #t #f
1025 (lambda (opt name arg result)
1026 (alist-cons 'xml-file arg result)))))
1027
1028(define (gnupdate . args)
1029 ;; Assume Nixpkgs is under $NIXPKGS or ~/src/nixpkgs.
1030
1031 (define (nixpkgs->snix xml-file attribute)
1032 (format (current-error-port) "evaluating Nixpkgs...~%")
1033 (let* ((home (getenv "HOME"))
1034 (xml (if xml-file
1035 (open-input-file xml-file)
1036 (open-nixpkgs (or (getenv "NIXPKGS")
1037 (string-append home "/src/nixpkgs"))
1038 attribute)))
1039 (snix (xml->snix xml)))
1040 (if (not xml-file)
1041 (let ((status (pipe-failed? xml)))
1042 (if status
1043 (begin
1044 (format (current-error-port) "`nix-instantiate' failed: ~A~%"
1045 status)
1046 (exit 1)))))
1047
1048 ;; If we asked for a specific attribute, rewrap the thing in an
1049 ;; attribute set to match the expectations of `packages-to-update' & co.
1050 (if attribute
1051 (match snix
1052 (('snix loc ('derivation args ...))
1053 `(snix ,loc
1054 (attribute-set
1055 ((attribute #f ,attribute
1056 (derivation ,@args)))))))
1057 snix)))
1058
1059 (define (selected-gnu-packages packages stdenv selection)
1060 ;; Return the subset of PACKAGES that are/aren't in STDENV, according to
1061 ;; SELECTION. To do that reliably, we check whether their "src"
1062 ;; derivation is a requisite of STDENV.
1063 (define gnu
1064 (gnu-packages packages))
1065
1066 (case selection
1067 ((stdenv)
1068 (filter (lambda (p)
1069 (member (package-source-output-path p)
1070 (force stdenv)))
1071 gnu))
1072 ((non-stdenv)
1073 (filter (lambda (p)
1074 (not (member (package-source-output-path p)
1075 (force stdenv))))
1076 gnu))
1077 (else gnu)))
1078
1079 (let* ((opts (args-fold (cdr args) %options
1080 (lambda (opt name arg result)
1081 (error "unrecognized option `~A'" name))
1082 (lambda (operand result)
1083 (error "extraneous argument `~A'" operand))
1084 '()))
1085 (snix (nixpkgs->snix (assq-ref opts 'xml-file)
1086 (assq-ref opts 'attribute)))
1087 (packages (match snix
1088 (('snix _ ('attribute-set attributes))
1089 attributes)
1090 (_ #f)))
1091 (stdenv (delay
1092 ;; The source tarballs that make up stdenv.
1093 (filter-map derivation-source-output-path
1094 (package-requisites (stdenv-package packages)))))
1095 (attribute (assq-ref opts 'attribute))
1096 (selection (assq-ref opts 'filter))
1097 (to-update (if attribute
1098 packages ; already a subset
1099 (selected-gnu-packages packages stdenv selection)))
1100 (updates (packages-to-update to-update)))
1101
1102 (format #t "~%~A packages to update...~%" (length updates))
1103 (for-each (lambda (update)
1104 (match update
1105 ((name attribute
1106 old-version old-hash
1107 new-version new-hash
1108 location)
1109 (if (assoc-ref opts 'dry-run)
1110 (format #t "`~a' would be updated from ~a to ~a (~a -> ~a)~%"
1111 name old-version new-version
1112 old-hash new-hash)
1113 (update-nix-expression (location-file location)
1114 old-version old-hash
1115 new-version new-hash)))
1116 (_ #f)))
1117 updates)
1118 #t))
1119
1120;;; Local Variables:
1121;;; eval: (put 'call-with-package 'scheme-indent-function 1)
1122;;; End: