diff options
Diffstat (limited to 'maintainers/scripts/gnu/gnupdate')
| -rwxr-xr-x | maintainers/scripts/gnu/gnupdate | 319 |
1 files changed, 220 insertions, 99 deletions
diff --git a/maintainers/scripts/gnu/gnupdate b/maintainers/scripts/gnu/gnupdate index d830b3ab26c2..6e89542ec575 100755 --- a/maintainers/scripts/gnu/gnupdate +++ b/maintainers/scripts/gnu/gnupdate @@ -5,7 +5,7 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ -c "(apply $main (command-line))" "$@" !# ;;; GNUpdate -- Update GNU packages in Nixpkgs. -;;; Copyright (C) 2010 Ludovic Courtès <ludo@gnu.org> +;;; Copyright (C) 2010, 2011 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This program is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -28,6 +28,7 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ #:use-module (ice-9 popen) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:use-module (ice-9 format) #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) @@ -116,8 +117,19 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ (if (pair? body) (values `(derivation ,drv-path ,out-path ,(cdr body)) derivations) - (error "no previous occurrence of derivation" - drv-path))) + + ;; DRV-PATH hasn't been encountered yet but may be later + ;; (see <http://article.gmane.org/gmane.linux.distributions.nixos/5946>.) + ;; Return an `unresolved' node. + (values `(unresolved + ,(lambda (derivations) + (let ((body (vhash-assoc drv-path derivations))) + (if (pair? body) + `(derivation ,drv-path ,out-path + ,(cdr body)) + (error "no previous occurrence of derivation" + drv-path))))) + derivations))) (values `(derivation ,drv-path ,out-path ,body) (vhash-cons drv-path body derivations))))) ((ellipsis) @@ -145,6 +157,32 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ (values `(varpat ,(assq-ref attributes 'name)) derivations)) (else (error "unhandled Nix XML element" elem)))) +(define (resolve snix derivations) + "Return a new SNix tree where `unresolved' nodes from SNIX have been +replaced by the result of their application to DERIVATIONS, a vhash." + (let loop ((node snix) + (seen vlist-null)) + (if (vhash-assq node seen) + (values node seen) + (match node + (('unresolved proc) + (let ((n (proc derivations))) + (values n seen))) + ((tag body ...) + (let ((body+seen (fold (lambda (n body+seen) + (call-with-values + (lambda () + (loop n (cdr body+seen))) + (lambda (n* seen) + (cons (cons n* (car body+seen)) + (vhash-consq n #t seen))))) + (cons '() (vhash-consq node #t seen)) + body))) + (values (cons tag (reverse (car body+seen))) + (vhash-consq node #t (cdr body+seen))))) + (anything + (values anything seen)))))) + (define xml->snix ;; Return the SNix represention of TREE, an SXML tree as returned by ;; parsing the XML output of `nix-instantiate' on Nixpkgs. @@ -172,9 +210,9 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ ;; Discard inter-node strings, which are blanks. seed)))) (lambda (port) - ;; Discard the second value returned by the parser (the derivation - ;; vhash). - (caar (parse port (cons '() vlist-null)))))) + (match (parse port (cons '() vlist-null)) + (((snix) . derivations) + (resolve snix derivations)))))) (define (call-with-package snix proc) (match snix @@ -277,18 +315,27 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ "--strict" "--eval-only" "--xml" script))) +(define (pipe-failed? pipe) + "Close pipe and return its status if it failed." + (let ((status (close-pipe pipe))) + (if (or (status:term-sig status) + (not (= (status:exit-val status) 0))) + status + #f))) + (define (nix-prefetch-url url) ;; Download URL in the Nix store and return the base32-encoded SHA256 hash ;; of the file at URL (let* ((pipe (open-pipe* OPEN_READ "nix-prefetch-url" url)) (hash (read-line pipe))) - (close-pipe pipe) - (if (eof-object? hash) + (if (or (pipe-failed? pipe) + (eof-object? hash)) (values #f #f) (let* ((pipe (open-pipe* OPEN_READ "nix-store" "--print-fixed-path" - "sha256" hash (basename url))) + "sha256" hash (basename url))) (path (read-line pipe))) - (if (eof-object? path) + (if (or (pipe-failed? pipe) + (eof-object? path)) (values #f #f) (values (string-trim-both hash) (string-trim-both path))))))) @@ -478,8 +525,14 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ (throw 'ftp-error conn "LIST" code))))) (else (loop (read-line s) - (let ((file (car (reverse (string-tokenize line))))) - (cons file result))))))) + (match (reverse (string-tokenize line)) + ((file _ ... permissions) + (let ((type (case (string-ref permissions 0) + ((#\d) 'directory) + (else 'file)))) + (cons (list file type) result))) + ((file _ ...) + (cons (cons file 'file) result)))))))) (lambda () (close s) (let-values (((code message) (%ftp-listen (ftp-connection-socket conn)))) @@ -498,10 +551,11 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ "automake17x" "automake19x" "automake110x" - "automake" ;; = 1.10.x "bison1875" "bison23" - "bison" ;; = 2.3 + "bison24" + "bison" ;; = 2.4 + "ccrtp_1_8" "emacs22" "emacsSnapshot" "gcc295" @@ -513,10 +567,24 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ "gcc43" "gcc44" "gcc45" + "gcc45_real" + "gcc45_realCross" + "gfortran45" + "gcj45" + "gcc46" + "gcc46_real" + "gcc46_realCross" + "gfortran46" + "gcj46" "glibc25" "glibc27" "glibc29" - "guile_1_9" + "guile_1_8" + "icecat3Xul" ;; redundant with `icecat' + "icecatWrapper" + "icecatXulrunner3" + "libzrtpcpp_1_6" + "parted_2_3" )) (define (gnu? package) @@ -558,15 +626,18 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ (define (ftp-server/directory project) (define quirks '(("commoncpp2" "ftp.gnu.org" "/gnu/commoncpp" #f) + ("ucommon" "ftp.gnu.org" "/gnu/commoncpp" #f) + ("libzrtpcpp" "ftp.gnu.org" "/gnu/ccrtp" #f) + ("libosip2" "ftp.gnu.org" "/gnu/osip" #f) ("libgcrypt" "ftp.gnupg.org" "/gcrypt" #t) ("libgpg-error" "ftp.gnupg.org" "/gcrypt" #t) ("freefont-ttf" "ftp.gnu.org" "/gnu/freefont" #f) ("gnupg" "ftp.gnupg.org" "/gcrypt" #t) ("gnu-ghostscript" "ftp.gnu.org" "/gnu/ghostscript" #f) - ("grub" "alpha.gnu.org" "/gnu" #t) ("GNUnet" "ftp.gnu.org" "/gnu/gnunet" #f) - ("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg") + ("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg" #f) ("icecat" "ftp.gnu.org" "/gnu/gnuzilla" #f) + ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite" #f) ("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz" #f))) (let ((quirk (assoc project quirks))) @@ -594,40 +665,65 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ (or (assoc-ref quirks project) project)) (define (releases project) - ;; TODO: Handle project release trees like that of IceCat and MyServer. + "Return the list of releases of PROJECT as a list of release name/directory +pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). " ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp. (define release-rx - (make-regexp (string-append "^" project "-[0-9].*\\.tar\\."))) + (make-regexp (string-append "^" project + "-([0-9]|[^-])*(-src)?\\.tar\\."))) + + (define alpha-rx + (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) + + (define (sans-extension tarball) + (let ((end (string-contains tarball ".tar"))) + (substring tarball 0 end))) - (catch #t + (catch 'ftp-error (lambda () (let-values (((server directory) (ftp-server/directory project))) - (let* ((conn (ftp-open server)) - (files (ftp-list conn directory))) - (ftp-close conn) - (map (lambda (tarball) - (let ((end (string-contains tarball ".tar"))) - (substring tarball 0 end))) - - ;; Filter out signatures, deltas, and files which are potentially - ;; not releases of PROJECT (e.g., in /gnu/guile, filter out - ;; guile-oops and guile-www). - (filter (lambda (file) - (and (not (string-suffix? ".sig" file)) - (regexp-exec release-rx file))) - files))))) + (define conn (ftp-open server)) + + (let loop ((directories (list directory)) + (result '())) + (if (null? directories) + (begin + (ftp-close conn) + result) + (let* ((directory (car directories)) + (files (ftp-list conn directory)) + (subdirs (filter-map (lambda (file) + (match file + ((name 'directory . _) name) + (_ #f))) + files))) + (loop (append (map (cut string-append directory "/" <>) + subdirs) + (cdr directories)) + (append + ;; Filter out signatures, deltas, and files which are potentially + ;; not releases of PROJECT (e.g., in /gnu/guile, filter out + ;; guile-oops and guile-www; in mit-scheme, filter out + ;; binaries). + (filter-map (lambda (file) + (match file + ((file 'file . _) + (and (not (string-suffix? ".sig" file)) + (regexp-exec release-rx file) + (not (regexp-exec alpha-rx file)) + (let ((s (sans-extension file))) + (and (regexp-exec + %package-name-rx s) + (cons s directory))))) + (_ #f))) + files) + result))))))) (lambda (key subr message . args) (format (current-error-port) - "failed to get release list for `~A': ~A ~A~%" + "failed to get release list for `~A': ~S ~S~%" project message args) '()))) -(define pointer->procedure - ;; Compatibility hack for Guile up to 1.9.12 included. - (if (defined? 'pointer->procedure) - pointer->procedure - make-foreign-function)) - (define version-string>? (let ((strverscmp (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) @@ -637,53 +733,64 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ (> (strverscmp (string->pointer a) (string->pointer b)) 0)))) (define (latest-release project) - ;; Return "FOO-X.Y" or #f. + "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f." (let ((releases (releases project))) (and (not (null? releases)) (fold (lambda (release latest) - (if (version-string>? release latest) + (if (version-string>? (car release) (car latest)) release latest)) - "" + '("" . "") releases)))) +(define %package-name-rx + ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses + ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed. + (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?")) + (define (package/version name+version) - (let ((hyphen (string-rindex name+version #\-))) - (if (not hyphen) + "Return the package name and version number extracted from NAME+VERSION." + (let ((match (regexp-exec %package-name-rx name+version))) + (if (not match) (values name+version #f) - (let ((name (substring name+version 0 hyphen)) - (version (substring name+version (+ hyphen 1) - (string-length name+version)))) - (values name version))))) + (values (match:substring match 1) (match:substring match 2))))) (define (file-extension file) (let ((dot (string-rindex file #\.))) (and dot (substring file (+ 1 dot) (string-length file))))) (define (packages-to-update gnu-packages) + (define (unpack latest) + (call-with-values (lambda () + (package/version (car latest))) + (lambda (name version) + (list name version (cdr latest))))) + (fold (lambda (pkg result) (call-with-package pkg (lambda (attribute name+version location meta src) (let-values (((name old-version) (package/version name+version))) (let ((latest (latest-release (nixpkgs->gnu-name name)))) - (cond ((not latest) - (format #t "~A [unknown latest version]~%" - name+version) - result) - ((string=? name+version latest) + (if (not latest) + (begin + (format #t "~A [unknown latest version]~%" + name+version) + result) + (match (unpack latest) + ((_ (? (cut string=? old-version <>)) _) (format #t "~A [up to date]~%" name+version) result) - (else - (let-values (((project new-version) - (package/version latest)) - ((old-name old-hash old-urls) + ((project new-version directory) + (let-values (((old-name old-hash old-urls) (src->values src))) - (format #t "~A -> ~A [~A]~%" name+version latest + (format #t "~A -> ~A [~A]~%" + name+version (car latest) (and (pair? old-urls) (car old-urls))) (let* ((url (and (pair? old-urls) (car old-urls))) - (new-hash (fetch-gnu project new-version + (new-hash (fetch-gnu project directory + new-version (if url (file-extension url) "gz")))) @@ -691,39 +798,38 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ old-version old-hash new-version new-hash location) - result)))))))))) + result))))))))))) '() gnu-packages)) -(define (fetch-gnu project version archive-type) - (let-values (((server directory) - (ftp-server/directory project))) - (let* ((base (string-append project "-" version ".tar." archive-type)) - (url (string-append "ftp://" server "/" directory "/" base)) - (sig (string-append base ".sig")) - (sig-url (string-append url ".sig"))) - (let-values (((hash path) (nix-prefetch-url url))) - (pk 'prefetch-url url hash path) - (and hash path - (begin - (false-if-exception (delete-file sig)) - (system* "wget" sig-url) - (if (file-exists? sig) - (let ((ret (system* "gpg" "--verify" sig path))) - (false-if-exception (delete-file sig)) - (if (and ret (= 0 (status:exit-val ret))) - hash - (begin - (format (current-error-port) - "signature verification failed for `~a'~%" - base) - (format (current-error-port) - "(could be because the public key is not in your keyring)~%") - #f))) - (begin - (format (current-error-port) - "no signature for `~a'~%" base) - hash)))))))) +(define (fetch-gnu project directory version archive-type) + (let* ((server (ftp-server/directory project)) + (base (string-append project "-" version ".tar." archive-type)) + (url (string-append "ftp://" server "/" directory "/" base)) + (sig (string-append base ".sig")) + (sig-url (string-append url ".sig"))) + (let-values (((hash path) (nix-prefetch-url url))) + (pk 'prefetch-url url hash path) + (and hash path + (begin + (false-if-exception (delete-file sig)) + (system* "wget" sig-url) + (if (file-exists? sig) + (let ((ret (system* "gpg" "--verify" sig path))) + (false-if-exception (delete-file sig)) + (if (and ret (= 0 (status:exit-val ret))) + hash + (begin + (format (current-error-port) + "signature verification failed for `~a'~%" + base) + (format (current-error-port) + "(could be because the public key is not in your keyring)~%") + #f))) + (begin + (format (current-error-port) + "no signature for `~a'~%" base) + hash))))))) ;;; @@ -769,20 +875,31 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ (define (gnupdate . args) ;; Assume Nixpkgs is under $NIXPKGS or ~/src/nixpkgs. + + (define (nixpkgs->snix xml-file) + (format (current-error-port) "evaluating Nixpkgs...~%") + (let* ((home (getenv "HOME")) + (xml (if xml-file + (open-input-file xml-file) + (open-nixpkgs (or (getenv "NIXPKGS") + (string-append home "/src/nixpkgs"))))) + (snix (xml->snix xml))) + (if (not xml-file) + (let ((status (pipe-failed? xml))) + (if status + (begin + (format (current-error-port) "`nix-instantiate' failed: ~A~%" + status) + (exit 1))))) + snix)) + (let* ((opts (args-fold (cdr args) %options (lambda (opt name arg result) (error "unrecognized option `~A'" name)) (lambda (operand result) (error "extraneous argument `~A'" operand)) '())) - (home (getenv "HOME")) - (path (or (getenv "NIXPKGS") - (string-append home "/src/nixpkgs"))) - (snix (begin - (format (current-error-port) "parsing XML...~%") - (xml->snix - (or (and=> (assoc-ref opts 'xml-file) open-input-file) - (open-nixpkgs path))))) + (snix (nixpkgs->snix (assoc-ref opts 'xml-file))) (packages (match snix (('snix _ ('attribute-set attributes)) attributes) @@ -826,3 +943,7 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \ (_ #f))) updates) #t)) + +;;; Local Variables: +;;; eval: (put 'call-with-package 'scheme-indent-function 1) +;;; End: |