synchronize with trunk

svn path=/nixpkgs/branches/stdenv-updates/; revision=30186

1 files changed, 93 insertions, 46 deletions

diff --git a/maintainers/scripts/gnu/gnupdate b/maintainers/scripts/gnu/gnupdate
index 96517f86cb8..a0c1f338d3a 100755
--- a/maintainers/scripts/gnu/gnupdate
+++ b/maintainers/scripts/gnu/gnupdate
@@ -308,12 +308,17 @@ replaced by the result of their application to DERIVATIONS, a vhash."
   ;; DERIVATION lacks an "src" attribute.
   (and=> (derivation-source derivation) source-output-path))
 
-(define (open-nixpkgs nixpkgs)
+(define* (open-nixpkgs nixpkgs #:optional attribute)
+  ;; Return an input pipe to the XML representation of Nixpkgs.  When
+  ;; ATTRIBUTE is true, only that attribute is considered.
   (let ((script  (string-append nixpkgs
                                 "/maintainers/scripts/eval-release.nix")))
-    (open-pipe* OPEN_READ "nix-instantiate"
-                "--strict" "--eval-only" "--xml"
-                script)))
+    (apply open-pipe* OPEN_READ
+           "nix-instantiate" "--strict" "--eval-only" "--xml"
+           `(,@(if attribute
+                   `("-A" ,attribute)
+                   '())
+             ,script))))
 
 (define (pipe-failed? pipe)
   "Close pipe and return its status if it failed."
@@ -323,21 +328,36 @@ replaced by the result of their application to DERIVATIONS, a vhash."
         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)))
-    (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)))
-               (path (read-line pipe)))
-          (if (or (pipe-failed? pipe)
-                  (eof-object? path))
-              (values #f #f)
-              (values (string-trim-both hash) (string-trim-both path)))))))
+(define (memoize proc)
+  "Return a memoizing version of PROC."
+  (let ((cache (make-hash-table)))
+    (lambda args
+      (let ((results (hash-ref cache args)))
+        (if results
+            (apply values results)
+            (let ((results (call-with-values (lambda ()
+                                               (apply proc args))
+                             list)))
+              (hash-set! cache args results)
+              (apply values results)))))))
+
+(define nix-prefetch-url
+  (memoize
+   (lambda (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)))
+       (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)))
+                  (path (read-line pipe)))
+             (if (or (pipe-failed? pipe)
+                     (eof-object? path))
+                 (values #f #f)
+                 (values (string-trim-both hash) (string-trim-both path)))))))))
 
 (define (update-nix-expression file
                                old-version old-hash
@@ -409,8 +429,7 @@ replaced by the result of their application to DERIVATIONS, a vhash."
 (define %openpgp-key-server "keys.gnupg.net")
 
 (define (gnupg-verify sig file)
-  "Verify signature SIG for FILE.  Return a status s-exp or #f if GnuPG
-failed."
+  "Verify signature SIG for FILE.  Return a status s-exp if GnuPG failed."
 
   (define (status-line->sexp line)
     ;; See file `doc/DETAILS' in GnuPG.
@@ -475,9 +494,10 @@ failed."
   (let* ((pipe   (open-pipe* OPEN_READ %gpg-command "--status-fd=1"
                              "--verify" sig file))
          (status (parse-status pipe)))
-    (if (pipe-failed? pipe)
-        #f
-        status)))
+    ;; Ignore PIPE's exit status since STATUS above should contain all the
+    ;; info we need.
+    (close-pipe pipe)
+    status))
 
 (define (gnupg-status-good-signature? status)
   "If STATUS, as returned by `gnupg-verify', denotes a good signature, return
@@ -716,7 +736,8 @@ Return #t if the signature was good, #f otherwise."
                         (('attribute _ "description" value)
                          (string-prefix? "GNU" value))
                         (('attribute _ "homepage" (? string? value))
-                         (string-contains value "www.gnu.org"))
+                         (or (string-contains value "gnu.org")
+                             (string-contains value "gnupg.org")))
                         (('attribute _ "homepage" ((? string? value) ...))
                          (any (cut string-contains <> "www.gnu.org") value))
                         (_ #f)))
@@ -749,6 +770,7 @@ Return #t if the signature was good, #f otherwise."
       ("libosip2"     "ftp.gnu.org"   "/gnu/osip" #f)
       ("libgcrypt"    "ftp.gnupg.org" "/gcrypt" #t)
       ("libgpg-error" "ftp.gnupg.org" "/gcrypt" #t)
+      ("libassuan"    "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)
@@ -921,6 +943,7 @@ pairs.  Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
         gnu-packages))
 
 (define (fetch-gnu project directory version archive-type)
+  "Download PROJECT's tarball over FTP."
   (let* ((server  (ftp-server/directory project))
          (base    (string-append project "-" version ".tar." archive-type))
          (url     (string-append "ftp://" server "/" directory "/" base))
@@ -963,12 +986,18 @@ pairs.  Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
                   (format #t "~%")
                   (format #t "  -x, --xml=FILE      Read XML output of `nix-instantiate'~%")
                   (format #t "                      from FILE.~%")
+                  (format #t "  -A, --attribute=ATTR~%")
+                  (format #t "                      Update only the package pointed to by attribute~%")
+                  (format #t "                      ATTR.~%")
                   (format #t "  -s, --select=SET    Update only packages from SET, which may~%")
                   (format #t "                      be either `all', `stdenv', or `non-stdenv'.~%")
                   (format #t "  -d, --dry-run       Don't actually update Nix expressions~%")
                   (format #t "  -h, --help          Give this help list.~%~%")
                   (format #t "Report bugs to <ludo@gnu.org>~%")
                   (exit 0)))
+        (option '(#\A "attribute") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'attribute arg result)))
         (option '(#\s "select") #t #f
                 (lambda (opt name arg result)
                   (cond ((string-ci=? arg "stdenv")
@@ -994,13 +1023,14 @@ pairs.  Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
 (define (gnupdate . args)
   ;; Assume Nixpkgs is under $NIXPKGS or ~/src/nixpkgs.
 
-  (define (nixpkgs->snix xml-file)
+  (define (nixpkgs->snix xml-file attribute)
     (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")))))
+                                       (string-append home "/src/nixpkgs"))
+                                   attribute)))
            (snix (xml->snix xml)))
       (if (not xml-file)
           (let ((status (pipe-failed? xml)))
@@ -1009,7 +1039,34 @@ pairs.  Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
                   (format (current-error-port) "`nix-instantiate' failed: ~A~%"
                           status)
                   (exit 1)))))
-      snix))
+
+      ;; If we asked for a specific attribute, rewrap the thing in an
+      ;; attribute set to match the expectations of `packages-to-update' & co.
+      (if attribute
+          (match snix
+            (('snix loc ('derivation args ...))
+             `(snix ,loc
+                    (attribute-set
+                     ((attribute #f ,attribute
+                                 (derivation ,@args)))))))
+          snix)))
+
+  (define (selected-gnu-packages packages stdenv selection)
+    ;; Return the subset of PACKAGES that are/aren't in STDENV, according to
+    ;; SELECTION.  To do that reliably, we check whether their "src"
+    ;; derivation is a requisite of STDENV.
+    (define gnu
+      (gnu-packages packages))
+
+    (case selection
+      ((stdenv)
+       gnu)
+      ((non-stdenv)
+       (filter (lambda (p)
+                 (not (member (package-source-output-path p)
+                              (force stdenv))))
+               gnu))
+      (else gnu)))
 
   (let* ((opts      (args-fold (cdr args) %options
                                (lambda (opt name arg result)
@@ -1017,7 +1074,8 @@ pairs.  Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
                                (lambda (operand result)
                                  (error "extraneous argument `~A'" operand))
                                '()))
-         (snix      (nixpkgs->snix (assoc-ref opts 'xml-file)))
+         (snix      (nixpkgs->snix (assq-ref opts 'xml-file)
+                                   (assq-ref opts 'attribute)))
          (packages  (match snix
                       (('snix _ ('attribute-set attributes))
                        attributes)
@@ -1026,23 +1084,12 @@ pairs.  Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
                       ;; The source tarballs that make up stdenv.
                       (filter-map derivation-source-output-path
                                   (package-requisites (stdenv-package packages)))))
-         (gnu       (gnu-packages packages))
-         (gnu*      (case (assoc-ref opts 'filter)
-                      ;; Filter out packages that are/aren't in `stdenv'.  To
-                      ;; do that reliably, we check whether their "src"
-                      ;; derivation is a requisite of stdenv.
-                      ((stdenv)
-                       (filter (lambda (p)
-                                 (member (package-source-output-path p)
-                                         (force stdenv)))
-                               gnu))
-                      ((non-stdenv)
-                       (filter (lambda (p)
-                                 (not (member (package-source-output-path p)
-                                              (force stdenv))))
-                               gnu))
-                      (else gnu)))
-         (updates   (packages-to-update gnu*)))
+         (attribute (assq-ref opts 'attribute))
+         (selection (assq-ref opts 'filter))
+         (to-update (if attribute
+                        packages                  ; already a subset
+                        (selected-gnu-packages packages stdenv selection)))
+         (updates   (packages-to-update to-update)))
 
     (format #t "~%~A packages to update...~%" (length updates))
     (for-each (lambda (update)