From 3ee5a7d86a5497ef444533df8763f41e24f9bf61 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 31 Mar 2013 12:39:25 +0200
Subject: [PATCH 01/74] gnu: perl-xml-parser: Fix URL.

* gnu/packages/xml.scm (perl-xml-parser): Fix URL.
---
 gnu/packages/xml.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gnu/packages/xml.scm b/gnu/packages/xml.scm
index b3c5f7d512..b5c40bef98 100644
--- a/gnu/packages/xml.scm
+++ b/gnu/packages/xml.scm
@@ -99,7 +99,7 @@ based on libxml for XML parsing, tree manipulation and XPath support.")
     (source (origin
              (method url-fetch)
              (uri (string-append
-                   "mirror://cpan/authors/id/M/MS/MSERGEANT/XML-Parser-"
+                   "mirror://cpan/authors/id/T/TO/TODDR/XML-Parser-"
                    version ".tar.gz"))
              (sha256
               (base32

From fdfd3d5d9c647876a0d7422b25fde1a6b8e9e654 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 31 Mar 2013 12:46:28 +0200
Subject: [PATCH 02/74] pull: Switch to the cgit URL.

* guix/scripts/pull.scm (%snapshot-url): Switch to the cgit URL, given
  that the Hydra one is not currently available.
---
 guix/scripts/pull.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index bc72dc4088..c5facd84d5 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -34,8 +34,8 @@
   #:export (guix-pull))
 
 (define %snapshot-url
-  "http://hydra.gnu.org/job/guix/master/tarball/latest/download"
-  ;;"http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz"
+  ;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download"
+  "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz"
   )
 
 (define (download-and-store store)

From ef8c03407dce8d6ebdfcf53318ac9a09b5ee8461 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 1 Apr 2013 00:41:55 +0200
Subject: [PATCH 03/74] gnu-maintenance: Adjust `http-fetch' to the various
 Guile versions.

* guix/gnu-maintenance.scm (http-fetch): Try #:streaming? #t, or
  'http-get*', or 'http-get' as a last resort.  Check whether DATA is
  #f, a string, or an input port.
---
 guix/gnu-maintenance.scm | 15 +++++++++++----
 1 file changed, 11 insertions(+), 4 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 979678d076..89e7f25589 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -66,12 +66,18 @@
 (define (http-fetch uri)
   "Return an input port containing the textual data at URI, a string."
   (let*-values (((resp data)
-                (http-get (string->uri uri)))
+                 (let ((uri (string->uri uri)))
+                   ;; Try hard to use the API du jour to get an input port.
+                   (if (version>? "2.0.7" (version))
+                       (if (defined? 'http-get*)
+                           (http-get* uri)
+                           (http-get uri))       ; old Guile, returns a string
+                       (http-get uri #:streaming? #t)))) ; 2.0.8 or later
                ((code)
                 (response-code resp)))
     (case code
       ((200)
-       (cond ((string<=? (version) "2.0.5")
+       (cond ((not data)
               (begin
                 ;; XXX: Guile 2.0.5 and earlier did not support chunked transfer
                 ;; encoding, which is required when fetching %PACKAGE-LIST-URL
@@ -85,9 +91,10 @@
                         (response-transfer-encoding resp))
                 (error "download failed; use a newer Guile"
                        uri resp)))
-             ((string<=? (version) "2.0.7")
+             ((string? data)                 ; old `http-get' returns a string
               (open-input-string data))
-             (else data)))
+             (else                           ; input port
+              data)))
       (else
        (error "download failed" uri code
               (response-reason-phrase resp))))))

From 2c6ab6ccd430550dfbc95fbdd22ae017f39e5901 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 1 Apr 2013 16:08:31 +0200
Subject: [PATCH 04/74] store: Add `store-path-hash-part'.

* guix/store.scm (store-path-hash-part): New procedure.
* tests/store.scm ("store-path-hash-part", "store-path-hash-part #f"):
  New tests.
---
 guix/store.scm  | 12 +++++++++++-
 tests/store.scm | 12 ++++++++++++
 2 files changed, 23 insertions(+), 1 deletion(-)

diff --git a/guix/store.scm b/guix/store.scm
index 4d078c5899..3bb2656bb6 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -83,7 +83,8 @@
             %store-prefix
             store-path?
             derivation-path?
-            store-path-package-name))
+            store-path-package-name
+            store-path-hash-part))
 
 (define %protocol-version #x10c)
 
@@ -751,3 +752,12 @@ collected, and the number of bytes freed."
 
   (and=> (regexp-exec store-path-rx path)
          (cut match:substring <> 1)))
+
+(define (store-path-hash-part path)
+  "Return the hash part of PATH as a base32 string, or #f if PATH is not a
+syntactically valid store path."
+  (let ((path-rx (make-regexp
+                  (string-append"^" (regexp-quote (%store-prefix))
+                                "/([0-9a-df-np-sv-z]{32})-[^/]+$"))))
+    (and=> (regexp-exec path-rx path)
+           (cut match:substring <> 1))))
diff --git a/tests/store.scm b/tests/store.scm
index c2de99e160..d6e1aa54e3 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -48,6 +48,18 @@
 
 (test-begin "store")
 
+(test-equal "store-path-hash-part"
+  "283gqy39v3g9dxjy26rynl0zls82fmcg"
+  (store-path-hash-part
+   (string-append (%store-prefix)
+                  "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
+
+(test-equal "store-path-hash-part #f"
+  #f
+  (store-path-hash-part
+   (string-append (%store-prefix)
+                  "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
+
 (test-skip (if %store 0 10))
 
 (test-assert "dead-paths"

From adb5f46940aec2a58446c647487998beaa31f412 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 2 Apr 2013 10:59:27 +0200
Subject: [PATCH 05/74] gnu: Add libphidget.

* gnu/packages/libphidget.scm: New file.
* Makefile.am (MODULES): Add it.
---
 Makefile.am                 |  1 +
 gnu/packages/libphidget.scm | 42 +++++++++++++++++++++++++++++++++++++
 2 files changed, 43 insertions(+)
 create mode 100644 gnu/packages/libphidget.scm

diff --git a/Makefile.am b/Makefile.am
index 41ef50318c..74977c5cf7 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -113,6 +113,7 @@ MODULES =					\
   gnu/packages/libffi.scm			\
   gnu/packages/libidn.scm			\
   gnu/packages/libjpeg.scm			\
+  gnu/packages/libphidget.scm			\
   gnu/packages/libpng.scm			\
   gnu/packages/libsigsegv.scm			\
   gnu/packages/libtiff.scm			\
diff --git a/gnu/packages/libphidget.scm b/gnu/packages/libphidget.scm
new file mode 100644
index 0000000000..0f4ae5f965
--- /dev/null
+++ b/gnu/packages/libphidget.scm
@@ -0,0 +1,42 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu packages libphidget)
+  #:use-module (guix packages)
+  #:use-module (guix download)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix licenses)
+  #:use-module (gnu packages libusb))
+
+(define-public libphidget
+  (package
+   (name "libphidget")
+   (version "2.1.8.20130320")
+   (source (origin
+            (method url-fetch)
+            (uri (string-append
+                  "http://www.phidgets.com/downloads/libraries/libphidget_"
+                  version ".tar.gz"))
+            (sha256
+             (base32 "09ibrz1df5ajqcm9vmx6zw8qama2rzf0961yhmmfsy629qfhyrk0"))))
+   (build-system gnu-build-system)
+   (inputs `(("libusb" ,libusb)))
+   (home-page "http://www.phidgets.com/")
+   (license lgpl3+)
+   (synopsis "C library to manipulate Phidgets")
+   (description synopsis)))

From cf53ecf514301d3ffdfc33dea057b057ffb132d6 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 3 Apr 2013 14:44:40 +0200
Subject: [PATCH 06/74] gnu: bigloo: Add dependencies on Avahi and libphidget.

* gnu/packages/scheme.scm (bigloo): Add Avahi and libphidget as inputs,
  and pkg-config as a native input.
---
 gnu/packages/scheme.scm | 11 ++++++++++-
 1 file changed, 10 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index 59e1da22ac..4b42f8c53c 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -28,6 +28,9 @@
   #:use-module (gnu packages texinfo)
   #:use-module (gnu packages patchelf)
   #:use-module (gnu packages which)
+  #:use-module (gnu packages pkg-config)
+  #:use-module (gnu packages avahi)
+  #:use-module (gnu packages libphidget)
   #:use-module (ice-9 match))
 
 (define-public mit-scheme
@@ -161,7 +164,13 @@ development cycle.")
                    %standard-phases)))))
     (inputs
      `(("emacs" ,emacs)
-       ("patch/shebangs" ,(search-patch "bigloo-gc-shebangs.patch"))))
+       ("patch/shebangs" ,(search-patch "bigloo-gc-shebangs.patch"))
+
+       ;; Optional APIs for which Bigloo has bindings.
+       ("avahi" ,avahi)
+       ("libphidget" ,libphidget)))
+    (native-inputs
+     `(("pkg-config" ,pkg-config)))
     (propagated-inputs
      `(("gmp" ,gmp)))                             ; bigloo.h refers to gmp.h
     (home-page "http://www-sop.inria.fr/indes/fp/Bigloo/")

From f65cf81a3cd15eab993e129977bca46972508b4b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 2 Apr 2013 10:44:20 +0200
Subject: [PATCH 07/74] Add preliminary binary substituter.

* guix/scripts/substitute-binary.scm: New file.
* Makefile.am (MODULES): Add it.
* nix/scripts/substitute-binary.in: New file.
* config-daemon.ac: Produce nix/scripts/substitute-binary.
* daemon.am (nodist_pkglibexec_SCRIPTS): Add
  nix/scripts/substitute-binary.
* guix/store.scm (substitutable-path-info): Use the
  `query-substitutable-path-infos' RPC.
* nix/nix-daemon/guix-daemon.cc (main): Honor `NIX_SUBSTITUTERS'.
* pre-inst-env.in: Set `NIX_SUBSTITUTERS'.
* test-env.in: Leave `NIX_SUBSTITUTERS' unchanged.  Set
  `GUIX_BINARY_SUBSTITUTE_URL, and create
  $NIX_STATE_DIR/substituter-data.
  Run `guix-daemon' within `./pre-inst-env'.
* tests/store.scm ("substitute query"): New test.
---
 .gitignore                         |   1 +
 Makefile.am                        |   1 +
 config-daemon.ac                   |   5 +-
 daemon.am                          |   3 +-
 guix/scripts/substitute-binary.scm | 232 +++++++++++++++++++++++++++++
 guix/store.scm                     |   2 +-
 nix/nix-daemon/guix-daemon.cc      |  12 +-
 nix/scripts/substitute-binary.in   |  11 ++
 pre-inst-env.in                    |   3 +-
 test-env.in                        |  17 ++-
 tests/store.scm                    |  39 +++++
 11 files changed, 313 insertions(+), 13 deletions(-)
 create mode 100755 guix/scripts/substitute-binary.scm
 create mode 100644 nix/scripts/substitute-binary.in

diff --git a/.gitignore b/.gitignore
index 302e473fd8..f2b1f1cd39 100644
--- a/.gitignore
+++ b/.gitignore
@@ -72,3 +72,4 @@ stamp-h[0-9]
 /doc/guix.tp
 /doc/guix.vr
 /doc/guix.vrs
+/nix/scripts/substitute-binary
diff --git a/Makefile.am b/Makefile.am
index 74977c5cf7..888302bd96 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -31,6 +31,7 @@ MODULES =					\
   guix/scripts/package.scm			\
   guix/scripts/gc.scm				\
   guix/scripts/pull.scm				\
+  guix/scripts/substitute-binary.scm		\
   guix/base32.scm				\
   guix/utils.scm				\
   guix/derivations.scm				\
diff --git a/config-daemon.ac b/config-daemon.ac
index f48741dfda..eed1e23f9e 100644
--- a/config-daemon.ac
+++ b/config-daemon.ac
@@ -93,8 +93,9 @@ if test "x$guix_build_daemon" = "xyes"; then
   AC_MSG_RESULT([$GUIX_TEST_ROOT])
   AC_SUBST([GUIX_TEST_ROOT])
 
-  AC_CONFIG_FILES([nix/scripts/list-runtime-roots],
-    [chmod +x nix/scripts/list-runtime-roots])
+  AC_CONFIG_FILES([nix/scripts/list-runtime-roots
+                   nix/scripts/substitute-binary],
+    [chmod +x nix/scripts/list-runtime-roots nix/scripts/substitute-binary])
 fi
 
 AM_CONDITIONAL([BUILD_DAEMON], [test "x$guix_build_daemon" = "xyes"])
diff --git a/daemon.am b/daemon.am
index 0c9bc9fb69..1d4d955a0c 100644
--- a/daemon.am
+++ b/daemon.am
@@ -159,7 +159,8 @@ nix/libstore/schema.sql.hh: nix/libstore/schema.sql
 	           (write (get-string-all in) out)))))"
 
 nodist_pkglibexec_SCRIPTS =			\
-  nix/scripts/list-runtime-roots
+  nix/scripts/list-runtime-roots		\
+  nix/scripts/substitute-binary
 
 EXTRA_DIST +=					\
   nix/sync-with-upstream			\
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
new file mode 100755
index 0000000000..6e886b6c96
--- /dev/null
+++ b/guix/scripts/substitute-binary.scm
@@ -0,0 +1,232 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts substitute-binary)
+  #:use-module (guix ui)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 threads)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:export (guix-substitute-binary))
+
+;;; Comment:
+;;;
+;;; This is the "binary substituter".  It is invoked by the daemon do check
+;;; for the existence of available "substitutes" (pre-built binaries), and to
+;;; actually use them as a substitute to building things locally.
+;;;
+;;; If possible, substitute a binary for the requested store path, using a Nix
+;;; "binary cache".  This program implements the Nix "substituter" protocol.
+;;;
+;;; Code:
+
+(define (fields->alist port)
+  "Read recutils-style record from PORT and return them as a list of key/value
+pairs."
+  (define field-rx
+    (make-regexp "^([[:graph:]]+): (.*)$"))
+
+  (let loop ((line   (read-line port))
+             (result '()))
+    (cond ((eof-object? line)
+           (reverse result))
+          ((regexp-exec field-rx line)
+           =>
+           (lambda (match)
+             (loop (read-line port)
+                   (alist-cons (match:substring match 1)
+                               (match:substring match 2)
+                               result))))
+          (else
+           (error "unmatched line" line)))))
+
+(define (alist->record alist make keys)
+  "Apply MAKE to the values associated with KEYS in ALIST."
+  (let ((args (map (cut assoc-ref alist <>) keys)))
+    (apply make args)))
+
+(define (fetch uri)
+  (case (uri-scheme uri)
+    ((file)
+     (open-input-file (uri-path uri)))
+    ((http)
+     (let*-values (((resp port)
+                    ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated
+                    ;; in 2.0.8 (!).  Assume it is available here.
+                    (if (version>? "2.0.7" (version))
+                        (http-get* uri #:decode-body? #f)
+                        (http-get uri #:streaming? #t)))
+                   ((code)
+                    (response-code resp))
+                   ((size)
+                    (response-content-length resp)))
+       (case code
+         ((200)                                   ; OK
+          port)
+         ((301                                    ; moved permanently
+           302)                                   ; found (redirection)
+          (let ((uri (response-location resp)))
+            (format #t "following redirection to `~a'...~%"
+                    (uri->string uri))
+            (fetch uri)))
+         (else
+          (error "download failed" (uri->string uri)
+                 code (response-reason-phrase resp))))))))
+
+(define-record-type <cache>
+  (%make-cache url store-directory wants-mass-query?)
+  cache?
+  (url               cache-url)
+  (store-directory   cache-store-directory)
+  (wants-mass-query? cache-wants-mass-query?))
+
+(define (open-cache url)
+  "Open the binary cache at URL.  Return a <cache> object on success, or #f on
+failure."
+  (define (download-cache-info url)
+    ;; Download the `nix-cache-info' from URL, and return its contents as an
+    ;; list of key/value pairs.
+    (and=> (false-if-exception (fetch (string->uri url)))
+           fields->alist))
+
+  (and=> (download-cache-info (string-append url "/nix-cache-info"))
+         (lambda (properties)
+           (alist->record properties
+                          (cut %make-cache url <...>)
+                          '("StoreDir" "WantMassQuery")))))
+
+(define-record-type <narinfo>
+  (%make-narinfo path url compression file-hash file-size nar-hash nar-size
+                 references deriver system)
+  narinfo?
+  (path         narinfo-path)
+  (url          narinfo-url)
+  (compression  narinfo-compression)
+  (file-hash    narinfo-file-hash)
+  (file-size    narinfo-file-size)
+  (nar-hash     narinfo-hash)
+  (nar-size     narinfo-size)
+  (references   narinfo-references)
+  (deriver      narinfo-deriver)
+  (system       narinfo-system))
+
+(define (make-narinfo path url compression file-hash file-size nar-hash nar-size
+                      references deriver system)
+  "Return a new <narinfo> object."
+  (%make-narinfo path url compression file-hash
+                 (and=> file-size string->number)
+                 nar-hash
+                 (and=> nar-size string->number)
+                 (string-tokenize references)
+                 (match deriver
+                   ((or #f "") #f)
+                   (_ deriver))
+                 system))
+
+(define (fetch-narinfo cache path)
+  "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
+  (define (download url)
+    ;; Download the `nix-cache-info' from URL, and return its contents as an
+    ;; list of key/value pairs.
+    (and=> (false-if-exception (fetch (string->uri url)))
+           fields->alist))
+
+  (and=> (download (string-append (cache-url cache) "/"
+                                  (store-path-hash-part path)
+                                  ".narinfo"))
+         (lambda (properties)
+           (alist->record properties make-narinfo
+                          '("StorePath" "URL" "Compression"
+                            "FileHash" "FileSize" "NarHash" "NarSize"
+                            "References" "Deriver" "System")))))
+
+(define %cache-url
+  (or (getenv "GUIX_BINARY_SUBSTITUTE_URL")
+      "http://hydra.gnu.org"))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-substitute-binary . args)
+  "Implement the build daemon's substituter protocol."
+  (match args
+    (("--query")
+     (let ((cache (open-cache %cache-url)))
+       (let loop ((command (read-line)))
+         (or (eof-object? command)
+             (begin
+               (match (string-tokenize command)
+                 (("have" paths ..1)
+                  ;; Return the subset of PATHS available in CACHE.
+                  (let ((substitutable
+                         (if cache
+                             (par-map (cut fetch-narinfo cache <>)
+                                      paths)
+                             '())))
+                    (for-each (lambda (narinfo)
+                                (when narinfo
+                                  (display (narinfo-path narinfo))
+                                  (newline)))
+                              substitutable)))
+                 (("info" paths ..1)
+                  ;; Reply info about PATHS if it's in CACHE.
+                  (let ((substitutable
+                         (if cache
+                             (par-map (cut fetch-narinfo cache <>)
+                                      paths)
+                             '())))
+                    (for-each (lambda (narinfo)
+                                (format #t "~a\n~a\n~a\n"
+                                        (narinfo-path narinfo)
+                                        (or (and=> (narinfo-deriver narinfo)
+                                                   (cute string-append
+                                                         (%store-prefix) "/"
+                                                         <>))
+                                            "")
+                                        (length (narinfo-references narinfo)))
+                                (for-each (cute format #t "~a/~a~%"
+                                                (%store-prefix) <>)
+                                          (narinfo-references narinfo))
+                                (format #t "~a\n~a\n"
+                                        (or (narinfo-file-size narinfo) 0)
+                                        (or (narinfo-size narinfo) 0))
+                                (newline))
+                              substitutable)))
+                 (wtf
+                  (error "unknown `--query' command" wtf)))
+               (loop (read-line)))))))
+    (("--substitute" store-path destination)
+     ;; Download PATH and add it to the store.
+     ;; TODO: Implement.
+     (format (current-error-port) "substitution not implemented yet~%")
+     #f)
+    (("--version")
+     (show-version-and-exit "guix substitute-binary"))))
+
+;;; substitute-binary.scm ends here
diff --git a/guix/store.scm b/guix/store.scm
index 3bb2656bb6..de9785c835 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -662,7 +662,7 @@ file name.  Return #t on success."
              store-path-list))
 
 (define substitutable-path-info
-  (operation (query-substitutable-paths (store-path-list paths))
+  (operation (query-substitutable-path-infos (store-path-list paths))
              "Return information about the subset of PATHS that is
 substitutable.  For each substitutable path, a `substitutable?' object is
 returned."
diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc
index 1611840bd4..0e2f36150b 100644
--- a/nix/nix-daemon/guix-daemon.cc
+++ b/nix/nix-daemon/guix-daemon.cc
@@ -200,9 +200,17 @@ main (int argc, char *argv[])
     {
       settings.processEnvironment ();
 
-      /* FIXME: Disable substitutes until we have something that works.  */
-      settings.useSubstitutes = false;
+      /* Use our substituter by default.  */
       settings.substituters.clear ();
+      string subs = getEnv ("NIX_SUBSTITUTERS", "default");
+      if (subs == "default")
+	/* XXX: No substituters until we have something that works.  */
+	settings.substituters.clear ();
+	// settings.substituters.push_back (settings.nixLibexecDir
+	// 				 + "/guix/substitute-binary");
+      else
+	settings.substituters = tokenizeString<Strings> (subs, ":");
+
 
       argp_parse (&argp, argc, argv, 0, 0, 0);
 
diff --git a/nix/scripts/substitute-binary.in b/nix/scripts/substitute-binary.in
new file mode 100644
index 0000000000..48d7bb8ff1
--- /dev/null
+++ b/nix/scripts/substitute-binary.in
@@ -0,0 +1,11 @@
+#!@SHELL@
+# A shorthand for "guix substitute-binary", for use by the daemon.
+
+if test "x$GUIX_UNINSTALLED" = "x"
+then
+    prefix="@prefix@"
+    exec_prefix="@exec_prefix@"
+    exec "@bindir@/guix" substitute-binary "$@"
+else
+    exec guix substitute-binary "$@"
+fi
diff --git a/pre-inst-env.in b/pre-inst-env.in
index 4e079c8d41..5e7758cd7c 100644
--- a/pre-inst-env.in
+++ b/pre-inst-env.in
@@ -35,8 +35,9 @@ export PATH
 # Daemon helpers.
 
 NIX_ROOT_FINDER="@abs_top_builddir@/nix/scripts/list-runtime-roots"
+NIX_SUBSTITUTERS="@abs_top_builddir@/nix/scripts/substitute-binary"
 NIX_SETUID_HELPER="@abs_top_builddir@/nix-setuid-helper"
-export NIX_ROOT_FINDER NIX_SETUID_HELPER
+export NIX_ROOT_FINDER NIX_SETUID_HELPER NIX_SUBSTITUTERS
 
 # The following variables need only be defined when compiling Guix
 # modules, but we define them to be on the safe side in case of
diff --git a/test-env.in b/test-env.in
index 491a45c7b4..9a6257197c 100644
--- a/test-env.in
+++ b/test-env.in
@@ -1,7 +1,7 @@
 #!/bin/sh
 
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -26,7 +26,6 @@
 
 if [ -x "@abs_top_builddir@/guix-daemon" ]
 then
-    NIX_SUBSTITUTERS=""		# don't resort to substituters
     NIX_SETUID_HELPER="@abs_top_builddir@/nix-setuid-helper" # normally unused
     NIX_IGNORE_SYMLINK_STORE=1	# in case the store is a symlink
     NIX_STORE_DIR="@GUIX_TEST_ROOT@/store"
@@ -39,18 +38,24 @@ then
     # that the directory name must be chosen so that the socket's file
     # name is less than 108-char long (the size of `sun_path' in glibc).
     # Currently, in Nix builds, we're at ~106 chars...
-    NIX_STATE_DIR="@GUIX_TEST_ROOT@/var/$$" # allow for parallel tests
+    NIX_STATE_DIR="@GUIX_TEST_ROOT@/var/$$"
 
-    export NIX_SUBSTITUTERS NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR	\
+    # A place to store data of the substituter.
+    GUIX_BINARY_SUBSTITUTE_URL="file://$NIX_STATE_DIR/substituter-data"
+    rm -rf "$NIX_STATE_DIR/substituter-data"
+    mkdir -p "$NIX_STATE_DIR/substituter-data"
+
+    export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR			\
 	NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR		\
-	NIX_ROOT_FINDER NIX_SETUID_HELPER
+	NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL
 
     # Do that because store.scm calls `canonicalize-path' on it.
     mkdir -p "$NIX_STORE_DIR"
 
     # Launch the daemon without chroot support because is may be
     # unavailable, for instance if we're not running as root.
-    "@abs_top_builddir@/guix-daemon" --disable-chroot &
+    "@abs_top_builddir@/pre-inst-env"				\
+	"@abs_top_builddir@/guix-daemon" --disable-chroot &
 
     daemon_pid=$!
     trap "kill $daemon_pid ; rm -rf $NIX_STATE_DIR" EXIT
diff --git a/tests/store.scm b/tests/store.scm
index d6e1aa54e3..c75b99c6a9 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -26,6 +26,7 @@
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
   #:use-module (ice-9 match)
+  #:use-module (web uri)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-64))
@@ -128,6 +129,44 @@
          (null? (substitutable-paths s o))
          (null? (substitutable-path-info s o)))))
 
+(test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
+
+(test-assert "substitute query"
+  (let* ((s   (open-connection))
+         (d   (package-derivation s %bootstrap-guile (%current-system)))
+         (o   (derivation-path->output-path d))
+         (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
+                     (compose uri-path string->uri))))
+    ;; Create fake substituter data, to be read by `substitute-binary'.
+    (call-with-output-file (string-append dir "/nix-cache-info")
+      (lambda (p)
+        (format p "StoreDir: ~a\nWantMassQuery: 0\n"
+                (getenv "NIX_STORE_DIR"))))
+    (call-with-output-file (string-append dir "/" (store-path-hash-part o)
+                                          ".narinfo")
+      (lambda (p)
+        (format p "StorePath: ~a
+URL: ~a
+Compression: none
+NarSize: 1234
+References: 
+System: ~a
+Deriver: ~a~%"
+                o                                   ; StorePath
+                (string-append dir "/example.nar")  ; URL
+                (%current-system)                   ; System
+                (basename d))))                     ; Deriver
+
+    ;; Make sure `substitute-binary' correctly communicates the above data.
+    (set-build-options s #:use-substitutes? #t)
+    (and (has-substitutes? s o)
+         (equal? (list o) (substitutable-paths s (list o)))
+         (match (pk 'spi (substitutable-path-info s (list o)))
+           (((? substitutable? s))
+            (and (equal? (substitutable-deriver s) d)
+                 (null? (substitutable-references s))
+                 (equal? (substitutable-nar-size s) 1234)))))))
+
 (test-end "store")
 
 

From 462f8e9f332b3e89bd8b0ebd4c618447b8558560 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 4 Apr 2013 21:47:55 +0200
Subject: [PATCH 08/74] substitute-binary: Fix communication of several store
 paths to the daemon.

* guix/scripts/substitute-binary.scm (guix-substitute-binary)["--query"]:
  Emit blank lines only after the complete list of store paths has been
  returned.
---
 guix/scripts/substitute-binary.scm | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 6e886b6c96..389acab094 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -191,9 +191,9 @@ failure."
                              '())))
                     (for-each (lambda (narinfo)
                                 (when narinfo
-                                  (display (narinfo-path narinfo))
-                                  (newline)))
-                              substitutable)))
+                                  (format #t "~a~%" (narinfo-path narinfo))))
+                              substitutable)
+                    (newline)))
                  (("info" paths ..1)
                   ;; Reply info about PATHS if it's in CACHE.
                   (let ((substitutable
@@ -215,9 +215,9 @@ failure."
                                           (narinfo-references narinfo))
                                 (format #t "~a\n~a\n"
                                         (or (narinfo-file-size narinfo) 0)
-                                        (or (narinfo-size narinfo) 0))
-                                (newline))
-                              substitutable)))
+                                        (or (narinfo-size narinfo) 0)))
+                              substitutable)
+                    (newline)))
                  (wtf
                   (error "unknown `--query' command" wtf)))
                (loop (read-line)))))))

From 0f41c26f9b9c981d5d5ecaa8c2ccda4f4c6ab147 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 4 Apr 2013 22:29:08 +0200
Subject: [PATCH 09/74] Add (guix nar) and (guix serialization).

* guix/store.scm (write-int, read-int, write-long-long, read-long-long,
  write-padding, write-string, read-string, read-latin1-string,
  write-string-list, read-string-list, write-store-path,
  read-store-path, write-store-path-list, read-store-path-list): Move to
  serialization.scm.
  (write-contents, write-file): Move to nar.scm.
* guix/nar.scm, guix/serialization.scm: New files.
* Makefile.am (MODULES): Add them.
---
 Makefile.am            |   2 +
 guix/nar.scm           | 110 ++++++++++++++++++++++++++++++
 guix/serialization.scm | 114 +++++++++++++++++++++++++++++++
 guix/store.scm         | 149 +----------------------------------------
 4 files changed, 228 insertions(+), 147 deletions(-)
 create mode 100644 guix/nar.scm
 create mode 100644 guix/serialization.scm

diff --git a/Makefile.am b/Makefile.am
index 888302bd96..136c01bf3f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -34,6 +34,8 @@ MODULES =					\
   guix/scripts/substitute-binary.scm		\
   guix/base32.scm				\
   guix/utils.scm				\
+  guix/serialization.scm			\
+  guix/nar.scm					\
   guix/derivations.scm				\
   guix/download.scm				\
   guix/gnu-maintenance.scm			\
diff --git a/guix/nar.scm b/guix/nar.scm
new file mode 100644
index 0000000000..b42f03c514
--- /dev/null
+++ b/guix/nar.scm
@@ -0,0 +1,110 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix nar)
+  #:use-module (guix utils)
+  #:use-module (guix serialization)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 ftw)
+  #:export (write-file))
+
+;;; Comment:
+;;;
+;;; Read and write Nix archives, aka. ‘nar’.
+;;;
+;;; Code:
+
+(define (write-contents file p size)
+  "Write SIZE bytes from FILE to output port P."
+  (define (call-with-binary-input-file file proc)
+    ;; Open FILE as a binary file.  This avoids scan-for-encoding, and thus
+    ;; avoids any initial buffering.  Disable file name canonicalization to
+    ;; avoid stat'ing like crazy.
+    (with-fluids ((%file-port-name-canonicalization #f))
+      (let ((port (open-file file "rb")))
+        (catch #t (cut proc port)
+          (lambda args
+            (close-port port)
+            (apply throw args))))))
+
+  (define (dump in size)
+    (define buf-size 65536)
+    (define buf (make-bytevector buf-size))
+
+    (let loop ((left size))
+      (if (<= left 0)
+          0
+          (let ((read (get-bytevector-n! in buf 0 buf-size)))
+            (if (eof-object? read)
+                left
+                (begin
+                  (put-bytevector p buf 0 read)
+                  (loop (- left read))))))))
+
+  (write-string "contents" p)
+  (write-long-long size p)
+  (call-with-binary-input-file file
+    ;; Use `sendfile' when available (Guile 2.0.8+).
+    (if (compile-time-value (defined? 'sendfile))
+        (cut sendfile p <> size 0)
+        (cut dump <> size)))
+  (write-padding size p))
+
+(define (write-file file port)
+  "Write the contents of FILE to PORT in Nar format, recursing into
+sub-directories of FILE as needed."
+  (define %archive-version-1 "nix-archive-1")
+  (define p port)
+
+  (write-string %archive-version-1 p)
+
+  (let dump ((f file))
+    (let ((s (lstat f)))
+      (write-string "(" p)
+      (case (stat:type s)
+        ((regular)
+         (write-string "type" p)
+         (write-string "regular" p)
+         (if (not (zero? (logand (stat:mode s) #o100)))
+             (begin
+               (write-string "executable" p)
+               (write-string "" p)))
+         (write-contents f p (stat:size s)))
+        ((directory)
+         (write-string "type" p)
+         (write-string "directory" p)
+         (let ((entries (remove (cut member <> '("." ".."))
+                                (scandir f))))
+           (for-each (lambda (e)
+                       (let ((f (string-append f "/" e)))
+                         (write-string "entry" p)
+                         (write-string "(" p)
+                         (write-string "name" p)
+                         (write-string e p)
+                         (write-string "node" p)
+                         (dump f)
+                         (write-string ")" p)))
+                     entries)))
+        (else
+         (error "ENOSYS")))
+      (write-string ")" p))))
+
+;;; nar.scm ends here
diff --git a/guix/serialization.scm b/guix/serialization.scm
new file mode 100644
index 0000000000..474dc69de5
--- /dev/null
+++ b/guix/serialization.scm
@@ -0,0 +1,114 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix serialization)
+  #:use-module (guix utils)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (write-int read-int
+            write-long-long read-long-long
+            write-padding
+            write-string read-string read-latin1-string
+            write-string-list read-string-list
+            write-store-path read-store-path
+            write-store-path-list read-store-path-list))
+
+;;; Comment:
+;;;
+;;; Serialization procedures used by the RPCs and the Nar format.  This module
+;;; is for internal consumption.
+;;;
+;;; Code:
+
+;; Similar to serialize.cc in Nix.
+
+(define (write-int n p)
+  (let ((b (make-bytevector 8 0)))
+    (bytevector-u32-set! b 0 n (endianness little))
+    (put-bytevector p b)))
+
+(define (read-int p)
+  (let ((b (get-bytevector-n p 8)))
+    (bytevector-u32-ref b 0 (endianness little))))
+
+(define (write-long-long n p)
+  (let ((b (make-bytevector 8 0)))
+    (bytevector-u64-set! b 0 n (endianness little))
+    (put-bytevector p b)))
+
+(define (read-long-long p)
+  (let ((b (get-bytevector-n p 8)))
+    (bytevector-u64-ref b 0 (endianness little))))
+
+(define write-padding
+  (let ((zero (make-bytevector 8 0)))
+    (lambda (n p)
+      (let ((m (modulo n 8)))
+        (or (zero? m)
+            (put-bytevector p zero 0 (- 8 m)))))))
+
+(define (write-string s p)
+  (let* ((s (string->utf8 s))
+         (l (bytevector-length s))
+         (m (modulo l 8))
+         (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m))))))
+    (bytevector-u32-set! b 0 l (endianness little))
+    (bytevector-copy! s 0 b 8 l)
+    (put-bytevector p b)))
+
+(define (read-string p)
+  (let* ((len (read-int p))
+         (m   (modulo len 8))
+         (bv  (get-bytevector-n p len))
+         (str (utf8->string bv)))
+    (or (zero? m)
+        (get-bytevector-n p (- 8 m)))
+    str))
+
+(define (read-latin1-string p)
+  (let* ((len (read-int p))
+         (m   (modulo len 8))
+         (str (get-string-n p len)))
+    (or (zero? m)
+        (get-bytevector-n p (- 8 m)))
+    str))
+
+(define (write-string-list l p)
+  (write-int (length l) p)
+  (for-each (cut write-string <> p) l))
+
+(define (read-string-list p)
+  (let ((len (read-int p)))
+    (unfold (cut >= <> len)
+            (lambda (i)
+              (read-string p))
+            1+
+            0)))
+
+(define (write-store-path f p)
+  (write-string f p))                             ; TODO: assert path
+
+(define (read-store-path p)
+  (read-string p))                                ; TODO: assert path
+
+(define write-store-path-list write-string-list)
+(define read-store-path-list read-string-list)
+
+;;; serialization.scm ends here
diff --git a/guix/store.scm b/guix/store.scm
index de9785c835..cc21af84e4 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -17,8 +17,10 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix store)
+  #:use-module (guix nar)
   #:use-module (guix utils)
   #:use-module (guix config)
+  #:use-module (guix serialization)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-1)
@@ -29,7 +31,6 @@
   #:use-module (srfi srfi-39)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 ftw)
   #:use-module (ice-9 regex)
   #:export (%daemon-socket-file
 
@@ -161,152 +162,6 @@
 
 
 
-;; serialize.cc
-
-(define (write-int n p)
-  (let ((b (make-bytevector 8 0)))
-    (bytevector-u32-set! b 0 n (endianness little))
-    (put-bytevector p b)))
-
-(define (read-int p)
-  (let ((b (get-bytevector-n p 8)))
-    (bytevector-u32-ref b 0 (endianness little))))
-
-(define (write-long-long n p)
-  (let ((b (make-bytevector 8 0)))
-    (bytevector-u64-set! b 0 n (endianness little))
-    (put-bytevector p b)))
-
-(define (read-long-long p)
-  (let ((b (get-bytevector-n p 8)))
-    (bytevector-u64-ref b 0 (endianness little))))
-
-(define write-padding
-  (let ((zero (make-bytevector 8 0)))
-    (lambda (n p)
-      (let ((m (modulo n 8)))
-        (or (zero? m)
-            (put-bytevector p zero 0 (- 8 m)))))))
-
-(define (write-string s p)
-  (let* ((s (string->utf8 s))
-         (l (bytevector-length s))
-         (m (modulo l 8))
-         (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m))))))
-    (bytevector-u32-set! b 0 l (endianness little))
-    (bytevector-copy! s 0 b 8 l)
-    (put-bytevector p b)))
-
-(define (read-string p)
-  (let* ((len (read-int p))
-         (m   (modulo len 8))
-         (bv  (get-bytevector-n p len))
-         (str (utf8->string bv)))
-    (or (zero? m)
-        (get-bytevector-n p (- 8 m)))
-    str))
-
-(define (read-latin1-string p)
-  (let* ((len (read-int p))
-         (m   (modulo len 8))
-         (str (get-string-n p len)))
-    (or (zero? m)
-        (get-bytevector-n p (- 8 m)))
-    str))
-
-(define (write-string-list l p)
-  (write-int (length l) p)
-  (for-each (cut write-string <> p) l))
-
-(define (read-string-list p)
-  (let ((len (read-int p)))
-    (unfold (cut >= <> len)
-            (lambda (i)
-              (read-string p))
-            1+
-            0)))
-
-(define (write-store-path f p)
-  (write-string f p))                             ; TODO: assert path
-
-(define (read-store-path p)
-  (read-string p))                                ; TODO: assert path
-
-(define write-store-path-list write-string-list)
-(define read-store-path-list read-string-list)
-
-(define (write-contents file p size)
-  "Write SIZE bytes from FILE to output port P."
-  (define (call-with-binary-input-file file proc)
-    ;; Open FILE as a binary file.  This avoids scan-for-encoding, and thus
-    ;; avoids any initial buffering.  Disable file name canonicalization to
-    ;; avoid stat'ing like crazy.
-    (with-fluids ((%file-port-name-canonicalization #f))
-      (let ((port (open-file file "rb")))
-        (catch #t (cut proc port)
-          (lambda args
-            (close-port port)
-            (apply throw args))))))
-
-  (define (dump in size)
-    (define buf-size 65536)
-    (define buf (make-bytevector buf-size))
-
-    (let loop ((left size))
-      (if (<= left 0)
-          0
-          (let ((read (get-bytevector-n! in buf 0 buf-size)))
-            (if (eof-object? read)
-                left
-                (begin
-                  (put-bytevector p buf 0 read)
-                  (loop (- left read))))))))
-
-  (write-string "contents" p)
-  (write-long-long size p)
-  (call-with-binary-input-file file
-    ;; Use `sendfile' when available (Guile 2.0.8+).
-    (if (compile-time-value (defined? 'sendfile))
-        (cut sendfile p <> size 0)
-        (cut dump <> size)))
-  (write-padding size p))
-
-(define (write-file f p)
-  (define %archive-version-1 "nix-archive-1")
-
-  (write-string %archive-version-1 p)
-
-  (let dump ((f f))
-    (let ((s (lstat f)))
-      (write-string "(" p)
-      (case (stat:type s)
-        ((regular)
-         (write-string "type" p)
-         (write-string "regular" p)
-         (if (not (zero? (logand (stat:mode s) #o100)))
-             (begin
-               (write-string "executable" p)
-               (write-string "" p)))
-         (write-contents f p (stat:size s)))
-        ((directory)
-         (write-string "type" p)
-         (write-string "directory" p)
-         (let ((entries (remove (cut member <> '("." ".."))
-                                (scandir f))))
-           (for-each (lambda (e)
-                       (let ((f (string-append f "/" e)))
-                         (write-string "entry" p)
-                         (write-string "(" p)
-                         (write-string "name" p)
-                         (write-string e p)
-                         (write-string "node" p)
-                         (dump f)
-                         (write-string ")" p)))
-                     entries)))
-        (else
-         (error "ENOSYS")))
-      (write-string ")" p))))
-
 ;; Information about a substitutable store path.
 (define-record-type <substitutable>
   (substitutable path deriver refs dl-size nar-size)

From 4f7d8d7ee4c3a2f92cd12d7e1e2a03725f406012 Mon Sep 17 00:00:00 2001
From: Cyril Roelandt <tipecaml@gmail.com>
Date: Sat, 6 Apr 2013 00:28:39 +0200
Subject: [PATCH 10/74] gnu: Python: fix the compilation of some modules from
 the standard library.

This commit enables the bz2, dbm, readline, ssl and zlib modules.

* gnu/packages/gdbm.scm: Enable the compatibility mode.
* gnu/packages/python.scm: Enable a few modules from the standard library.
* gnu/packages/patches/python-fix-dbm.patch: New file.
* Makefile.am: Add it.
---
 Makefile.am                               |  1 +
 gnu/packages/gdbm.scm                     |  1 +
 gnu/packages/patches/python-fix-dbm.patch | 20 ++++++++++++++
 gnu/packages/python.scm                   | 33 ++++++++++++++++++++---
 4 files changed, 52 insertions(+), 3 deletions(-)
 create mode 100644 gnu/packages/patches/python-fix-dbm.patch

diff --git a/Makefile.am b/Makefile.am
index 136c01bf3f..91de488380 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -229,6 +229,7 @@ dist_patch_DATA =						\
   gnu/packages/patches/make-impure-dirs.patch			\
   gnu/packages/patches/mcron-install.patch			\
   gnu/packages/patches/perl-no-sys-dirs.patch			\
+  gnu/packages/patches/python-fix-dbm.patch			\
   gnu/packages/patches/procps-make-3.82.patch			\
   gnu/packages/patches/qemu-multiple-smb-shares.patch		\
   gnu/packages/patches/readline-link-ncurses.patch		\
diff --git a/gnu/packages/gdbm.scm b/gnu/packages/gdbm.scm
index 588b732b02..76733dba65 100644
--- a/gnu/packages/gdbm.scm
+++ b/gnu/packages/gdbm.scm
@@ -34,6 +34,7 @@
       (sha256
        (base32
         "0h9lfzdjc2yl849y0byg51h6xfjg0y7vg9jnsw3gpfwlbd617y13"))))
+    (arguments `(#:configure-flags '("--enable-libgdbm-compat")))
     (build-system gnu-build-system)
     (home-page "http://www.gnu.org/software/gdbm/")
     (synopsis "GNU dbm key/value database library")
diff --git a/gnu/packages/patches/python-fix-dbm.patch b/gnu/packages/patches/python-fix-dbm.patch
new file mode 100644
index 0000000000..29e4521f3f
--- /dev/null
+++ b/gnu/packages/patches/python-fix-dbm.patch
@@ -0,0 +1,20 @@
+This patch allows the dbm module to be built using the compatibility mode of
+gdbm. It will not be needed any more with Python 2.7.4.
+--- setup.py	2013-04-06 00:53:37.000000000 +0200
++++ setup.py.new	2013-04-06 19:55:05.000000000 +0200
+@@ -1158,10 +1158,14 @@
+             for cand in dbm_order:
+                 if cand == "ndbm":
+                     if find_file("ndbm.h", inc_dirs, []) is not None:
+-                        # Some systems have -lndbm, others don't
++                        # Some systems have -lndbm, some have -lgdbm_compat,
++                        # others have no particular linker flags.
+                         if self.compiler.find_library_file(lib_dirs,
+                                                                'ndbm'):
+                             ndbm_libs = ['ndbm']
++                        elif self.compiler.find_library_file(lib_dirs,
++                                                             'gdbm_compat'):
++                            ndbm_libs = ['gdbm_compat']
+                         else:
+                             ndbm_libs = []
+                         print "building dbm using ndbm"
diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm
index 52b11e4197..3f941642fc 100644
--- a/gnu/packages/python.scm
+++ b/gnu/packages/python.scm
@@ -19,7 +19,10 @@
 
 (define-module (gnu packages python)
   #:use-module ((guix licenses) #:select (psfl))
+  #:use-module (gnu packages)
   #:use-module (gnu packages compression)
+  #:use-module (gnu packages gdbm)
+  #:use-module (gnu packages readline)
   #:use-module (gnu packages openssl)
   #:use-module (guix packages)
   #:use-module (guix download)
@@ -38,11 +41,35 @@
        (base32
         "11f9aw855lrmknr6c82gm1ijr3n0smc6idyp94y7774yivjnplv1"))))
     (build-system gnu-build-system)
-    (arguments `(#:tests? #f)) ; XXX: some tests fail
+    (arguments
+     `(#:tests? #f ; XXX: some tests fail
+       #:patches (list (assoc-ref %build-inputs "patch-dbm"))
+       #:patch-flags '("-p0")
+       #:configure-flags
+        (let ((bz2 (assoc-ref %build-inputs "bzip2"))
+              (gdbm (assoc-ref %build-inputs "gdbm"))
+              (openssl (assoc-ref %build-inputs "openssl"))
+              (readline (assoc-ref %build-inputs "readline"))
+              (zlib (assoc-ref %build-inputs "zlib")))
+         (list (string-append "CPPFLAGS="
+                "-I" bz2 "/include "
+                "-I" gdbm "/include "
+                "-I" openssl "/include "
+                "-I" readline "/include "
+                "-I" zlib "/include")
+               (string-append "LDFLAGS="
+                "-L" bz2 "/lib "
+                "-L" gdbm "/lib "
+                "-L" openssl "/lib "
+                "-L" readline "/lib "
+                "-L" zlib "/lib")))))
     (inputs
-     `(("zlib" ,zlib)
+     `(("bzip2" ,bzip2)
+       ("gdbm" ,gdbm)
        ("openssl" ,openssl)
-       ("bzip2" ,bzip2)))
+       ("readline" ,readline)
+       ("zlib" ,zlib)
+       ("patch-dbm" ,(search-patch "python-fix-dbm.patch"))))
     (home-page "http://python.org")
     (synopsis
      "Python, a high-level dynamically-typed programming language")

From cbca6eb55298a7205ca3533957ff2e3857140f40 Mon Sep 17 00:00:00 2001
From: Nikita Karetnikov <nikita@karetnikov.org>
Date: Fri, 5 Apr 2013 23:08:44 +0000
Subject: [PATCH 11/74] gnu: shishi: Update to 1.0.2.

* gnu/packages/shishi.scm (shishi): Update to 1.0.2.
* gnu/packages/patches/shishi-gets-undeclared.patch: Remove it.
* Makefile.am (dist_patch_DATA): Adjust accordingly.
---
 Makefile.am                                   |  1 -
 .../patches/shishi-gets-undeclared.patch      | 71 -------------------
 gnu/packages/shishi.scm                       | 46 +++++-------
 3 files changed, 16 insertions(+), 102 deletions(-)
 delete mode 100644 gnu/packages/patches/shishi-gets-undeclared.patch

diff --git a/Makefile.am b/Makefile.am
index 91de488380..a8bd2f8daf 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -233,7 +233,6 @@ dist_patch_DATA =						\
   gnu/packages/patches/procps-make-3.82.patch			\
   gnu/packages/patches/qemu-multiple-smb-shares.patch		\
   gnu/packages/patches/readline-link-ncurses.patch		\
-  gnu/packages/patches/shishi-gets-undeclared.patch		\
   gnu/packages/patches/tar-gets-undeclared.patch		\
   gnu/packages/patches/tcsh-fix-autotest.patch			\
   gnu/packages/patches/teckit-cstdio.patch			\
diff --git a/gnu/packages/patches/shishi-gets-undeclared.patch b/gnu/packages/patches/shishi-gets-undeclared.patch
deleted file mode 100644
index a3d6d0cca2..0000000000
--- a/gnu/packages/patches/shishi-gets-undeclared.patch
+++ /dev/null
@@ -1,71 +0,0 @@
-This patch is needed to allow builds with newer versions of
-the GNU libc (2.16+).
-
-
-commit 66712c23388e93e5c518ebc8515140fa0c807348
-Author: Eric Blake <eblake@redhat.com>
-Date:   Thu Mar 29 13:30:41 2012 -0600
-
-    stdio: don't assume gets any more
-    
-    Gnulib intentionally does not have a gets module, and now that C11
-    and glibc have dropped it, we should be more proactive about warning
-    any user on a platform that still has a declaration of this dangerous
-    interface.
-    
-    * m4/stdio_h.m4 (gl_STDIO_H, gl_STDIO_H_DEFAULTS): Drop gets
-    support.
-    * modules/stdio (Makefile.am): Likewise.
-    * lib/stdio-read.c (gets): Likewise.
-    * tests/test-stdio-c++.cc: Likewise.
-    * m4/warn-on-use.m4 (gl_WARN_ON_USE_PREPARE): Fix comment.
-    * lib/stdio.in.h (gets): Make warning occur in more places.
-    * doc/posix-functions/gets.texi (gets): Update documentation.
-    Reported by Christer Solskogen.
-    
-    Signed-off-by: Eric Blake <eblake@redhat.com>
-
-diff --git a/gl/stdio.in.h b/gl/stdio.in.h
-index aa7b599..c377b6e 100644
---- a/gl/stdio.in.h
-+++ b/gl/stdio.in.h
-@@ -698,22 +698,11 @@ _GL_WARN_ON_USE (getline, "getline is unportable - "
- # endif
- #endif
- 
--#if @GNULIB_GETS@
--# if @REPLACE_STDIO_READ_FUNCS@ && @GNULIB_STDIO_H_NONBLOCKING@
--#  if !(defined __cplusplus && defined GNULIB_NAMESPACE)
--#   undef gets
--#   define gets rpl_gets
--#  endif
--_GL_FUNCDECL_RPL (gets, char *, (char *s) _GL_ARG_NONNULL ((1)));
--_GL_CXXALIAS_RPL (gets, char *, (char *s));
--# else
--_GL_CXXALIAS_SYS (gets, char *, (char *s));
--#  undef gets
--# endif
--_GL_CXXALIASWARN (gets);
- /* It is very rare that the developer ever has full control of stdin,
--   so any use of gets warrants an unconditional warning.  Assume it is
--   always declared, since it is required by C89.  */
-+   so any use of gets warrants an unconditional warning; besides, C11
-+   removed it.  */
-+#undef gets
-+#if HAVE_RAW_DECL_GETS
- _GL_WARN_ON_USE (gets, "gets is a security hole - use fgets instead");
- #endif
- 
-@@ -1053,9 +1042,9 @@ _GL_WARN_ON_USE (snprintf, "snprintf is unportable - "
- # endif
- #endif
- 
--/* Some people would argue that sprintf should be handled like gets
--   (for example, OpenBSD issues a link warning for both functions),
--   since both can cause security holes due to buffer overruns.
-+/* Some people would argue that all sprintf uses should be warned about
-+   (for example, OpenBSD issues a link warning for it),
-+   since it can cause security holes due to buffer overruns.
-    However, we believe that sprintf can be used safely, and is more
-    efficient than snprintf in those safe cases; and as proof of our
-    belief, we use sprintf in several gnulib modules.  So this header
diff --git a/gnu/packages/shishi.scm b/gnu/packages/shishi.scm
index 1590221496..767037a580 100644
--- a/gnu/packages/shishi.scm
+++ b/gnu/packages/shishi.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -18,12 +18,11 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu packages shishi)
-  #:use-module (guix licenses)
+  #:use-module ((guix licenses) #:select (gpl3+))
   #:use-module (gnu packages)
   #:use-module (gnu packages gnutls)
   #:use-module (gnu packages gnupg)
-  #:use-module ((gnu packages compression)
-                #:renamer (symbol-prefix-proc 'guix:))
+  #:use-module (gnu packages compression)
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix build-system gnu))
@@ -31,41 +30,28 @@
 (define-public shishi
   (package
     (name "shishi")
-    (version "1.0.1")
+    (version "1.0.2")
     (source
      (origin
       (method url-fetch)
-      (uri (string-append
-            "mirror://gnu/shishi/shishi-"
-            version
-            ".tar.gz"))
+      (uri (string-append "mirror://gnu/shishi/shishi-"
+                          version ".tar.gz"))
       (sha256
        (base32
-        "13c6w9rpaqb3am65nrn86byvmll5r78pld2vb0i68491vww4fzlx"))))
+        "032qf72cpjdfffq1yq54gz3ahgqf2ijca4vl31sfabmjzq9q370d"))))
     (build-system gnu-build-system)
-    (arguments
-     `(#:make-flags
-       '("CPPFLAGS=-DMAX_ERROR_DESCRIPTION_SIZE=ASN1_MAX_ERROR_DESCRIPTION_SIZE")
-       #:patches (list (assoc-ref %build-inputs
-                                  "patch/gets"))))
     (inputs
      `(("gnutls" ,gnutls)
-       ("zlib" ,guix:zlib)
+       ("zlib" ,zlib)
        ("libgcrypt" ,libgcrypt)
-       ("libtasn1" ,libtasn1)
-       ("patch/gets" ,(search-patch "shishi-gets-undeclared.patch"))))
+       ("libtasn1" ,libtasn1)))
     (home-page "http://www.gnu.org/software/shishi/")
     (synopsis
-     "GNU Shishi, free implementation of the Kerberos 5 network security system")
+     "GNU Shishi, an implementation of the Kerberos 5 network security system")
     (description
-     " GNU Shishi is an implementation of the Kerberos 5 network
-  authentication system, as specified in RFC 4120.  Shishi can be
-  used to authenticate users in distributed systems.
-
-  Shishi contains a library (`libshishi') that can be used by
-  application developers to add support for Kerberos 5.  Shishi
-  contains a command line utility (1shishi') that is used by
-  users to acquire and manage tickets (and more).  The server
-  side, a Key Distribution Center, is implemented by `shishid'.
-")
-    (license gpl3+))) ; some files are under GPLv2+
+     "Shishi contains a library ('libshishi') that can be used by application
+developers to add support for Kerberos 5.  Shishi contains a command line
+utility ('shishi') that is used by users to acquire and manage tickets (and
+more).  The server side, a Key Distribution Center (KDC), is implemented by
+'shishid', and support X.509 authenticated TLS via GnuTLS.")
+    (license gpl3+)))

From 52e5910cdc0275cbc668682346172be2673d150d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 30 Mar 2013 21:49:17 +0100
Subject: [PATCH 12/74] build: Pass the appropriate flags when building
 `libstore.a'.

* daemon.am (libstore_a_CFLAGS): Rename to...
  (libstore_a_CXXFLAGS): ... this.
---
 daemon.am | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/daemon.am b/daemon.am
index 1d4d955a0c..069700b1b6 100644
--- a/daemon.am
+++ b/daemon.am
@@ -115,7 +115,7 @@ libstore_a_CPPFLAGS =				\
   -DNIX_BIN_DIR=\"$(bindir)\"			\
   -DOPENSSL_PATH="\"openssl\""
 
-libstore_a_CFLAGS =				\
+libstore_a_CXXFLAGS =				\
   $(SQLITE3_CFLAGS) $(LIBGCRYPT_CFLAGS)
 
 bin_PROGRAMS = guix-daemon

From 53c63ee93790e4e4054bf6547199d3490b78bf47 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 8 Apr 2013 22:54:08 +0200
Subject: [PATCH 13/74] nar: Implement restoration from Nar.

* guix/nar.scm (&nar-error, &nar-read-error): New condition types.
  (dump): New procedure.
  (write-contents)[dump]: Remove.  Use the one above instead.
  (read-contents, write-file, restore-file): New procedures.
  (%archive-version-1): New variable.
---
 Makefile.am   |   1 +
 guix/nar.scm  | 150 ++++++++++++++++++++++++++++++++++++++++++++------
 tests/nar.scm |  95 ++++++++++++++++++++++++++++++++
 3 files changed, 228 insertions(+), 18 deletions(-)
 create mode 100644 tests/nar.scm

diff --git a/Makefile.am b/Makefile.am
index a8bd2f8daf..930ea6ce72 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -296,6 +296,7 @@ TESTS =						\
   tests/packages.scm				\
   tests/snix.scm				\
   tests/store.scm				\
+  tests/nar.scm					\
   tests/union.scm				\
   tests/guix-build.sh				\
   tests/guix-download.sh			\
diff --git a/guix/nar.scm b/guix/nar.scm
index b42f03c514..9ae76ff2a9 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -19,12 +19,23 @@
 (define-module (guix nar)
   #:use-module (guix utils)
   #:use-module (guix serialization)
+  #:use-module ((guix build utils) #:select (with-directory-excursion))
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 ftw)
-  #:export (write-file))
+  #:use-module (ice-9 match)
+  #:export (nar-error?
+            nar-read-error?
+            nar-read-error-file
+            nar-read-error-port
+            nar-read-error-token
+
+            write-file
+            restore-file))
 
 ;;; Comment:
 ;;;
@@ -32,6 +43,31 @@
 ;;;
 ;;; Code:
 
+(define-condition-type &nar-error &error      ; XXX: inherit from &nix-error ?
+  nar-error?)
+
+(define-condition-type &nar-read-error &nar-error
+  nar-read-error?
+  (port  nar-read-error-port)                   ; port from which we read
+  (file  nar-read-error-file)                   ; file we were restoring, or #f
+  (token nar-read-error-token))                 ; faulty token, or #f
+
+
+(define (dump in out size)
+  "Copy SIZE bytes from IN to OUT."
+  (define buf-size 65536)
+  (define buf (make-bytevector buf-size))
+
+  (let loop ((left size))
+    (if (<= left 0)
+        0
+        (let ((read (get-bytevector-n! in buf 0 (min left buf-size))))
+          (if (eof-object? read)
+              left
+              (begin
+                (put-bytevector out buf 0 read)
+                (loop (- left read))))))))
+
 (define (write-contents file p size)
   "Write SIZE bytes from FILE to output port P."
   (define (call-with-binary-input-file file proc)
@@ -45,33 +81,55 @@
             (close-port port)
             (apply throw args))))))
 
-  (define (dump in size)
-    (define buf-size 65536)
-    (define buf (make-bytevector buf-size))
-
-    (let loop ((left size))
-      (if (<= left 0)
-          0
-          (let ((read (get-bytevector-n! in buf 0 buf-size)))
-            (if (eof-object? read)
-                left
-                (begin
-                  (put-bytevector p buf 0 read)
-                  (loop (- left read))))))))
-
   (write-string "contents" p)
   (write-long-long size p)
   (call-with-binary-input-file file
     ;; Use `sendfile' when available (Guile 2.0.8+).
     (if (compile-time-value (defined? 'sendfile))
         (cut sendfile p <> size 0)
-        (cut dump <> size)))
+        (cut dump <> p size)))
   (write-padding size p))
 
+(define (read-contents in out)
+  "Read the contents of a file from the Nar at IN, write it to OUT, and return
+the size in bytes."
+  (define executable?
+    (match (read-string in)
+      ("contents"
+       #f)
+      ("executable"
+       (match (list (read-string in) (read-string in))
+         (("" "contents") #t)
+         (x (raise
+             (condition (&message
+                         (message "unexpected executable file marker"))
+                        (&nar-read-error (port in)
+                                         (file #f)
+                                         (token x))))))
+       #t)
+      (x
+       (raise
+        (condition (&message (message "unsupported nar file type"))
+                   (&nar-read-error (port in) (file #f) (token x)))))))
+
+  (let ((size (read-long-long in)))
+    ;; Note: `sendfile' cannot be used here because of port buffering on IN.
+    (dump in out size)
+
+    (when executable?
+      (chmod out #o755))
+    (let ((m (modulo size 8)))
+      (unless (zero? m)
+        (get-bytevector-n in (- 8 m))))
+    size))
+
+(define %archive-version-1
+  ;; Magic cookie for Nix archives.
+  "nix-archive-1")
+
 (define (write-file file port)
   "Write the contents of FILE to PORT in Nar format, recursing into
 sub-directories of FILE as needed."
-  (define %archive-version-1 "nix-archive-1")
   (define p port)
 
   (write-string %archive-version-1 p)
@@ -104,7 +162,63 @@ sub-directories of FILE as needed."
                          (write-string ")" p)))
                      entries)))
         (else
-         (error "ENOSYS")))
+         (raise (condition (&message (message "ENOSYS"))
+                           (&nar-error)))))
       (write-string ")" p))))
 
+(define (restore-file port file)
+  "Read a file (possibly a directory structure) in Nar format from PORT.
+Restore it as FILE."
+  (let ((signature (read-string port)))
+    (unless (equal? signature %archive-version-1)
+      (raise
+       (condition (&message (message "invalid nar signature"))
+                  (&nar-read-error (port port)
+                                   (token signature)
+                                   (file #f))))))
+
+  (let restore ((file file))
+    (match (list (read-string port) (read-string port) (read-string port))
+      (("(" "type" "regular")
+       (call-with-output-file file (cut read-contents port <>))
+       (match (read-string port)
+         (")" #t)
+         (x (raise
+             (condition
+              (&message (message "invalid nar end-of-file marker"))
+              (&nar-read-error (port port) (file file) (token x)))))))
+      (("(" "type" "directory")
+       (let ((dir file))
+         (mkdir dir)
+         (let loop ((prefix (read-string port)))
+           (match prefix
+             ("entry"
+              (match (list (read-string port)
+                           (read-string port) (read-string port)
+                           (read-string port))
+                (("(" "name" file "node")
+                 (restore (string-append dir "/" file))
+                 (match (read-string port)
+                   (")" #t)
+                   (x
+                    (raise
+                     (condition
+                      (&message
+                       (message "unexpected directory entry termination"))
+                      (&nar-read-error (port port)
+                                       (file file)
+                                       (token x))))))
+                 (loop (read-string port)))))
+             (")" #t)                             ; done with DIR
+             (x
+              (raise
+               (condition
+                (&message (message "unexpected directory inter-entry marker"))
+                (&nar-read-error (port port) (file file) (token x)))))))))
+      (x
+       (raise
+        (condition
+         (&message (message "unsupported nar entry type"))
+         (&nar-read-error (port port) (file file) (token x))))))))
+
 ;;; nar.scm ends here
diff --git a/tests/nar.scm b/tests/nar.scm
new file mode 100644
index 0000000000..2d9bffd487
--- /dev/null
+++ b/tests/nar.scm
@@ -0,0 +1,95 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-nar)
+  #:use-module (guix nar)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-64)
+  #:use-module (ice-9 ftw))
+
+;; Test the (guix nar) module.
+
+(define (rm-rf dir)
+  (file-system-fold (const #t)                    ; enter?
+                    (lambda (file stat result)    ; leaf
+                      (delete-file file))
+                    (const #t)                    ; down
+                    (lambda (dir stat result)     ; up
+                      (rmdir dir))
+                    (const #t)                    ; skip
+                    (const #t)                    ; error
+                    #t
+                    dir
+                    lstat))
+
+
+(test-begin "nar")
+
+(test-assert "write-file + restore-file"
+  (let* ((input  (string-append (dirname (search-path %load-path "guix.scm"))
+                                "/guix"))
+         (output (string-append (dirname input)
+                                "/test-nar-"
+                                (number->string (getpid))))
+         (nar    (string-append output ".nar")))
+    (dynamic-wind
+      (lambda () #t)
+      (lambda ()
+        (call-with-output-file nar
+          (cut write-file input <>))
+        (call-with-input-file nar
+          (cut restore-file <> output))
+        (let* ((strip   (cute string-drop <> (string-length input)))
+               (sibling (compose (cut string-append output <>) strip))
+               (file=?  (lambda (a b)
+                          (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
+                               (case (stat:type (lstat a))
+                                 ((regular)
+                                  (equal?
+                                   (call-with-input-file a get-bytevector-all)
+                                   (call-with-input-file b get-bytevector-all)))
+                                 ((symlink)
+                                  (string=? (readlink a) (readlink b)))
+                                 (else
+                                  (error "what?" (lstat a))))))))
+          (file-system-fold (const #t)
+                            (lambda (name stat result) ; leaf
+                              (and result
+                                   (file=? name (sibling name))))
+                            (lambda (name stat result) ; down
+                              result)
+                            (lambda (name stat result) ; up
+                              result)
+                            (const #f)                 ; skip
+                            (lambda (name stat errno result)
+                              (pk 'error name stat errno)
+                              #f)
+                            (> (stat:nlink (stat output)) 2)
+                            input
+                            lstat)))
+      (lambda ()
+        (false-if-exception (delete-file nar))
+        (false-if-exception (rm-rf output))
+        ))))
+
+(test-end "nar")
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))

From a2011be5dfaf2b94a1d0e3dfbcf4b512389b4711 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 11 Apr 2013 22:30:06 +0200
Subject: [PATCH 14/74] ui: Add a `warning' macro.

* guix/ui.scm (program-name, guix-warning-port): New variables.
  (warning): New macro.
  (guix-main): Parametrize PROGRAM-NAME.
* guix/scripts/build.scm, guix/scripts/download.scm,
  guix/scripts/gc.scm, guix/scripts/package.scm: Adjust to use `leave'
  and `warning' consistently.
---
 guix/scripts/build.scm    | 16 +++++--------
 guix/scripts/download.scm |  3 +--
 guix/scripts/gc.scm       | 15 ++++--------
 guix/scripts/package.scm  | 20 +++++++---------
 guix/ui.scm               | 49 +++++++++++++++++++++++++++++++++++----
 5 files changed, 64 insertions(+), 39 deletions(-)

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index a49bfdbeb8..339ad0d06f 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -176,9 +176,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
                   0
                   paths))))
        (lambda args
-         (format (current-error-port)
-                 (_ "failed to create GC root `~a': ~a~%")
-                 root (strerror (system-error-errno args)))
+         (leave (_ "failed to create GC root `~a': ~a~%")
+                root (strerror (system-error-errno args)))
          (exit 1)))))
 
   (define newest-available-packages
@@ -202,13 +201,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
         ((p)                                      ; one match
          p)
         ((p x ...)                                ; several matches
-         (format (current-error-port)
-                 (_ "warning: ambiguous package specification `~a'~%")
-                 request)
-         (format (current-error-port)
-                 (_ "warning: choosing ~a from ~a~%")
-                 (package-full-name p)
-                 (location->string (package-location p)))
+         (warning (_ "ambiguous package specification `~a'~%") request)
+         (warning (_ "choosing ~a from ~a~%")
+                  (package-full-name p)
+                  (location->string (package-location p)))
          p)
         (_                                        ; no matches
          (if version
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index 3f989a3494..7c00312c74 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -81,8 +81,7 @@ and the hash of its contents.\n"))
                       ((or "base16" "hex" "hexadecimal")
                        bytevector->base16-string)
                       (x
-                       (format (current-error-port)
-                               "unsupported hash format: ~a~%" arg))))
+                       (leave (_ "unsupported hash format: ~a~%") arg))))
 
                   (alist-cons 'format fmt-proc
                               (alist-delete 'format result))))
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 12d80fd171..3d918923f8 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -87,13 +87,9 @@ interpreted."
              ("TB"  (expt 10 12))
              (""    1)
              (_
-              (format (current-error-port) (_ "error: unknown unit: ~a~%")
-                      unit)
+              (leave (_ "error: unknown unit: ~a~%") unit)
               (exit 1))))
-        (begin
-          (format (current-error-port)
-                  (_ "error: invalid number: ~a") numstr)
-          (exit 1)))))
+        (leave (_ "error: invalid number: ~a") numstr))))
 
 (define %options
   ;; Specification of the command-line options.
@@ -114,11 +110,8 @@ interpreted."
                       (let ((amount (size->number arg)))
                         (if arg
                             (alist-cons 'min-freed amount result)
-                            (begin
-                              (format (current-error-port)
-                                      (_ "error: invalid amount of storage: ~a~%")
-                                      arg)
-                              (exit 1)))))
+                            (leave (_ "error: invalid amount of storage: ~a~%")
+                                   arg))))
                      (#f result)))))
         (option '(#\d "delete") #f #f
                 (lambda (opt name arg result)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 6de2f1beb6..89708ccc49 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -208,12 +208,10 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
       (switch-symlinks profile previous-profile))
 
     (cond ((not (file-exists? profile))           ; invalid profile
-           (format (current-error-port)
-                   (_ "error: profile `~a' does not exist~%")
-                   profile))
+           (leave (_ "error: profile `~a' does not exist~%")
+                  profile))
           ((zero? number)                         ; empty profile
-           (format (current-error-port)
-                   (_ "nothing to do: already at the empty profile~%")))
+           (leave (_ "nothing to do: already at the empty profile~%")))
           ((or (zero? previous-number)            ; going to emptiness
                (not (file-exists? previous-profile)))
            (let*-values (((drv-path drv)
@@ -465,13 +463,11 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
          (list name (package-version p) sub-drv (ensure-output p sub-drv)
                (package-transitive-propagated-inputs p)))
         ((p p* ...)
-         (format (current-error-port)
-                 (_ "warning: ambiguous package specification `~a'~%")
-                 request)
-         (format (current-error-port)
-                 (_ "warning: choosing ~a from ~a~%")
-                 (package-full-name p)
-                 (location->string (package-location p)))
+         (warning (_ "ambiguous package specification `~a'~%")
+                  request)
+         (warning (_ "choosing ~a from ~a~%")
+                  (package-full-name p)
+                  (location->string (package-location p)))
          (list name (package-version p) sub-drv (ensure-output p sub-drv)
                (package-transitive-propagated-inputs p)))
         (()
diff --git a/guix/ui.scm b/guix/ui.scm
index 94f0825a0a..dfb6418a10 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -47,6 +47,9 @@
             string->recutils
             package->recutils
             run-guix-command
+            program-name
+            guix-warning-port
+            warning
             guix-main))
 
 ;;; Commentary:
@@ -332,6 +335,43 @@ WIDTH columns."
                                    (symbol-append 'guix- command))))
     (apply command-main args)))
 
+(define program-name
+  ;; Name of the command-line program currently executing, or #f.
+  (make-parameter #f))
+
+(define guix-warning-port
+  (make-parameter (current-warning-port)))
+
+(define-syntax warning
+  (lambda (s)
+    "Emit a warming.  The macro assumes that `_' is bound to `gettext'."
+    ;; All this just to preserve `-Wformat' warnings.  Too much?
+
+    (define (augmented-format-string fmt)
+      (string-append "~:[~;guix ~a: ~]~a" (syntax->datum fmt)))
+
+    (define prefix
+      #'(_ "warning: "))
+
+    (syntax-case s (N_ _)                        ; these are literals, yeah...
+      ((warning (_ fmt) args ...)
+       (string? (syntax->datum #'fmt))
+       (with-syntax ((fmt*   (augmented-format-string #'fmt))
+                     (prefix prefix))
+         #'(format (guix-warning-port) (gettext fmt*)
+                   (program-name) (program-name) prefix
+                   args ...)))
+      ((warning (N_ singular plural n) args ...)
+       (and (string? (syntax->datum #'singular))
+            (string? (syntax->datum #'plural)))
+       (with-syntax ((s (augmented-format-string #'singular))
+                     (p (augmented-format-string #'plural))
+                     (b prefix))
+         #'(format (guix-warning-port)
+                   (ngettext s p n %gettext-domain)
+                   (program-name) (program-name) b
+                   args ...))))))
+
 (define (guix-main arg0 . args)
   (initialize-guix)
   (let ()
@@ -340,10 +380,11 @@ WIDTH columns."
       (() (show-guix-usage) (exit 1))
       (("--help") (show-guix-usage))
       (("--version") (show-version-and-exit "guix"))
-      (((? option? arg1) args ...) (show-guix-usage) (exit 1))
+      (((? option?) args ...) (show-guix-usage) (exit 1))
       ((command args ...)
-       (apply run-guix-command
-              (string->symbol command)
-              args)))))
+       (parameterize ((program-name command))
+         (apply run-guix-command
+                (string->symbol command)
+                args))))))
 
 ;;; ui.scm ends here

From 8f3114b7a433480c9534903d23d659ce3fb12ffb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 12 Apr 2013 14:35:01 +0200
Subject: [PATCH 15/74] nar: Add support for symlinks.

* guix/nar.scm (write-file): Add case for type `symlink'.
  (restore-file): Likewise.
* tests/nar.scm (random-file-size, make-file-tree, delete-file-tree,
  with-file-tree, file-tree-equal?, make-random-bytevector,
  populate-file): New procedures.
  (%test-dir): New variable.
  ("write-file + restore-file"): Use `%test-dir' and `file-tree-equal?'.
  ("write-file + restore-file with symlinks"): New test.
---
 guix/nar.scm  |  23 ++++++-
 tests/nar.scm | 183 ++++++++++++++++++++++++++++++++++++++++----------
 2 files changed, 169 insertions(+), 37 deletions(-)

diff --git a/guix/nar.scm b/guix/nar.scm
index 9ae76ff2a9..29b57dc989 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -161,6 +161,11 @@ sub-directories of FILE as needed."
                          (dump f)
                          (write-string ")" p)))
                      entries)))
+        ((symlink)
+         (write-string "type" p)
+         (write-string "symlink" p)
+         (write-string "target" p)
+         (write-string (readlink f) p))
         (else
          (raise (condition (&message (message "ENOSYS"))
                            (&nar-error)))))
@@ -178,14 +183,26 @@ Restore it as FILE."
                                    (file #f))))))
 
   (let restore ((file file))
+    (define (read-eof-marker)
+      (match (read-string port)
+        (")" #t)
+        (x (raise
+            (condition
+             (&message (message "invalid nar end-of-file marker"))
+             (&nar-read-error (port port) (file file) (token x)))))))
+
     (match (list (read-string port) (read-string port) (read-string port))
       (("(" "type" "regular")
        (call-with-output-file file (cut read-contents port <>))
-       (match (read-string port)
-         (")" #t)
+       (read-eof-marker))
+      (("(" "type" "symlink")
+       (match (list (read-string port) (read-string port))
+         (("target" target)
+          (symlink target file)
+          (read-eof-marker))
          (x (raise
              (condition
-              (&message (message "invalid nar end-of-file marker"))
+              (&message (message "invalid symlink tokens"))
               (&nar-read-error (port port) (file file) (token x)))))))
       (("(" "type" "directory")
        (let ((dir file))
diff --git a/tests/nar.scm b/tests/nar.scm
index 2d9bffd487..4321cbda53 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -22,10 +22,122 @@
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
-  #:use-module (ice-9 ftw))
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match))
 
 ;; Test the (guix nar) module.
 
+
+;;;
+;;; File system testing tools, initially contributed to Guile, then libchop.
+;;;
+
+(define (random-file-size)
+  (define %average (* 1024 512))                  ; 512 KiB
+  (define %stddev  (* 1024 64))                   ; 64 KiB
+  (inexact->exact
+   (max 0 (round (+ %average (* %stddev (random:normal)))))))
+
+(define (make-file-tree dir tree)
+  "Make file system TREE at DIR."
+  (let loop ((dir  dir)
+             (tree tree))
+    (define (scope file)
+      (string-append dir "/" file))
+
+    (match tree
+      (('directory name (body ...))
+       (mkdir (scope name))
+       (for-each (cute loop (scope name) <>) body))
+      (('directory name (? integer? mode) (body ...))
+       (mkdir (scope name))
+       (for-each (cute loop (scope name) <>) body)
+       (chmod (scope name) mode))
+      ((file)
+       (populate-file (scope file) (random-file-size)))
+      ((file (? integer? mode))
+       (populate-file (scope file) (random-file-size))
+       (chmod (scope file) mode))
+      ((from '-> to)
+       (symlink to (scope from))))))
+
+(define (delete-file-tree dir tree)
+  "Delete file TREE from DIR."
+  (let loop ((dir  dir)
+             (tree tree))
+    (define (scope file)
+      (string-append dir "/" file))
+
+    (match tree
+      (('directory name (body ...))
+       (for-each (cute loop (scope name) <>) body)
+       (rmdir (scope name)))
+      (('directory name (? integer? mode) (body ...))
+       (chmod (scope name) #o755)          ; make sure it can be entered
+       (for-each (cute loop (scope name) <>) body)
+       (rmdir (scope name)))
+      ((from '-> _)
+       (delete-file (scope from)))
+      ((file _ ...)
+       (delete-file (scope file))))))
+
+(define-syntax-rule (with-file-tree dir tree body ...)
+  (dynamic-wind
+    (lambda ()
+      (make-file-tree dir 'tree))
+    (lambda ()
+      body ...)
+    (lambda ()
+      (delete-file-tree dir 'tree))))
+
+(define (file-tree-equal? input output)
+  "Return #t if the file trees at INPUT and OUTPUT are equal."
+  (define strip
+    (cute string-drop <> (string-length input)))
+  (define sibling
+    (compose (cut string-append output <>) strip))
+  (define (file=? a b)
+    (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
+         (case (stat:type (lstat a))
+           ((regular)
+            (equal?
+             (call-with-input-file a get-bytevector-all)
+             (call-with-input-file b get-bytevector-all)))
+           ((symlink)
+            (string=? (readlink a) (readlink b)))
+           (else
+            (error "what?" (lstat a))))))
+
+  (file-system-fold (const #t)
+                    (lambda (name stat result)    ; leaf
+                      (and result
+                           (file=? name (sibling name))))
+                    (lambda (name stat result)    ; down
+                      result)
+                    (lambda (name stat result)    ; up
+                      result)
+                    (const #f)                    ; skip
+                    (lambda (name stat errno result)
+                      (pk 'error name stat errno)
+                      #f)
+                    (> (stat:nlink (stat output)) 2)
+                    input
+                    lstat))
+
+(define (make-random-bytevector n)
+  (let ((bv (make-bytevector n)))
+    (let loop ((i 0))
+      (if (< i n)
+          (begin
+            (bytevector-u8-set! bv i (random 256))
+            (loop (1+ i)))
+          bv))))
+
+(define (populate-file file size)
+  (call-with-output-file file
+    (lambda (p)
+      (put-bytevector p (make-random-bytevector size)))))
+
 (define (rm-rf dir)
   (file-system-fold (const #t)                    ; enter?
                     (lambda (file stat result)    ; leaf
@@ -39,15 +151,18 @@
                     dir
                     lstat))
 
+(define %test-dir
+  ;; An output directory under $top_builddir.
+  (string-append (dirname (search-path %load-path "configure"))
+                 "/test-nar-" (number->string (getpid))))
+
 
 (test-begin "nar")
 
 (test-assert "write-file + restore-file"
   (let* ((input  (string-append (dirname (search-path %load-path "guix.scm"))
                                 "/guix"))
-         (output (string-append (dirname input)
-                                "/test-nar-"
-                                (number->string (getpid))))
+         (output %test-dir)
          (nar    (string-append output ".nar")))
     (dynamic-wind
       (lambda () #t)
@@ -56,40 +171,40 @@
           (cut write-file input <>))
         (call-with-input-file nar
           (cut restore-file <> output))
-        (let* ((strip   (cute string-drop <> (string-length input)))
-               (sibling (compose (cut string-append output <>) strip))
-               (file=?  (lambda (a b)
-                          (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
-                               (case (stat:type (lstat a))
-                                 ((regular)
-                                  (equal?
-                                   (call-with-input-file a get-bytevector-all)
-                                   (call-with-input-file b get-bytevector-all)))
-                                 ((symlink)
-                                  (string=? (readlink a) (readlink b)))
-                                 (else
-                                  (error "what?" (lstat a))))))))
-          (file-system-fold (const #t)
-                            (lambda (name stat result) ; leaf
-                              (and result
-                                   (file=? name (sibling name))))
-                            (lambda (name stat result) ; down
-                              result)
-                            (lambda (name stat result) ; up
-                              result)
-                            (const #f)                 ; skip
-                            (lambda (name stat errno result)
-                              (pk 'error name stat errno)
-                              #f)
-                            (> (stat:nlink (stat output)) 2)
-                            input
-                            lstat)))
+        (file-tree-equal? input output))
       (lambda ()
         (false-if-exception (delete-file nar))
-        (false-if-exception (rm-rf output))
-        ))))
+        (false-if-exception (rm-rf output))))))
+
+(test-assert "write-file + restore-file with symlinks"
+  (let ((input (string-append %test-dir ".input")))
+    (mkdir input)
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (with-file-tree input
+            (directory "root"
+                       (("reg") ("exe" #o777) ("sym" -> "reg")))
+          (let* ((output %test-dir)
+                 (nar    (string-append output ".nar")))
+            (dynamic-wind
+              (lambda () #t)
+              (lambda ()
+                (call-with-output-file nar
+                  (cut write-file input <>))
+                (call-with-input-file nar
+                  (cut restore-file <> output))
+                (file-tree-equal? input output))
+              (lambda ()
+                (false-if-exception (delete-file nar)))))))
+      (lambda ()
+        (rmdir input)))))
 
 (test-end "nar")
 
 
 (exit (= (test-runner-fail-count (test-runner-current)) 0))
+
+;;; Local Variables:
+;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
+;;; End:

From d7c5d27795500c1db3bca6c2ebf9066e32d36adb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 12 Apr 2013 15:52:27 +0200
Subject: [PATCH 16/74] substitute-binary: Correctly handle missing narinfos in
 `--query' mode.

* guix/scripts/substitute-binary.scm (guix-substitute-binary)["--query"]("have",
  "info"): Filter SUBSTITUTABLE through `narinfo?'.
---
 guix/scripts/substitute-binary.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 389acab094..64df4f09d6 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -192,7 +192,7 @@ failure."
                     (for-each (lambda (narinfo)
                                 (when narinfo
                                   (format #t "~a~%" (narinfo-path narinfo))))
-                              substitutable)
+                              (filter narinfo? substitutable))
                     (newline)))
                  (("info" paths ..1)
                   ;; Reply info about PATHS if it's in CACHE.
@@ -216,7 +216,7 @@ failure."
                                 (format #t "~a\n~a\n"
                                         (or (narinfo-file-size narinfo) 0)
                                         (or (narinfo-size narinfo) 0)))
-                              substitutable)
+                              (filter narinfo? substitutable))
                     (newline)))
                  (wtf
                   (error "unknown `--query' command" wtf)))

From fe0cff14f6c5facee4192529f5c7b7a972f185ca Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 12 Apr 2013 17:30:27 +0200
Subject: [PATCH 17/74] substitute-binary: Implement `--substitute'.

This allows build outputs to be transparently downloaded from
http://hydra.gnu.org, for example.

* config-daemon.ac: Check for `gzip', `bzip2', and `xz'.
* guix/config.scm.in (%gzip, %bzip2, %xz): New variable.
* guix/scripts/substitute-binary.scm (fetch): Return SIZE as a second value.
  (<narinfo>): Change `url' to `uri'.
  (make-narinfo): Rename to...
  (narinfo-maker): ... this.  Handle relative URLs.
  (fetch-narinfo): Adjust accordingly.
  (filtered-port, decompressed-port): New procedures.
  (guix-substitute-binary): Implement the `--substitute' case.
* tests/store.scm ("substitute query"): Use (%store-prefix) instead
  of (getenv "NIX_STORE_DIR").
  ("substitute"): New test.
---
 config-daemon.ac                   |   8 +++
 guix/config.scm.in                 |  14 +++-
 guix/scripts/substitute-binary.scm | 100 +++++++++++++++++++++++------
 tests/store.scm                    |  55 +++++++++++++++-
 4 files changed, 154 insertions(+), 23 deletions(-)

diff --git a/config-daemon.ac b/config-daemon.ac
index eed1e23f9e..7c51f2b95c 100644
--- a/config-daemon.ac
+++ b/config-daemon.ac
@@ -11,6 +11,14 @@ if test "x$guix_build_daemon" = "xyes"; then
   AC_PROG_RANLIB
   AC_CONFIG_HEADER([nix/config.h])
 
+  dnl Decompressors, for use by the substituter.
+  AC_PATH_PROG([GZIP], [gzip])
+  AC_PATH_PROG([BZIP2], [bzip2])
+  AC_PATH_PROG([XZ], [xz])
+  AC_SUBST([GZIP])
+  AC_SUBST([BZIP2])
+  AC_SUBST([XZ])
+
   dnl Use 64-bit file system calls so that we can support files > 2 GiB.
   AC_SYS_LARGEFILE
 
diff --git a/guix/config.scm.in b/guix/config.scm.in
index ab7b0669b8..772ea8c289 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -26,7 +26,10 @@
             %system
             %libgcrypt
             %nixpkgs
-            %nix-instantiate))
+            %nix-instantiate
+            %gzip
+            %bzip2
+            %xz))
 
 ;;; Commentary:
 ;;;
@@ -67,4 +70,13 @@
 (define %nix-instantiate
   "@NIX_INSTANTIATE@")
 
+(define %gzip
+  "@GZIP@")
+
+(define %bzip2
+  "@BZIP2@")
+
+(define %xz
+  "@XZ@")
+
 ;;; config.scm ends here
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 64df4f09d6..2b447ce7f2 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -20,10 +20,13 @@
   #:use-module (guix ui)
   #:use-module (guix store)
   #:use-module (guix utils)
+  #:use-module (guix config)
+  #:use-module (guix nar)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
   #:use-module (ice-9 threads)
+  #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
@@ -70,9 +73,12 @@ pairs."
     (apply make args)))
 
 (define (fetch uri)
+  "Return a binary input port to URI and the number of bytes it's expected to
+provide."
   (case (uri-scheme uri)
     ((file)
-     (open-input-file (uri-path uri)))
+     (let ((port (open-input-file (uri-path uri))))
+       (values port (stat:size (stat port)))))
     ((http)
      (let*-values (((resp port)
                     ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated
@@ -86,7 +92,7 @@ pairs."
                     (response-content-length resp)))
        (case code
          ((200)                                   ; OK
-          port)
+          (values port size))
          ((301                                    ; moved permanently
            302)                                   ; found (redirection)
           (let ((uri (response-location resp)))
@@ -120,11 +126,11 @@ failure."
                           '("StoreDir" "WantMassQuery")))))
 
 (define-record-type <narinfo>
-  (%make-narinfo path url compression file-hash file-size nar-hash nar-size
+  (%make-narinfo path uri compression file-hash file-size nar-hash nar-size
                  references deriver system)
   narinfo?
   (path         narinfo-path)
-  (url          narinfo-url)
+  (uri          narinfo-uri)
   (compression  narinfo-compression)
   (file-hash    narinfo-file-hash)
   (file-size    narinfo-file-size)
@@ -134,18 +140,26 @@ failure."
   (deriver      narinfo-deriver)
   (system       narinfo-system))
 
-(define (make-narinfo path url compression file-hash file-size nar-hash nar-size
-                      references deriver system)
-  "Return a new <narinfo> object."
-  (%make-narinfo path url compression file-hash
-                 (and=> file-size string->number)
-                 nar-hash
-                 (and=> nar-size string->number)
-                 (string-tokenize references)
-                 (match deriver
-                   ((or #f "") #f)
-                   (_ deriver))
-                 system))
+(define (narinfo-maker cache-url)
+  "Return a narinfo constructor for narinfos originating from CACHE-URL."
+  (lambda (path url compression file-hash file-size nar-hash nar-size
+                references deriver system)
+    "Return a new <narinfo> object."
+    (%make-narinfo path
+
+                   ;; Handle the case where URL is a relative URL.
+                   (or (string->uri url)
+                       (string->uri (string-append cache-url "/" url)))
+
+                   compression file-hash
+                   (and=> file-size string->number)
+                   nar-hash
+                   (and=> nar-size string->number)
+                   (string-tokenize references)
+                   (match deriver
+                     ((or #f "") #f)
+                     (_ deriver))
+                   system)))
 
 (define (fetch-narinfo cache path)
   "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
@@ -159,11 +173,36 @@ failure."
                                   (store-path-hash-part path)
                                   ".narinfo"))
          (lambda (properties)
-           (alist->record properties make-narinfo
+           (alist->record properties (narinfo-maker (cache-url cache))
                           '("StorePath" "URL" "Compression"
                             "FileHash" "FileSize" "NarHash" "NarSize"
                             "References" "Deriver" "System")))))
 
+(define (filtered-port command input)
+  "Return an input port (and PID) where data drained from INPUT is filtered
+through COMMAND.  INPUT must be a file input port."
+  (let ((i+o (pipe)))
+    (match (primitive-fork)
+      (0
+       (close-port (car i+o))
+       (close-port (current-input-port))
+       (dup2 (fileno input) 0)
+       (close-port (current-output-port))
+       (dup2 (fileno (cdr i+o)) 1)
+       (apply execl (car command) command))
+      (child
+       (close-port (cdr i+o))
+       (values (car i+o) child)))))
+
+(define (decompressed-port compression input)
+  "Return an input port where INPUT is decompressed according to COMPRESSION."
+  (match compression
+    ("none"  (values input #f))
+    ("bzip2" (filtered-port `(,%bzip2 "-dc") input))
+    ("xz"    (filtered-port `(,%xz "-dc") input))
+    ("gzip"  (filtered-port `(,%gzip "-dc") input))
+    (else    (error "unsupported compression scheme" compression))))
+
 (define %cache-url
   (or (getenv "GUIX_BINARY_SUBSTITUTE_URL")
       "http://hydra.gnu.org"))
@@ -222,10 +261,29 @@ failure."
                   (error "unknown `--query' command" wtf)))
                (loop (read-line)))))))
     (("--substitute" store-path destination)
-     ;; Download PATH and add it to the store.
-     ;; TODO: Implement.
-     (format (current-error-port) "substitution not implemented yet~%")
-     #f)
+     ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
+     (let* ((cache   (open-cache %cache-url))
+            (narinfo (fetch-narinfo cache store-path))
+            (uri     (narinfo-uri narinfo)))
+       ;; Tell the daemon what the expected hash of the Nar itself is.
+       (format #t "~a~%" (narinfo-hash narinfo))
+
+       (let*-values (((raw download-size)
+                      (fetch uri))
+                     ((input pid)
+                      (decompressed-port (narinfo-compression narinfo)
+                                         raw)))
+         ;; Note that Hydra currently generates Nars on the fly and doesn't
+         ;; specify a Content-Length, so DOWNLOAD-SIZE is #f in practice.
+         (format (current-error-port)
+                 (_ "downloading `~a' from `~a'~:[~*~; (~,1f KiB)~]...~%")
+                 store-path (uri->string uri)
+                 download-size
+                 (and=> download-size (cut / <> 1024.0)))
+
+         ;; Unpack the Nar at INPUT into DESTINATION.
+         (restore-file input destination)
+         (or (not pid) (zero? (cdr (waitpid pid)))))))
     (("--version")
      (show-version-and-exit "guix substitute-binary"))))
 
diff --git a/tests/store.scm b/tests/store.scm
index c75b99c6a9..4ee20a9352 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -23,9 +23,11 @@
   #:use-module (guix base32)
   #:use-module (guix packages)
   #:use-module (guix derivations)
+  #:use-module (guix nar)
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
   #:use-module (ice-9 match)
+  #:use-module (rnrs io ports)
   #:use-module (web uri)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
@@ -141,7 +143,7 @@
     (call-with-output-file (string-append dir "/nix-cache-info")
       (lambda (p)
         (format p "StoreDir: ~a\nWantMassQuery: 0\n"
-                (getenv "NIX_STORE_DIR"))))
+                (%store-prefix))))
     (call-with-output-file (string-append dir "/" (store-path-hash-part o)
                                           ".narinfo")
       (lambda (p)
@@ -167,6 +169,57 @@ Deriver: ~a~%"
                  (null? (substitutable-references s))
                  (equal? (substitutable-nar-size s) 1234)))))))
 
+(test-assert "substitute"
+  (let* ((s   (open-connection))
+         (c   (random-text))                      ; contents of the output
+         (d   (build-expression->derivation
+               s "substitute-me" (%current-system)
+               `(call-with-output-file %output
+                  (lambda (p)
+                    (exit 1)                      ; would actually fail
+                    (display ,c p)))
+               '()
+               #:guile-for-build
+               (package-derivation s %bootstrap-guile (%current-system))))
+         (o   (derivation-path->output-path d))
+         (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
+                     (compose uri-path string->uri))))
+    ;; Create fake substituter data, to be read by `substitute-binary'.
+    (call-with-output-file (string-append dir "/nix-cache-info")
+      (lambda (p)
+        (format p "StoreDir: ~a\nWantMassQuery: 0\n"
+                (%store-prefix))))
+    (call-with-output-file (string-append dir "/example.out")
+      (lambda (p)
+        (display c p)))
+    (call-with-output-file (string-append dir "/example.nar")
+      (lambda (p)
+        (write-file (string-append dir "/example.out") p)))
+    (call-with-output-file (string-append dir "/" (store-path-hash-part o)
+                                          ".narinfo")
+      (lambda (p)
+        (format p "StorePath: ~a
+URL: ~a
+Compression: none
+NarSize: 1234
+NarHash: sha256:~a
+References: 
+System: ~a
+Deriver: ~a~%"
+                o                                   ; StorePath
+                "example.nar"                       ; relative URL
+                (call-with-input-file (string-append dir "/example.nar")
+                  (compose bytevector->nix-base32-string sha256
+                           get-bytevector-all))
+                (%current-system)                   ; System
+                (basename d))))                     ; Deriver
+
+    ;; Make sure we use `substitute-binary'.
+    (set-build-options s #:use-substitutes? #t)
+    (and (has-substitutes? s o)
+         (build-derivations s (list d))
+         (equal? c (call-with-input-file o get-string-all)))))
+
 (test-end "store")
 
 

From 3b8246057629c5fbdcb297da12f88fae69ee1a9a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 12 Apr 2013 15:43:55 +0200
Subject: [PATCH 18/74] guix package: Add `--no-substitutes'.

* guix/scripts/package.scm (%default-options): Add `substitutes?'.
  (show-help, %options): Add and document `--no-substitutes'.
  (guix-package): Call `set-build-options' to honor `substitutes?'.
---
 doc/guix.texi            |  3 +++
 guix/scripts/package.scm | 13 ++++++++++++-
 2 files changed, 15 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 1be172c3f6..c91bc2021d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -570,6 +570,9 @@ Use @var{profile} instead of the user's default profile.
 @itemx -n
 Show what would be done without actually doing it.
 
+@item --no-substitutes
+Build instead of resorting to pre-built substitutes.
+
 @item --verbose
 Produce verbose output.  In particular, emit the environment's build log
 on the standard error port.
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 89708ccc49..ba75cd778c 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -313,7 +313,8 @@ but ~a is available upstream~%")
 
 (define %default-options
   ;; Alist of default option values.
-  `((profile . ,%current-profile)))
+  `((profile . ,%current-profile)
+    (substitutes? . #t)))
 
 (define (show-help)
   (display (_ "Usage: guix package [OPTION]... PACKAGES...
@@ -334,6 +335,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
   -p, --profile=PROFILE  use PROFILE instead of the user's default profile"))
   (display (_ "
   -n, --dry-run          show what would be done without actually doing it"))
+  (display (_ "
+      --no-substitutes   build instead of resorting to pre-built substitutes"))
   (display (_ "
       --bootstrap        use the bootstrap Guile to build the profile"))
   (display (_ "
@@ -388,6 +391,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
         (option '(#\n "dry-run") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'dry-run? #t result)))
+        (option '("no-substitutes") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'substitutes? #f
+                              (alist-delete 'substitutes? result))))
         (option '("bootstrap") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'bootstrap? #t result)))
@@ -750,6 +757,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
     (or (process-query opts)
         (with-error-handling
           (parameterize ((%store (open-connection)))
+            (set-build-options (%store)
+                               #:use-substitutes?
+                               (assoc-ref opts 'substitutes?))
+
             (parameterize ((%guile-for-build
                             (package-derivation (%store)
                                                 (if (assoc-ref opts 'bootstrap?)

From 9297c90b69ba2d1f504f8c63b92510806615847d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 12 Apr 2013 15:59:03 +0200
Subject: [PATCH 19/74] Update `TODO'.

---
 TODO | 10 ++++++----
 1 file changed, 6 insertions(+), 4 deletions(-)

diff --git a/TODO b/TODO
index 205e1d71af..7a3b892105 100644
--- a/TODO
+++ b/TODO
@@ -17,11 +17,13 @@ X.509 SubjectPublicKeyInfo.  These can be decoded with the [[http://lists.gnu.or
 GnuTLS]], but not yet with its Guile bindings.  There’s also
 ‘gnutls_privkey_sign_data’ to sign, and related functions.
 
-** Add a binary cache substituter
 
-Like scripts/download-from-binary-cache.pl in Nix, but written in
-Scheme.  Substituters allow pre-built binaries to be downloaded when
-they are available from a trusted source.
+** Add `guix publish' to publish the store using Guile's web server
+
+Generate narinfos and nars on the fly, upon HTTP GET requests.
+Ideally, extend .nix-cache-info to include the server's public key, and also
+reply to requests for .narinfo.sig.
+Optionally, use Guile-Avahi to publish the service.
 
 ** MAYBE Add a substituter that uses the GNUnet DHT
 

From c31d1a7860203cb779b16171fe50ec9948135bc2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 12 Apr 2013 18:07:17 +0200
Subject: [PATCH 20/74] package: Being at the empty profile is not an error.

* guix/scripts/package.scm (roll-back): Use `format', not `leave' when
  indicating "already at the empty profile".  Fixes a regression
  introduced in a2011be5dfaf2b94a1d0e3dfbcf4b512389b4711.  Reported by
  Nikita Karetnikov <nikita@karetnikov.org>.
---
 guix/scripts/package.scm | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index ba75cd778c..ac99d16497 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -211,7 +211,8 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
            (leave (_ "error: profile `~a' does not exist~%")
                   profile))
           ((zero? number)                         ; empty profile
-           (leave (_ "nothing to do: already at the empty profile~%")))
+           (format (current-error-port)
+                   (_ "nothing to do: already at the empty profile~%")))
           ((or (zero? previous-number)            ; going to emptiness
                (not (file-exists? previous-profile)))
            (let*-values (((drv-path drv)

From 9adb6934f434436523e6d736cd1b55950d690b8d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 12 Apr 2013 18:22:41 +0200
Subject: [PATCH 21/74] store: Remove unneeded and conflicting import.

* guix/store.scm: Remove unneeded (ice-9 rdelim) import.  In Guile 2.0.9
  that module exports `read-string', which conflicts with that of (guix
  serialization).
---
 guix/store.scm | 1 -
 1 file changed, 1 deletion(-)

diff --git a/guix/store.scm b/guix/store.scm
index cc21af84e4..b1b60babf0 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -30,7 +30,6 @@
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-39)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:export (%daemon-socket-file
 

From 77ffd691bfbb152cde94b60aa8df5135d39727c3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 12 Apr 2013 18:40:22 +0200
Subject: [PATCH 22/74] tests: Remove temporary directory created by nar.scm.

* tests/nar.scm ("write-file + restore-file with symlinks"): Add (rm-rf
  output).
---
 tests/nar.scm | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/tests/nar.scm b/tests/nar.scm
index 4321cbda53..9bc5a1962e 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -196,7 +196,8 @@
                   (cut restore-file <> output))
                 (file-tree-equal? input output))
               (lambda ()
-                (false-if-exception (delete-file nar)))))))
+                (false-if-exception (delete-file nar))
+                (false-if-exception (rm-rf output)))))))
       (lambda ()
         (rmdir input)))))
 

From 04fd96cac33fa7557e574e54575252564ba27111 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 14 Apr 2013 16:56:08 +0200
Subject: [PATCH 23/74] utils: Add `fold2'.

* gnu/packages.scm (fold2): Remove.
* guix/utils.scm (fold2): New procedure.  Generalization of the above to
  one and two lists.
* tests/utils.scm ("fold2, 1 list", "fold2, 2 lists"): New tests.
---
 gnu/packages.scm |  8 --------
 guix/utils.scm   | 29 ++++++++++++++++++++++++++++-
 tests/utils.scm  | 25 +++++++++++++++++++++++++
 3 files changed, 53 insertions(+), 9 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index b639541788..f4d93a789d 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -110,14 +110,6 @@
                   (false-if-exception (resolve-interface name))))
               (package-files)))
 
-(define (fold2 f seed1 seed2 lst)
-  (if (null? lst)
-      (values seed1 seed2)
-      (call-with-values
-          (lambda () (f (car lst) seed1 seed2))
-        (lambda (seed1 seed2)
-          (fold2 f seed1 seed2 (cdr lst))))))
-
 (define (fold-packages proc init)
   "Call (PROC PACKAGE RESULT) for each available package, using INIT as
 the initial value of RESULT.  It is guaranteed to never traverse the
diff --git a/guix/utils.scm b/guix/utils.scm
index d7c37e37d1..f13e585e2b 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -59,7 +59,8 @@
             %current-system
             version-compare
             version>?
-            package-name->name+version))
+            package-name->name+version
+            fold2))
 
 
 ;;;
@@ -463,6 +464,32 @@ introduce the version part."
       ((head tail ...)
        (loop tail (cons head prefix))))))
 
+(define fold2
+  (case-lambda
+    ((proc seed1 seed2 lst)
+     "Like `fold', but with a single list and two seeds."
+     (let loop ((result1 seed1)
+                (result2 seed2)
+                (lst     lst))
+       (if (null? lst)
+           (values result1 result2)
+           (call-with-values
+               (lambda () (proc (car lst) result1 result2))
+             (lambda (result1 result2)
+               (loop result1 result2 (cdr lst)))))))
+    ((proc seed1 seed2 lst1 lst2)
+     "Like `fold', but with a two lists and two seeds."
+     (let loop ((result1 seed1)
+                (result2 seed2)
+                (lst1    lst1)
+                (lst2    lst2))
+       (if (or (null? lst1) (null? lst2))
+           (values result1 result2)
+           (call-with-values
+               (lambda () (proc (car lst1) (car lst2) result1 result2))
+             (lambda (result1 result2)
+               (fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))
+
 
 ;;;
 ;;; Source location.
diff --git a/tests/utils.scm b/tests/utils.scm
index bcdd120a74..fa7d7b03fd 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -64,6 +64,31 @@
            ("nixpkgs" "1.0pre22125_a28fe19")
            ("gtk2" "2.38.0"))))
 
+(test-equal "fold2, 1 list"
+    (list (reverse (iota 5))
+          (map - (reverse (iota 5))))
+  (call-with-values
+      (lambda ()
+        (fold2 (lambda (i r1 r2)
+                 (values (cons i r1)
+                         (cons (- i) r2)))
+               '() '()
+               (iota 5)))
+    list))
+
+(test-equal "fold2, 2 lists"
+    (list (reverse '((a . 0) (b . 1) (c . 2) (d . 3)))
+          (reverse '((a . 0) (b . -1) (c . -2) (d . -3))))
+  (call-with-values
+      (lambda ()
+        (fold2 (lambda (k v r1 r2)
+                 (values (alist-cons k v r1)
+                         (alist-cons k (- v) r2)))
+               '() '()
+               '(a b c d)
+               '(0 1 2 3)))
+    list))
+
 (test-assert "define-record-type*"
   (begin
     (define-record-type* <foo> foo make-foo

From 63b7c6c1f82486604abd6e3b6a6e14643d1f6621 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 14 Apr 2013 17:17:19 +0200
Subject: [PATCH 24/74] gnu: automake: Restore shebangs on files that end up in
 user tarballs.

* gnu/packages/autotools.scm (automake): Add `unpatch-shebangs' phase.
---
 gnu/packages/autotools.scm | 35 ++++++++++++++++++++++++++++++++++-
 1 file changed, 34 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/autotools.scm b/gnu/packages/autotools.scm
index bc4dddc01f..51aadbf0ec 100644
--- a/gnu/packages/autotools.scm
+++ b/gnu/packages/autotools.scm
@@ -151,6 +151,11 @@ exec ~a --no-auto-compile \"$0\" \"$@\"
         ,(search-patch "automake-skip-amhello-tests.patch"))))
     (arguments
      '(#:patches (list (assoc-ref %build-inputs "patch/skip-amhello"))
+       #:modules ((guix build gnu-build-system)
+                  (guix build utils)
+                  (srfi srfi-1)
+                  (srfi srfi-26)
+                  (rnrs io ports))
        #:phases (alist-cons-before
                  'patch-source-shebangs 'patch-tests-shebangs
                  (lambda _
@@ -163,7 +168,35 @@ exec ~a --no-auto-compile \"$0\" \"$@\"
                      ;; that occur during the test suite.
                      (setenv "SHELL" sh)
                      (setenv "CONFIG_SHELL" sh)))
-                 %standard-phases)))
+
+                 ;; Files like `install-sh', `mdate.sh', etc. must use
+                 ;; #!/bin/sh, otherwise users could leak erroneous shebangs
+                 ;; in the wild.  See <http://bugs.gnu.org/14201> for an
+                 ;; example.
+                 (alist-cons-after
+                  'install 'unpatch-shebangs
+                  (lambda* (#:key outputs #:allow-other-keys)
+                    (let* ((out (assoc-ref outputs "out"))
+                           (dir (string-append out "/share")))
+                      (define (starts-with-shebang? file)
+                        (equal? (call-with-input-file file
+                                  (lambda (p)
+                                    (list (get-u8 p) (get-u8 p))))
+                                (map char->integer '(#\# #\!))))
+
+                      (for-each (lambda (file)
+                                  (when (and (starts-with-shebang? file)
+                                             (executable-file? file))
+                                    (format #t "restoring shebang on `~a'~%"
+                                            file)
+                                    (substitute* file
+                                      (("^#!.*/bin/sh")
+                                       "#!/bin/sh")
+                                      (("^#!.*/bin/env(.*)$" _ args)
+                                       (string-append "#!/usr/bin/env"
+                                                      args)))))
+                                (find-files dir ".*"))))
+                  %standard-phases))))
     (home-page "http://www.gnu.org/software/automake/")
     (synopsis
      "GNU Automake, a GNU standard-compliant makefile generator")

From eba783b7b20cbf84dfd0a04bc19e3bebbc9a30fc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 15 Apr 2013 23:42:27 +0200
Subject: [PATCH 25/74] substitute-binary: Add a local cache.

* guix/scripts/substitute-binary.scm (%narinfo-cache-directory,
  %narinfo-ttl, %narinfo-negative-ttl): New variables.
  (with-atomic-file-output, object->fields, read-narinfo,
  write-narinfo, narinfo->string, string->narinfo, lookup-narinfo): New
  procedures.
  (fetch-narinfo): Adjust to use `read-narinfo'.
  (guix-substitute-binary): Ensure the existence of
  %NARINFO-CACHE-DIRECTORY.  Use `lookup-narinfo' instead of
  `fetch-narinfo'.
---
 guix/scripts/substitute-binary.scm | 155 +++++++++++++++++++++++++++--
 test-env.in                        |   6 +-
 tests/store.scm                    |   6 ++
 3 files changed, 156 insertions(+), 11 deletions(-)

diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 2b447ce7f2..453a29a5ea 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -22,6 +22,7 @@
   #:use-module (guix utils)
   #:use-module (guix config)
   #:use-module (guix nar)
+  #:use-module ((guix build utils) #:select (mkdir-p))
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
@@ -30,6 +31,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (web uri)
   #:use-module (web client)
@@ -47,6 +49,36 @@
 ;;;
 ;;; Code:
 
+(define %narinfo-cache-directory
+  ;; A local cache of narinfos, to avoid going to the network.
+  (or (and=> (getenv "XDG_CACHE_HOME")
+             (cut string-append <> "/guix/substitute-binary"))
+      (string-append %state-directory "/substitute-binary/cache")))
+
+(define %narinfo-ttl
+  ;; Number of seconds during which cached narinfo lookups are considered
+  ;; valid.
+  (* 24 3600))
+
+(define %narinfo-negative-ttl
+  ;; Likewise, but for negative lookups---i.e., cached lookup failures.
+  (* 3 3600))
+
+(define (with-atomic-file-output file proc)
+  "Call PROC with an output port for the file that is going to replace FILE.
+Upon success, FILE is atomically replaced by what has been written to the
+output port, and PROC's result is returned."
+  (let* ((template (string-append file ".XXXXXX"))
+         (out      (mkstemp! template)))
+    (with-throw-handler #t
+      (lambda ()
+        (let ((result (proc out)))
+          (close out)
+          (rename-file template file)
+          result))
+      (lambda (key . args)
+        (false-if-exception (delete-file template))))))
+
 (define (fields->alist port)
   "Read recutils-style record from PORT and return them as a list of key/value
 pairs."
@@ -72,6 +104,17 @@ pairs."
   (let ((args (map (cut assoc-ref alist <>) keys)))
     (apply make args)))
 
+(define (object->fields object fields port)
+  "Write OBJECT (typically a record) as a series of recutils-style fields to
+PORT, according to FIELDS.  FIELDS must be a list of field name/getter pairs."
+  (let loop ((fields fields))
+    (match fields
+      (()
+       object)
+      (((field . get) rest ...)
+       (format port "~a: ~a~%" field (get object))
+       (loop rest)))))
+
 (define (fetch uri)
   "Return a binary input port to URI and the number of bytes it's expected to
 provide."
@@ -161,22 +204,113 @@ failure."
                      (_ deriver))
                    system)))
 
+(define* (read-narinfo port #:optional url)
+  "Read a narinfo from PORT in its standard external form.  If URL is true, it
+must be a string used to build full URIs from relative URIs found while
+reading PORT."
+  (alist->record (fields->alist port)
+                 (narinfo-maker url)
+                 '("StorePath" "URL" "Compression"
+                   "FileHash" "FileSize" "NarHash" "NarSize"
+                   "References" "Deriver" "System")))
+
+(define (write-narinfo narinfo port)
+  "Write NARINFO to PORT."
+  (define (empty-string-if-false x)
+    (or x ""))
+
+  (define (number-or-empty-string x)
+    (if (number? x)
+        (number->string x)
+        ""))
+
+  (object->fields narinfo
+                  `(("StorePath" . ,narinfo-path)
+                    ("URL" . ,(compose uri->string narinfo-uri))
+                    ("Compression" . ,narinfo-compression)
+                    ("FileHash" . ,(compose empty-string-if-false
+                                            narinfo-file-hash))
+                    ("FileSize" . ,(compose number-or-empty-string
+                                            narinfo-file-size))
+                    ("NarHash" . ,(compose empty-string-if-false
+                                           narinfo-hash))
+                    ("NarSize" . ,(compose number-or-empty-string
+                                           narinfo-size))
+                    ("References" . ,(compose string-join narinfo-references))
+                    ("Deriver" . ,(compose empty-string-if-false
+                                           narinfo-deriver))
+                    ("System" . ,narinfo-system))
+                  port))
+
+(define (narinfo->string narinfo)
+  "Return the external representation of NARINFO."
+  (call-with-output-string (cut write-narinfo narinfo <>)))
+
+(define (string->narinfo str)
+  "Return the narinfo represented by STR."
+  (call-with-input-string str (cut read-narinfo <>)))
+
 (define (fetch-narinfo cache path)
   "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
   (define (download url)
     ;; Download the `nix-cache-info' from URL, and return its contents as an
     ;; list of key/value pairs.
-    (and=> (false-if-exception (fetch (string->uri url)))
-           fields->alist))
+    (false-if-exception (fetch (string->uri url))))
 
   (and=> (download (string-append (cache-url cache) "/"
                                   (store-path-hash-part path)
                                   ".narinfo"))
-         (lambda (properties)
-           (alist->record properties (narinfo-maker (cache-url cache))
-                          '("StorePath" "URL" "Compression"
-                            "FileHash" "FileSize" "NarHash" "NarSize"
-                            "References" "Deriver" "System")))))
+         (cute read-narinfo <> (cache-url cache))))
+
+(define (lookup-narinfo cache path)
+  "Check locally if we have valid info about PATH, otherwise go to CACHE and
+check what it has."
+  (define now
+    (current-time time-monotonic))
+
+  (define (->time seconds)
+    (make-time time-monotonic 0 seconds))
+
+  (define (obsolete? date ttl)
+    (time>? (subtract-duration now (make-time time-duration 0 ttl))
+            (->time date)))
+
+  (define cache-file
+    (string-append %narinfo-cache-directory "/"
+                   (store-path-hash-part path)))
+
+  (define (cache-entry narinfo)
+    `(narinfo (version 0)
+              (date ,(time-second now))
+              (value ,(and=> narinfo narinfo->string))))
+
+  (let*-values (((valid? cached)
+                 (catch 'system-error
+                   (lambda ()
+                     (call-with-input-file cache-file
+                       (lambda (p)
+                         (match (read p)
+                           (('narinfo ('version 0) ('date date)
+                                      ('value #f))
+                            ;; A cached negative lookup.
+                            (if (obsolete? date %narinfo-negative-ttl)
+                                (values #f #f)
+                                (values #t #f)))
+                           (('narinfo ('version 0) ('date date)
+                                      ('value value))
+                            ;; A cached positive lookup
+                            (if (obsolete? date %narinfo-ttl)
+                                (values #f #f)
+                                (values #t (string->narinfo value))))))))
+                   (lambda _
+                     (values #f #f)))))
+    (if valid?
+        cached                                    ; including negative caches
+        (let ((narinfo (fetch-narinfo cache path)))
+          (with-atomic-file-output cache-file
+            (lambda (out)
+              (write (cache-entry narinfo) out)))
+          narinfo))))
 
 (define (filtered-port command input)
   "Return an input port (and PID) where data drained from INPUT is filtered
@@ -214,6 +348,7 @@ through COMMAND.  INPUT must be a file input port."
 
 (define (guix-substitute-binary . args)
   "Implement the build daemon's substituter protocol."
+  (mkdir-p %narinfo-cache-directory)
   (match args
     (("--query")
      (let ((cache (open-cache %cache-url)))
@@ -225,7 +360,7 @@ through COMMAND.  INPUT must be a file input port."
                   ;; Return the subset of PATHS available in CACHE.
                   (let ((substitutable
                          (if cache
-                             (par-map (cut fetch-narinfo cache <>)
+                             (par-map (cut lookup-narinfo cache <>)
                                       paths)
                              '())))
                     (for-each (lambda (narinfo)
@@ -237,7 +372,7 @@ through COMMAND.  INPUT must be a file input port."
                   ;; Reply info about PATHS if it's in CACHE.
                   (let ((substitutable
                          (if cache
-                             (par-map (cut fetch-narinfo cache <>)
+                             (par-map (cut lookup-narinfo cache <>)
                                       paths)
                              '())))
                     (for-each (lambda (narinfo)
@@ -263,7 +398,7 @@ through COMMAND.  INPUT must be a file input port."
     (("--substitute" store-path destination)
      ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
      (let* ((cache   (open-cache %cache-url))
-            (narinfo (fetch-narinfo cache store-path))
+            (narinfo (lookup-narinfo cache store-path))
             (uri     (narinfo-uri narinfo)))
        ;; Tell the daemon what the expected hash of the Nar itself is.
        (format #t "~a~%" (narinfo-hash narinfo))
diff --git a/test-env.in b/test-env.in
index 9a6257197c..64440fb86a 100644
--- a/test-env.in
+++ b/test-env.in
@@ -45,9 +45,13 @@ then
     rm -rf "$NIX_STATE_DIR/substituter-data"
     mkdir -p "$NIX_STATE_DIR/substituter-data"
 
+    # Place for the substituter's cache.
+    XDG_CACHE_HOME="$NIX_STATE_DIR/cache-$$"
+
     export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR			\
 	NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR		\
-	NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL
+	NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL	\
+        XDG_CACHE_HOME
 
     # Do that because store.scm calls `canonicalize-path' on it.
     mkdir -p "$NIX_STORE_DIR"
diff --git a/tests/store.scm b/tests/store.scm
index 4ee20a9352..677e39e75d 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -159,6 +159,12 @@ Deriver: ~a~%"
                 (%current-system)                   ; System
                 (basename d))))                     ; Deriver
 
+    ;; Remove entry from the local cache.
+    (false-if-exception
+     (delete-file (string-append (getenv "XDG_CACHE_HOME")
+                                 "/guix/substitute-binary/"
+                                 (store-path-hash-part o))))
+
     ;; Make sure `substitute-binary' correctly communicates the above data.
     (set-build-options s #:use-substitutes? #t)
     (and (has-substitutes? s o)

From 0c357a088bb0b267df9d9bde486e6603f66cd029 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 15 Apr 2013 23:42:42 +0200
Subject: [PATCH 26/74] substitute-binary: Call `open-cache' only when needed.

* guix/scripts/substitute-binary.scm (lookup-narinfo): Force CACHE when
  passing it to `fetch-narinfo'.
  (guix-substitute-binary): Delay calls to `open-cache'.
---
 guix/scripts/substitute-binary.scm | 7 ++++---
 1 file changed, 4 insertions(+), 3 deletions(-)

diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 453a29a5ea..94cfac8bcc 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -306,7 +306,8 @@ check what it has."
                      (values #f #f)))))
     (if valid?
         cached                                    ; including negative caches
-        (let ((narinfo (fetch-narinfo cache path)))
+        (let ((narinfo (and=> (force cache)
+                              (cut fetch-narinfo <> path))))
           (with-atomic-file-output cache-file
             (lambda (out)
               (write (cache-entry narinfo) out)))
@@ -351,7 +352,7 @@ through COMMAND.  INPUT must be a file input port."
   (mkdir-p %narinfo-cache-directory)
   (match args
     (("--query")
-     (let ((cache (open-cache %cache-url)))
+     (let ((cache (delay (open-cache %cache-url))))
        (let loop ((command (read-line)))
          (or (eof-object? command)
              (begin
@@ -397,7 +398,7 @@ through COMMAND.  INPUT must be a file input port."
                (loop (read-line)))))))
     (("--substitute" store-path destination)
      ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
-     (let* ((cache   (open-cache %cache-url))
+     (let* ((cache   (delay (open-cache %cache-url)))
             (narinfo (lookup-narinfo cache store-path))
             (uri     (narinfo-uri narinfo)))
        ;; Tell the daemon what the expected hash of the Nar itself is.

From e967678ed1f1d7e765adc4bfc7d2a79ee9677b21 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 15 Apr 2013 23:27:04 +0200
Subject: [PATCH 27/74] substitute-binary: Skip servers that use a different
 store prefix.

* guix/scripts/substitute-binary.scm (fetch-narinfo): Return #f when
  CACHE uses a store directory different from (%store-prefix).
---
 guix/scripts/substitute-binary.scm | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 94cfac8bcc..804121b6c8 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -257,10 +257,11 @@ reading PORT."
     ;; list of key/value pairs.
     (false-if-exception (fetch (string->uri url))))
 
-  (and=> (download (string-append (cache-url cache) "/"
-                                  (store-path-hash-part path)
-                                  ".narinfo"))
-         (cute read-narinfo <> (cache-url cache))))
+  (and (string=? (cache-store-directory cache) (%store-prefix))
+       (and=> (download (string-append (cache-url cache) "/"
+                                       (store-path-hash-part path)
+                                       ".narinfo"))
+              (cute read-narinfo <> (cache-url cache)))))
 
 (define (lookup-narinfo cache path)
   "Check locally if we have valid info about PATH, otherwise go to CACHE and

From 0160536dcb5399ad7d80b10e064df5c95f3adb4f Mon Sep 17 00:00:00 2001
From: Cyril Roelandt <tipecaml@gmail.com>
Date: Mon, 15 Apr 2013 22:02:47 +0200
Subject: [PATCH 28/74] gnu: Python: bump to version 2.7.4.

* gnu/packages/python.scm: bump to version 2.7.4, remove references to
python-fix-dbm.patch.
* Makefile.am: remove references to python-fix-dbm.patch
* gnu/packages/patches/python-fix-dbm.patch: remove it.
---
 Makefile.am                               |  1 -
 gnu/packages/patches/python-fix-dbm.patch | 20 --------------------
 gnu/packages/python.scm                   |  9 +++------
 3 files changed, 3 insertions(+), 27 deletions(-)
 delete mode 100644 gnu/packages/patches/python-fix-dbm.patch

diff --git a/Makefile.am b/Makefile.am
index 930ea6ce72..df0a5138dc 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -229,7 +229,6 @@ dist_patch_DATA =						\
   gnu/packages/patches/make-impure-dirs.patch			\
   gnu/packages/patches/mcron-install.patch			\
   gnu/packages/patches/perl-no-sys-dirs.patch			\
-  gnu/packages/patches/python-fix-dbm.patch			\
   gnu/packages/patches/procps-make-3.82.patch			\
   gnu/packages/patches/qemu-multiple-smb-shares.patch		\
   gnu/packages/patches/readline-link-ncurses.patch		\
diff --git a/gnu/packages/patches/python-fix-dbm.patch b/gnu/packages/patches/python-fix-dbm.patch
deleted file mode 100644
index 29e4521f3f..0000000000
--- a/gnu/packages/patches/python-fix-dbm.patch
+++ /dev/null
@@ -1,20 +0,0 @@
-This patch allows the dbm module to be built using the compatibility mode of
-gdbm. It will not be needed any more with Python 2.7.4.
---- setup.py	2013-04-06 00:53:37.000000000 +0200
-+++ setup.py.new	2013-04-06 19:55:05.000000000 +0200
-@@ -1158,10 +1158,14 @@
-             for cand in dbm_order:
-                 if cand == "ndbm":
-                     if find_file("ndbm.h", inc_dirs, []) is not None:
--                        # Some systems have -lndbm, others don't
-+                        # Some systems have -lndbm, some have -lgdbm_compat,
-+                        # others have no particular linker flags.
-                         if self.compiler.find_library_file(lib_dirs,
-                                                                'ndbm'):
-                             ndbm_libs = ['ndbm']
-+                        elif self.compiler.find_library_file(lib_dirs,
-+                                                             'gdbm_compat'):
-+                            ndbm_libs = ['gdbm_compat']
-                         else:
-                             ndbm_libs = []
-                         print "building dbm using ndbm"
diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm
index 3f941642fc..8b4515930e 100644
--- a/gnu/packages/python.scm
+++ b/gnu/packages/python.scm
@@ -31,7 +31,7 @@
 (define-public python
   (package
     (name "python")
-    (version "2.7.3")
+    (version "2.7.4")
     (source
      (origin
       (method url-fetch)
@@ -39,12 +39,10 @@
                           version "/Python-" version ".tar.xz"))
       (sha256
        (base32
-        "11f9aw855lrmknr6c82gm1ijr3n0smc6idyp94y7774yivjnplv1"))))
+        "0bdn4dylm92n2dsvqvjfyask9jbz88aan5hi4lgkawkxs2v6wqmn"))))
     (build-system gnu-build-system)
     (arguments
      `(#:tests? #f ; XXX: some tests fail
-       #:patches (list (assoc-ref %build-inputs "patch-dbm"))
-       #:patch-flags '("-p0")
        #:configure-flags
         (let ((bz2 (assoc-ref %build-inputs "bzip2"))
               (gdbm (assoc-ref %build-inputs "gdbm"))
@@ -68,8 +66,7 @@
        ("gdbm" ,gdbm)
        ("openssl" ,openssl)
        ("readline" ,readline)
-       ("zlib" ,zlib)
-       ("patch-dbm" ,(search-patch "python-fix-dbm.patch"))))
+       ("zlib" ,zlib)))
     (home-page "http://python.org")
     (synopsis
      "Python, a high-level dynamically-typed programming language")

From acb6ba256703da1db1d300541e15a4e7428f622b Mon Sep 17 00:00:00 2001
From: Cyril Roelandt <tipecaml@gmail.com>
Date: Mon, 15 Apr 2013 23:23:27 +0200
Subject: [PATCH 29/74] package: allow users to upgrade the whole system by not
 providing a regexp.

* guix/scripts/packages.scm (guix-package) [process-actions]: When upgrading,
use "" when REGEXP is #f.
* doc/guix.texi: update the documentation accordingly.
---
 doc/guix.texi            | 7 ++++---
 guix/scripts/package.scm | 6 +++---
 2 files changed, 7 insertions(+), 6 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index c91bc2021d..b77335d2c2 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -537,9 +537,10 @@ multiple-output package.
 @itemx -r @var{package}
 Remove @var{package}.
 
-@item --upgrade=@var{regexp}
-@itemx -u @var{regexp}
-Upgrade all the installed packages matching @var{regexp}.
+@item --upgrade[=@var{regexp}]
+@itemx -u [@var{regexp}]
+Upgrade all the installed packages.  When @var{regexp} is specified, upgrade
+only installed packages whose name matches @var{regexp}.
 
 Note that this upgrades package to the latest version of packages found
 in the distribution currently installed.  To update your distribution,
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index ac99d16497..5b340c6ab7 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -328,7 +328,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
   (display (_ "
   -r, --remove=PACKAGE   remove PACKAGE"))
   (display (_ "
-  -u, --upgrade=REGEXP   upgrade all the installed packages matching REGEXP"))
+  -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP"))
   (display (_ "
       --roll-back        roll back to the previous generation"))
   (newline)
@@ -379,7 +379,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
         (option '(#\r "remove") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'remove arg result)))
-        (option '(#\u "upgrade") #t #f
+        (option '(#\u "upgrade") #f #t
                 (lambda (opt name arg result)
                   (alist-cons 'upgrade arg result)))
         (option '("roll-back") #f #f
@@ -602,7 +602,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
         (let* ((installed (manifest-packages (profile-manifest profile)))
                (upgrade-regexps (filter-map (match-lambda
                                              (('upgrade . regexp)
-                                              (make-regexp regexp))
+                                              (make-regexp (or regexp "")))
                                              (_ #f))
                                             opts))
                (upgrade  (if (null? upgrade-regexps)

From dd36b51bf7cffa389726ad997465b14f7072944a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 17 Apr 2013 00:06:59 +0200
Subject: [PATCH 30/74] scripts: Report what will be substituted.

* guix/derivations.scm (derivation-input-output-paths): New procedure.
  (derivation-prerequisites-to-build): New `use-substitutes?' keyword
  argument.  Change two return the list of substitutable paths as a
  second argument.
* guix/ui.scm (show-what-to-build): Turn `dry-run?' into a keyword
  argument.  New `use-substitutes?' keyword argument.  Use `fold2' and
  adjust to use both return values of
  `derivation-prerequisites-to-build'.  Display what will/would be
  downloaded.
* guix/scripts/build.scm (guix-build): Adjust accordingly.
* guix/scripts/package.scm (guix-package): Likewise.
* tests/derivations.scm ("derivation-prerequisites-to-build and
  substitutes"): New test.
---
 guix/derivations.scm     | 115 +++++++++++++++++++++++++++------------
 guix/scripts/build.scm   |   4 +-
 guix/scripts/package.scm |   4 +-
 guix/ui.scm              |  81 +++++++++++++++++++--------
 tests/derivations.scm    |  46 ++++++++++++++++
 5 files changed, 190 insertions(+), 60 deletions(-)

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 2243d2ba46..cf329819c4 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -48,6 +48,7 @@
             derivation-input?
             derivation-input-path
             derivation-input-sub-derivations
+            derivation-input-output-paths
 
             fixed-output-derivation?
             derivation-hash
@@ -99,6 +100,14 @@ download with a fixed hash (aka. `fetchurl')."
      #t)
     (_ #f)))
 
+(define (derivation-input-output-paths input)
+  "Return the list of output paths corresponding to INPUT, a
+<derivation-input>."
+  (match input
+    (($ <derivation-input> path sub-drvs)
+     (map (cut derivation-path->output-path path <>)
+          sub-drvs))))
+
 (define (derivation-prerequisites drv)
   "Return the list of derivation-inputs required to build DRV, recursively."
   (let loop ((drv    drv)
@@ -113,47 +122,85 @@ download with a fixed hash (aka. `fetchurl')."
                  inputs)))))
 
 (define* (derivation-prerequisites-to-build store drv
-                                            #:key (outputs
-                                                   (map
-                                                    car
-                                                    (derivation-outputs drv))))
-  "Return the list of derivation-inputs required to build the OUTPUTS of
-DRV and not already available in STORE, recursively."
+                                            #:key
+                                            (outputs
+                                             (map
+                                              car
+                                              (derivation-outputs drv)))
+                                            (use-substitutes? #t))
+  "Return two values: the list of derivation-inputs required to build the
+OUTPUTS of DRV and not already available in STORE, recursively, and the list
+of required store paths that can be substituted.  When USE-SUBSTITUTES? is #f,
+that second value is the empty list."
+  (define (derivation-output-paths drv sub-drvs)
+    (match drv
+      (($ <derivation> outputs)
+       (map (lambda (sub-drv)
+              (derivation-output-path (assoc-ref outputs sub-drv)))
+            sub-drvs))))
+
   (define built?
     (cut valid-path? store <>))
 
+  (define substitutable?
+    ;; Return true if the given path is substitutable.  Call
+    ;; `substitutable-paths' upfront, to benefit from parallelism in the
+    ;; substituter.
+    (if use-substitutes?
+        (let ((s (substitutable-paths store
+                                      (append
+                                       (derivation-output-paths drv outputs)
+                                       (append-map
+                                        derivation-input-output-paths
+                                        (derivation-prerequisites drv))))))
+          (cut member <> s))
+        (const #f)))
+
   (define input-built?
-    (match-lambda
-     (($ <derivation-input> path sub-drvs)
-      (let ((out (map (cut derivation-path->output-path path <>)
-                      sub-drvs)))
-        (any built? out)))))
+    (compose (cut any built? <>) derivation-input-output-paths))
+
+  (define input-substitutable?
+    ;; Return true if and only if all of SUB-DRVS are subsitutable.  If at
+    ;; least one is missing, then everything must be rebuilt.
+    (compose (cut every substitutable? <>) derivation-input-output-paths))
 
   (define (derivation-built? drv sub-drvs)
-    (match drv
-      (($ <derivation> outputs)
-       (let ((paths (map (lambda (sub-drv)
-                           (derivation-output-path
-                            (assoc-ref outputs sub-drv)))
-                         sub-drvs)))
-         (every built? paths)))))
+    (every built? (derivation-output-paths drv sub-drvs)))
 
-  (let loop ((drv      drv)
-             (sub-drvs outputs)
-             (result   '()))
-    (if (derivation-built? drv sub-drvs)
-        result
-        (let ((inputs (remove (lambda (i)
-                                (or (member i result) ; XXX: quadratic
-                                    (input-built? i)))
-                              (derivation-inputs drv))))
-          (fold loop
-                (append inputs result)
-                (map (lambda (i)
-                       (call-with-input-file (derivation-input-path i)
-                         read-derivation))
-                     inputs)
-                (map derivation-input-sub-derivations inputs))))))
+  (define (derivation-substitutable? drv sub-drvs)
+    (every substitutable? (derivation-output-paths drv sub-drvs)))
+
+  (let loop ((drv        drv)
+             (sub-drvs   outputs)
+             (build      '())
+             (substitute '()))
+    (cond ((derivation-built? drv sub-drvs)
+           (values build substitute))
+          ((derivation-substitutable? drv sub-drvs)
+           (values build
+                   (append (derivation-output-paths drv sub-drvs)
+                           substitute)))
+          (else
+           (let ((inputs (remove (lambda (i)
+                                   (or (member i build) ; XXX: quadratic
+                                       (input-built? i)
+                                       (input-substitutable? i)))
+                                 (derivation-inputs drv))))
+             (fold2 loop
+                    (append inputs build)
+                    (append (append-map (lambda (input)
+                                          (if (and (not (input-built? input))
+                                                   (input-substitutable? input))
+                                              (derivation-input-output-paths
+                                               input)
+                                              '()))
+                                        (derivation-inputs drv))
+                            substitute)
+                    (map (lambda (i)
+                           (call-with-input-file (derivation-input-path i)
+                             read-derivation))
+                         inputs)
+                    (map derivation-input-sub-derivations inputs)))))))
 
 (define (%read-derivation drv-port)
   ;; Actually read derivation from DRV-PORT.
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 339ad0d06f..f296f3031f 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -237,7 +237,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
                                    (_ #f))
                                   opts)))
 
-          (show-what-to-build (%store) drv (assoc-ref opts 'dry-run?))
+          (show-what-to-build (%store) drv
+                              #:use-substitutes? (assoc-ref opts 'substitutes?)
+                              #:dry-run? (assoc-ref opts 'dry-run?))
 
           ;; TODO: Add more options.
           (set-build-options (%store)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 5b340c6ab7..f83c0573e7 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -674,7 +674,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
             (ensure-default-profile))
 
           (show-what-to-remove/install remove* install* dry-run?)
-          (show-what-to-build (%store) drv dry-run?)
+          (show-what-to-build (%store) drv
+                              #:use-substitutes? (assoc-ref opts 'substitutes?)
+                              #:dry-run? dry-run?)
 
           (or dry-run?
               (and (build-derivations (%store) drv)
diff --git a/guix/ui.scm b/guix/ui.scm
index dfb6418a10..db0711bb61 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -144,33 +144,66 @@ error."
           (leave (_ "expression `~s' does not evaluate to a package~%")
                  exp)))))
 
-(define* (show-what-to-build store drv #:optional dry-run?)
+(define* (show-what-to-build store drv
+                             #:key dry-run? (use-substitutes? #t))
   "Show what will or would (depending on DRY-RUN?) be built in realizing the
 derivations listed in DRV.  Return #t if there's something to build, #f
-otherwise."
-  (let* ((req  (append-map (lambda (drv-path)
-                             (let ((d (call-with-input-file drv-path
-                                        read-derivation)))
-                               (derivation-prerequisites-to-build
-                                store d)))
-                           drv))
-         (req* (delete-duplicates
-                (append (remove (compose (cute valid-path? store <>)
-                                         derivation-path->output-path)
-                                drv)
-                        (map derivation-input-path req)))))
+otherwise.  When USE-SUBSTITUTES?, check and report what is prerequisites are
+available for download."
+  (let*-values (((build download)
+                 (fold2 (lambda (drv-path build download)
+                          (let ((drv (call-with-input-file drv-path
+                                       read-derivation)))
+                            (let-values (((b d)
+                                          (derivation-prerequisites-to-build
+                                           store drv
+                                           #:use-substitutes?
+                                           use-substitutes?)))
+                              (values (append b build)
+                                      (append d download)))))
+                        '() '()
+                        drv))
+                ((build)                          ; add the DRV themselves
+                 (delete-duplicates
+                  (append (remove (compose (lambda (out)
+                                             (or (valid-path? store out)
+                                                 (and use-substitutes?
+                                                      (has-substitutes? store
+                                                                        out))))
+                                           derivation-path->output-path)
+                                  drv)
+                          (map derivation-input-path build))))
+                ((download)                   ; add the references of DOWNLOAD
+                 (delete-duplicates
+                  (append download
+                          (remove (cut valid-path? store <>)
+                                  (append-map
+                                   substitutable-references
+                                   (substitutable-path-info store download)))))))
     (if dry-run?
-        (format (current-error-port)
-                (N_ "~:[the following derivation would be built:~%~{   ~a~%~}~;~]"
-                    "~:[the following derivations would be built:~%~{    ~a~%~}~;~]"
-                    (length req*))
-                (null? req*) req*)
-        (format (current-error-port)
-                (N_ "~:[the following derivation will be built:~%~{   ~a~%~}~;~]"
-                    "~:[the following derivations will be built:~%~{    ~a~%~}~;~]"
-                    (length req*))
-                (null? req*) req*))
-    (pair? req*)))
+        (begin
+          (format (current-error-port)
+                  (N_ "~:[the following derivation would be built:~%~{   ~a~%~}~;~]"
+                      "~:[the following derivations would be built:~%~{    ~a~%~}~;~]"
+                      (length build))
+                  (null? build) build)
+          (format (current-error-port)
+                  (N_ "~:[the following file would be downloaded:~%~{   ~a~%~}~;~]"
+                      "~:[the following files would be downloaded:~%~{    ~a~%~}~;~]"
+                      (length download))
+                  (null? download) download))
+        (begin
+          (format (current-error-port)
+                  (N_ "~:[the following derivation will be built:~%~{   ~a~%~}~;~]"
+                      "~:[the following derivations will be built:~%~{    ~a~%~}~;~]"
+                      (length build))
+                  (null? build) build)
+          (format (current-error-port)
+                  (N_ "~:[the following file will be downloaded:~%~{   ~a~%~}~;~]"
+                      "~:[the following files will be downloaded:~%~{    ~a~%~}~;~]"
+                      (length download))
+                  (null? download) download)))
+    (pair? build)))
 
 (define-syntax with-error-handling
   (syntax-rules ()
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 6012e73216..a50c1af878 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -32,6 +32,7 @@
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
+  #:use-module (web uri)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 ftw)
@@ -398,6 +399,51 @@
          ;; prerequisite to build because DRV itself is already built.
          (null? (derivation-prerequisites-to-build %store drv)))))
 
+(test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
+(test-assert "derivation-prerequisites-to-build and substitutes"
+  (let*-values (((store)
+                 (open-connection))
+                ((drv-path drv)
+                 (build-expression->derivation store "prereq-subst"
+                                               (%current-system)
+                                               (random 1000) '()))
+                ((output)
+                 (derivation-output-path
+                  (assoc-ref (derivation-outputs drv) "out")))
+                ((dir)
+                 (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
+                        (compose uri-path string->uri))))
+    ;; Create fake substituter data, to be read by `substitute-binary'.
+    (call-with-output-file (string-append dir "/nix-cache-info")
+      (lambda (p)
+        (format p "StoreDir: ~a\nWantMassQuery: 0\n"
+                (%store-prefix))))
+    (call-with-output-file (string-append dir "/" (store-path-hash-part output)
+                                          ".narinfo")
+      (lambda (p)
+        (format p "StorePath: ~a
+URL: ~a
+Compression: none
+NarSize: 1234
+References: 
+System: ~a
+Deriver: ~a~%"
+                output                              ; StorePath
+                (string-append dir "/example.nar")  ; URL
+                (%current-system)                   ; System
+                (basename drv-path))))              ; Deriver
+
+    (let-values (((build download)
+                  (derivation-prerequisites-to-build store drv))
+                 ((build* download*)
+                  (derivation-prerequisites-to-build store drv
+                                                     #:use-substitutes? #f)))
+      (pk build download build* download*)
+      (and (null? build)
+           (equal? download (list output))
+           (null? download*)
+           (null? build*)))))
+
 (test-assert "build-expression->derivation with expression returning #f"
   (let* ((builder  '(begin
                       (mkdir %output)

From 801486fe46b288338de6ed542c70acade45aac9a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 17 Apr 2013 18:02:48 +0200
Subject: [PATCH 31/74] ui: Fix format string in `warning'.

* guix/ui.scm (warning)[augmented-format-string]: Add missing ~*.
---
 guix/ui.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/guix/ui.scm b/guix/ui.scm
index db0711bb61..938b5d259c 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -381,7 +381,7 @@ WIDTH columns."
     ;; All this just to preserve `-Wformat' warnings.  Too much?
 
     (define (augmented-format-string fmt)
-      (string-append "~:[~;guix ~a: ~]~a" (syntax->datum fmt)))
+      (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))
 
     (define prefix
       #'(_ "warning: "))

From f50d2669e3e624365221cc81918ba55fdce94107 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 17 Apr 2013 18:04:25 +0200
Subject: [PATCH 32/74] gnu: Use synopses from the Womb.

* gnu/packages/algebra.scm,
  gnu/packages/aspell.scm,
  gnu/packages/autotools.scm,
  gnu/packages/base.scm,
  gnu/packages/bash.scm,
  gnu/packages/bison.scm,
  gnu/packages/cdrom.scm,
  gnu/packages/cflow.scm,
  gnu/packages/compression.scm,
  gnu/packages/cpio.scm,
  gnu/packages/cppi.scm,
  gnu/packages/ddrescue.scm,
  gnu/packages/dejagnu.scm,
  gnu/packages/ed.scm,
  gnu/packages/emacs.scm,
  gnu/packages/fdisk.scm,
  gnu/packages/gawk.scm,
  gnu/packages/gcc.scm,
packages/gcc.scm, b/gnu/packages/gcc.scm,
4b982 100644
s/gcc.scm,
s/gcc.scm,
@@
         %standard-phases)))))

 `((gcc-libc . ,(assoc-ref inputs "libc"))))
The GNU Compiler Collection")
GNU Compiler Collection")
n
ompiler Collection includes compiler front ends for C, C++,
tran, OpenMP for C/C++/Fortran, Java, and Ada, as well as
  gnu/packages/gdb.scm,
  gnu/packages/gettext.scm,
  gnu/packages/ghostscript.scm,
  gnu/packages/glib.scm,
  gnu/packages/global.scm,
  gnu/packages/gnupg.scm,
  gnu/packages/gnutls.scm,
  gnu/packages/gperf.scm,
  gnu/packages/gprolog.scm,
  gnu/packages/groff.scm,
  gnu/packages/grub.scm,
  gnu/packages/gsasl.scm,
  gnu/packages/guile.scm,
  gnu/packages/help2man.scm,
  gnu/packages/idutils.scm,
  gnu/packages/indent.scm,
  gnu/packages/less.scm,
  gnu/packages/libidn.scm,
  gnu/packages/libsigsegv.scm,
  gnu/packages/libunistring.scm,
  gnu/packages/linux.scm,
  gnu/packages/lsh.scm,
  gnu/packages/m4.scm,
  gnu/packages/mailutils.scm,
  gnu/packages/multiprecision.scm,
  gnu/packages/nano.scm,
  gnu/packages/ncurses.scm,
  gnu/packages/nettle.scm,
  gnu/packages/oggvorbis.scm,
  gnu/packages/parted.scm,
  gnu/packages/pth.scm,
  gnu/packages/readline.scm,
  gnu/packages/recutils.scm,
  gnu/packages/scheme.scm,
  gnu/packages/screen.scm,
  gnu/packages/shishi.scm,
  gnu/packages/smalltalk.scm,
  gnu/packages/system.scm,
  gnu/packages/texinfo.scm,
  gnu/packages/time.scm,
  gnu/packages/wdiff.scm,
  gnu/packages/wget.scm,
  gnu/packages/which.scm: Use synopses from the Womb.
---
 gnu/packages/algebra.scm        |  4 ++--
 gnu/packages/aspell.scm         |  3 +--
 gnu/packages/autotools.scm      |  8 +++-----
 gnu/packages/base.scm           | 25 ++++++++++---------------
 gnu/packages/bash.scm           |  2 +-
 gnu/packages/bison.scm          |  3 +--
 gnu/packages/cdrom.scm          |  4 ++--
 gnu/packages/cflow.scm          |  2 +-
 gnu/packages/compression.scm    |  2 +-
 gnu/packages/cpio.scm           |  5 ++---
 gnu/packages/cppi.scm           |  2 +-
 gnu/packages/ddrescue.scm       |  2 +-
 gnu/packages/dejagnu.scm        |  2 +-
 gnu/packages/ed.scm             |  3 +--
 gnu/packages/emacs.scm          |  3 +--
 gnu/packages/fdisk.scm          |  5 ++---
 gnu/packages/gawk.scm           |  2 +-
 gnu/packages/gcc.scm            |  2 +-
 gnu/packages/gdb.scm            |  2 +-
 gnu/packages/gettext.scm        |  3 +--
 gnu/packages/ghostscript.scm    |  2 +-
 gnu/packages/glib.scm           |  2 +-
 gnu/packages/global.scm         |  2 +-
 gnu/packages/gnupg.scm          |  6 ++----
 gnu/packages/gnutls.scm         |  4 ++--
 gnu/packages/gperf.scm          |  3 +--
 gnu/packages/gprolog.scm        |  6 ++----
 gnu/packages/groff.scm          |  2 +-
 gnu/packages/grub.scm           |  3 +--
 gnu/packages/gsasl.scm          |  4 ++--
 gnu/packages/guile.scm          | 10 ++++------
 gnu/packages/help2man.scm       |  2 +-
 gnu/packages/idutils.scm        |  2 +-
 gnu/packages/indent.scm         |  2 +-
 gnu/packages/less.scm           |  6 ++----
 gnu/packages/libidn.scm         |  2 +-
 gnu/packages/libsigsegv.scm     |  2 +-
 gnu/packages/libunistring.scm   |  2 +-
 gnu/packages/linux.scm          |  2 +-
 gnu/packages/lsh.scm            |  3 +--
 gnu/packages/m4.scm             |  2 +-
 gnu/packages/mailutils.scm      |  2 +-
 gnu/packages/multiprecision.scm |  8 +++-----
 gnu/packages/nano.scm           |  5 ++---
 gnu/packages/ncurses.scm        |  3 +--
 gnu/packages/nettle.scm         |  2 +-
 gnu/packages/oggvorbis.scm      |  3 +--
 gnu/packages/parted.scm         |  5 ++---
 gnu/packages/pth.scm            |  2 +-
 gnu/packages/readline.scm       |  2 +-
 gnu/packages/recutils.scm       |  3 +--
 gnu/packages/scheme.scm         |  2 +-
 gnu/packages/screen.scm         |  2 +-
 gnu/packages/shishi.scm         |  3 +--
 gnu/packages/smalltalk.scm      |  3 +--
 gnu/packages/system.scm         |  6 ++----
 gnu/packages/texinfo.scm        |  2 +-
 gnu/packages/time.scm           |  4 +---
 gnu/packages/wdiff.scm          |  5 ++---
 gnu/packages/wget.scm           |  3 +--
 gnu/packages/which.scm          |  3 +--
 gnu/packages/zile.scm           |  2 +-
 62 files changed, 91 insertions(+), 132 deletions(-)

diff --git a/gnu/packages/algebra.scm b/gnu/packages/algebra.scm
index 8d51c16814..87f7d0e9d7 100644
--- a/gnu/packages/algebra.scm
+++ b/gnu/packages/algebra.scm
@@ -92,7 +92,7 @@ solve the shortest vector problem.")
         "18qf6jzz1r3mzb5qynywv4xx3z9g61hgkbpkdrhbgqh2g7jhgfc5"))))
     (build-system gnu-build-system)
     (home-page "http://www.gnu.org/software/gsl/")
-    (synopsis "The GNU Scientific Library, a large numerical library")
+    (synopsis "Numerical library for C and C++")
     (description
      "The GNU Scientific Library (GSL) is a numerical library for C
 and C++ programmers.  It is free software under the GNU General
@@ -177,7 +177,7 @@ PARI is also available as a C library to allow for faster computations.")
                                     (string-append "--prefix=" out)))))
                       %standard-phases)))
     (home-page "http://www.gnu.org/software/bc/")
-    (synopsis "GNU software calculator")
+    (synopsis "Arbitrary precision numeric processing language")
     (description
      "bc is an arbitrary precision numeric processing language. Syntax
 is similar to C, but differs in many substantial areas. It supports
diff --git a/gnu/packages/aspell.scm b/gnu/packages/aspell.scm
index ca0218d814..0b8d761266 100644
--- a/gnu/packages/aspell.scm
+++ b/gnu/packages/aspell.scm
@@ -38,8 +38,7 @@
     (build-system gnu-build-system)
     (inputs `(("perl" ,perl)))
     (home-page "http://aspell.net/")
-    (synopsis
-     "GNU Aspell, A spell checker for many languages")
+    (synopsis "Spell checker")
     (description
      "GNU Aspell is a free spell checker designed to eventually replace
 Ispell.  It can either be used as a library or as an independent spell
diff --git a/gnu/packages/autotools.scm b/gnu/packages/autotools.scm
index 51aadbf0ec..4af6d2a6cf 100644
--- a/gnu/packages/autotools.scm
+++ b/gnu/packages/autotools.scm
@@ -50,8 +50,7 @@
     (arguments `(#:tests? #f))
     (home-page
      "http://www.gnu.org/software/autoconf/")
-    (synopsis
-     "GNU Autoconf, a part of the GNU Build System")
+    (synopsis "Create source code configuration scripts")
     (description
      "GNU Autoconf is an extensible package of M4 macros that produce
 shell scripts to automatically configure software source code
@@ -198,8 +197,7 @@ exec ~a --no-auto-compile \"$0\" \"$@\"
                                 (find-files dir ".*"))))
                   %standard-phases))))
     (home-page "http://www.gnu.org/software/automake/")
-    (synopsis
-     "GNU Automake, a GNU standard-compliant makefile generator")
+    (synopsis "Making GNU standards-compliant Makefiles")
     (description
      "GNU Automake is a tool for automatically generating
 `Makefile.in' files compliant with the GNU Coding
@@ -253,7 +251,7 @@ Standards.  Automake requires the use of Autoconf.")
                  %standard-phases)))
     (inputs `(("patch/skip-tests"
                ,(search-patch "libtool-skip-tests.patch"))))
-    (synopsis "GNU Libtool, a generic library support script")
+    (synopsis "Generic shared library support tools")
     (description
      "GNU libtool is a generic library support script.  Libtool hides the
 complexity of using shared libraries behind a consistent, portable interface.
diff --git a/gnu/packages/base.scm b/gnu/packages/base.scm
index 92b94dc035..1eaa4fb860 100644
--- a/gnu/packages/base.scm
+++ b/gnu/packages/base.scm
@@ -61,7 +61,7 @@
                   ,(string-append "--with-gawk="  ; for illustration purposes
                                  (assoc-ref %build-inputs "gawk")))))
    (inputs `(("gawk" ,gawk)))
-   (synopsis "GNU Hello")
+   (synopsis "Hello, GNU world: An example GNU package")
    (description "Yeah...")
    (home-page "http://www.gnu.org/software/hello/")
    (license gpl3+)))
@@ -78,7 +78,7 @@
              (base32
               "1qbjb1l7f9blckc5pqy8jlf6482hpx4awn2acmhyf5mv9wfq03p7"))))
    (build-system gnu-build-system)
-   (synopsis "GNU implementation of the Unix grep command")
+   (synopsis "Print lines matching a pattern")
    (description
     "The grep command searches one or more input files for lines containing a
 match to a specified pattern.  By default, grep prints the matching
@@ -98,7 +98,7 @@ lines.")
              (base32
               "13wlsb4sf5d5a82xjhxqmdvrrn36rmw5f0pl9qyb9zkvldnb7hra"))))
    (build-system gnu-build-system)
-   (synopsis "GNU sed, a batch stream editor")
+   (synopsis "Stream editor")
    (arguments
     `(#:phases (alist-cons-before
                 'patch-source-shebangs 'patch-test-suite
@@ -134,7 +134,7 @@ substituting multiple occurrences of a string within a file.")
    (inputs `(("patch/gets" ,(search-patch "tar-gets-undeclared.patch"))))
    (arguments
     `(#:patches (list (assoc-ref %build-inputs "patch/gets"))))
-   (synopsis "GNU implementation of the `tar' archiver")
+   (synopsis "Managing tar archives")
    (description
     "The Tar program provides the ability to create tar archives, as well as
 various other kinds of manipulation.  For example, you can use Tar on
@@ -167,7 +167,7 @@ files (as archives).")
     ;; TODO: When cross-compiling, add this:
     ;;  '(#:configure-flags '("ac_cv_func_strnlen_working=yes"))
     )
-   (synopsis "GNU Patch, a program to apply differences to files")
+   (synopsis "Apply differences to originals, with optional backups")
    (description
     "GNU Patch takes a patch file containing a difference listing produced by
 the diff program and applies those differences to one or more original files,
@@ -190,7 +190,7 @@ producing patched versions.")
    (inputs `(("patch/gets"
               ,(search-patch "diffutils-gets-undeclared.patch"))))
    (arguments `(#:patches (list (assoc-ref %build-inputs "patch/gets"))))
-   (synopsis "Programs to find differences among text files")
+   (synopsis "Comparing and merging files")
    (description
     "GNU Diffutils is a package of several programs related to finding
 differences between files.
@@ -243,8 +243,7 @@ You can use the sdiff command to merge two files interactively.")
     ;; `(#:configure-flags '("gl_cv_func_wcwidth_works=yes")
     ;;   ,@(arguments cross-system))
     )
-   (synopsis "Basic directory searching utilities of the GNU operating
-system")
+   (synopsis "Operating on files matching given criteria")
    (description
     "The GNU Find Utilities are the basic directory searching utilities of
 the GNU operating system.  These programs are typically used in conjunction
@@ -291,9 +290,7 @@ The tools supplied with this package are:
                       (("#!/bin/sh")
                        (format #f "#!~a/bin/bash" bash)))))
                 %standard-phases)))
-   (synopsis
-    "The basic file, shell and text manipulation utilities of the GNU
-operating system")
+   (synopsis "Core GNU utilities (file, text, shell)")
    (description
     "The GNU Core Utilities are the basic file, shell and text manipulation
 utilities of the GNU operating system.  These are the core utilities which
@@ -327,8 +324,7 @@ are expected to exist on every operating system.")
                        (format #f "default_shell[] = \"~a/bin/bash\";\n"
                                bash)))))
                 %standard-phases)))
-   (synopsis "GNU Make, a program controlling the generation of non-source
-files from sources")
+   (synopsis "Remake files automatically")
    (description
     "Make is a tool which controls the generation of executables and other
 non-source files of a program from the program's source files.
@@ -370,8 +366,7 @@ that it is possible to use Make to build and install the program.")
                           ;; Don't search under /usr/lib & co.
                           "--with-lib-path=/no-ld-lib-path")))
 
-   (synopsis "GNU Binutils, tools for manipulating binaries (linker,
-assembler, etc.)")
+   (synopsis "Binary utilities: bfd gas gprof ld")
    (description
     "The GNU Binutils are a collection of binary tools.  The main ones are
 `ld' (the GNU linker) and `as' (the GNU assembler).  They also include the
diff --git a/gnu/packages/bash.scm b/gnu/packages/bash.scm
index d74315ad18..7caa26f36c 100644
--- a/gnu/packages/bash.scm
+++ b/gnu/packages/bash.scm
@@ -76,7 +76,7 @@
         #:phases (alist-cons-after 'install 'post-install
                                    ,post-install-phase
                                    %standard-phases)))
-     (synopsis "GNU Bourne-Again Shell")
+     (synopsis "The GNU Bourne-Again SHell")
      (description
       "Bash is the shell, or command language interpreter, that will appear in
 the GNU operating system.  Bash is an sh-compatible shell that incorporates
diff --git a/gnu/packages/bison.scm b/gnu/packages/bison.scm
index 95ffb17522..11483b1434 100644
--- a/gnu/packages/bison.scm
+++ b/gnu/packages/bison.scm
@@ -40,8 +40,7 @@
     (inputs `(("perl" ,perl)))
     (propagated-inputs `(("m4" ,m4)))
     (home-page "http://www.gnu.org/software/bison/")
-    (synopsis
-     "GNU Bison, a Yacc-compatible parser generator")
+    (synopsis "Parser generator")
     (description
      "Bison is a general-purpose parser generator that converts an
 annotated context-free grammar into an LALR(1) or GLR parser for
diff --git a/gnu/packages/cdrom.scm b/gnu/packages/cdrom.scm
index 225ed2fa9c..ccab52fc56 100644
--- a/gnu/packages/cdrom.scm
+++ b/gnu/packages/cdrom.scm
@@ -78,7 +78,7 @@ caching facility provided by the library.")
        ("pkg-config" ,pkg-config)
        ("libcddb" ,libcddb)))
     (home-page "http://www.gnu.org/software/libcdio/")
-    (synopsis "A library for OS-independent CD-ROM and CD image access")
+    (synopsis "CD Input and Control library")
     (description
      "GNU libcdio is a library for OS-idependent CD-ROM and CD image access.
 It includes a library for working with ISO-9660 filesystems (libiso9660), as
@@ -104,7 +104,7 @@ well as utility programs such as an audio CD player and an extractor.")
        ("zlib" ,zlib)
        ("libcdio" ,libcdio)))
     (home-page "http://www.gnu.org/software/xorriso/")
-    (synopsis "An ISO 9660 Rock Ridge file system manipulator")
+    (synopsis "Create, manipulate, burn ISO-9660 filesystems")
     (description
      "GNU xorriso copies file objects from POSIX compliant filesystems into
 Rock Ridge enhanced ISO 9660 filesystems and allows session-wise manipulation
diff --git a/gnu/packages/cflow.scm b/gnu/packages/cflow.scm
index bb000ddc59..caf690bc4c 100644
--- a/gnu/packages/cflow.scm
+++ b/gnu/packages/cflow.scm
@@ -36,7 +36,7 @@
                "1jkbq97ajcf834z68hbn3xfhiz921zhn39gklml1racf0kb3jzh3"))))
     (build-system gnu-build-system)
     (home-page "http://www.gnu.org/software/cflow/")
-    (synopsis "A tool to analyze the control flow of C programs")
+    (synopsis "Create a graph of control flow within a program")
     (description
      "GNU cflow analyzes a collection of C source files and prints a
 graph, charting control flow within the program.
diff --git a/gnu/packages/compression.scm b/gnu/packages/compression.scm
index 086900990b..89cb014a3c 100644
--- a/gnu/packages/compression.scm
+++ b/gnu/packages/compression.scm
@@ -73,7 +73,7 @@ in compression.")
              (base32
               "18rm80kar7n016g8bsyy1a3zk50i2826xdgs874yh64rzj7nxmdm"))))
    (build-system gnu-build-system)
-   (synopsis "Gzip, the GNU zip compression program")
+   (synopsis "General file (de)compression (using lzw)")
    (arguments
     ;; FIXME: The test suite wants `less', and optionally Perl.
     '(#:tests? #f))
diff --git a/gnu/packages/cpio.scm b/gnu/packages/cpio.scm
index 711d64d7af..8512499b7b 100644
--- a/gnu/packages/cpio.scm
+++ b/gnu/packages/cpio.scm
@@ -42,8 +42,7 @@
     (inputs
      `(("patch/gets" ,(search-patch "cpio-gets-undeclared.patch"))))
     (home-page "https://www.gnu.org/software/cpio/")
-    (synopsis
-     "A program to create or extract from cpio archives")
+    (synopsis "Manage cpio and tar file archives")
     (description
      "GNU Cpio copies files into or out of a cpio or tar archive. The
 archive can be another file on the disk, a magnetic tape, or a pipe.
@@ -55,4 +54,4 @@ default, cpio creates binary format archives, for compatibility with
 older cpio programs. When extracting from archives, cpio automatically
 recognizes which kind of archive it is reading and can read archives
 created on machines with a different byte-order.")
-    (license gpl3+)))
\ No newline at end of file
+    (license gpl3+)))
diff --git a/gnu/packages/cppi.scm b/gnu/packages/cppi.scm
index 53f24698fc..d28fc40173 100644
--- a/gnu/packages/cppi.scm
+++ b/gnu/packages/cppi.scm
@@ -35,7 +35,7 @@
                "1jk42cjaggk71rimjnx3qpmb6hivps0917vl3z7wbxk3i2whb98j"))))
     (build-system gnu-build-system)
     (home-page "http://www.gnu.org/software/cppi/")
-    (synopsis "A cpp directive indenter")
+    (synopsis "Indent C preprocessor directives to reflect nesting and more")
     (description
      "GNU cppi indents C preprocessor directives to reflect their nesting and
 ensure that there is exactly one space character between each #if, #elif,
diff --git a/gnu/packages/ddrescue.scm b/gnu/packages/ddrescue.scm
index 0d5533d423..5c653af6db 100644
--- a/gnu/packages/ddrescue.scm
+++ b/gnu/packages/ddrescue.scm
@@ -37,7 +37,7 @@
     (build-system gnu-build-system)
     (home-page
      "http://www.gnu.org/software/ddrescue/ddrescue.html")
-    (synopsis "GNU Ddrescue, a data recovery tool")
+    (synopsis "Data recovery utility")
     (description
      "GNU Ddrescue is a data recovery tool.  It copies data from one
 file or block device (e.g., hard disk, CD-ROM) to another, trying hard to
diff --git a/gnu/packages/dejagnu.scm b/gnu/packages/dejagnu.scm
index 1efc7c78e7..999d976ec7 100644
--- a/gnu/packages/dejagnu.scm
+++ b/gnu/packages/dejagnu.scm
@@ -75,7 +75,7 @@
                   %standard-phases))))
     (home-page
      "http://www.gnu.org/software/dejagnu/")
-    (synopsis "The DejaGNU testing framework")
+    (synopsis "GNU software testing framework")
     (description
      "DejaGnu is a framework for testing other programs.  Its purpose
 is to provide a single front end for all tests.  Think of it as a
diff --git a/gnu/packages/ed.scm b/gnu/packages/ed.scm
index de76bee38d..0f387be797 100644
--- a/gnu/packages/ed.scm
+++ b/gnu/packages/ed.scm
@@ -43,8 +43,7 @@
                                        (("/bin/sh") (which "sh"))))
                                    %standard-phases)))
     (home-page "http://www.gnu.org/software/ed/")
-    (synopsis
-     "GNU ed, an implementation of the standard Unix editor")
+    (synopsis "Line-oriented text editor")
     (description
      "GNU ed is a line-oriented text editor.  It is used to create,
 display, modify and otherwise manipulate text files, both
diff --git a/gnu/packages/emacs.scm b/gnu/packages/emacs.scm
index 9a107967a3..250fcf2401 100644
--- a/gnu/packages/emacs.scm
+++ b/gnu/packages/emacs.scm
@@ -74,8 +74,7 @@
        ("patch/epaths" ,(search-patch "emacs-configure-sh.patch"))
        ))
     (home-page "http://www.gnu.org/software/emacs/")
-    (synopsis
-     "GNU Emacs 24, the extensible, customizable text editor")
+    (synopsis "The extensible, customizable, self-documenting text editor")
     (description
      "GNU Emacs is an extensible, customizable text editor—and more.  At its
 core is an interpreter for Emacs Lisp, a dialect of the Lisp
diff --git a/gnu/packages/fdisk.scm b/gnu/packages/fdisk.scm
index 5cf02a9014..6248feb98b 100644
--- a/gnu/packages/fdisk.scm
+++ b/gnu/packages/fdisk.scm
@@ -46,9 +46,8 @@
        ("util-linux" ,util-linux)
        ("parted" ,parted)))
     (home-page "https://www.gnu.org/software/fdisk/")
-    (synopsis
-     "GNU Fdisk, a command-line disk partitioning tool")
+    (synopsis "Low-level disk partitioning and formatting")
     (description
      "GNU Fdisk provides alternatives to util-linux fdisk and util-linux
 cfdisk.  It uses GNU Parted.")
-    (license gpl3+)))
\ No newline at end of file
+    (license gpl3+)))
diff --git a/gnu/packages/gawk.scm b/gnu/packages/gawk.scm
index 5279544db9..15ff2a4401 100644
--- a/gnu/packages/gawk.scm
+++ b/gnu/packages/gawk.scm
@@ -51,7 +51,7 @@
                 %standard-phases)))
    (inputs `(("libsigsegv" ,libsigsegv)))
    (home-page "http://www.gnu.org/software/gawk/")
-   (synopsis "GNU implementation of the Awk programming language")
+   (synopsis "A text scanning and processing language")
    (description
     "Many computer users need to manipulate text files: extract and then
 operate on data from parts of certain lines while discarding the rest, make
diff --git a/gnu/packages/gcc.scm b/gnu/packages/gcc.scm
index 116c1859a9..164b982ab1 100644
--- a/gnu/packages/gcc.scm
+++ b/gnu/packages/gcc.scm
@@ -132,7 +132,7 @@
                          %standard-phases)))))
 
      (properties `((gcc-libc . ,(assoc-ref inputs "libc"))))
-     (synopsis "The GNU Compiler Collection")
+     (synopsis "GNU Compiler Collection")
      (description
       "The GNU Compiler Collection includes compiler front ends for C, C++,
 Objective-C, Fortran, OpenMP for C/C++/Fortran, Java, and Ada, as well as
diff --git a/gnu/packages/gdb.scm b/gnu/packages/gdb.scm
index 71a85a431b..95f542c707 100644
--- a/gnu/packages/gdb.scm
+++ b/gnu/packages/gdb.scm
@@ -57,7 +57,7 @@
        ("texinfo" ,texinfo)
        ("dejagnu" ,dejagnu)))
     (home-page "http://www.gnu.org/software/gdb/")
-    (synopsis "GDB, the GNU Project debugger")
+    (synopsis "The GNU debugger")
     (description
      "GDB, the GNU Project debugger, allows you to see what is going
 on `inside' another program while it executes -- or what another
diff --git a/gnu/packages/gettext.scm b/gnu/packages/gettext.scm
index e85b8f69c3..29ea54924a 100644
--- a/gnu/packages/gettext.scm
+++ b/gnu/packages/gettext.scm
@@ -56,8 +56,7 @@
         ,(search-patch "gettext-gets-undeclared.patch"))))
     (home-page
      "http://www.gnu.org/software/gettext/")
-    (synopsis
-     "GNU gettext, a well integrated set of translation tools and documentation")
+    (synopsis "Tools and documentation for translation")
     (description
      "Usually, programs are written and documented in English, and use
 English at execution time for interacting with users.  Using a common
diff --git a/gnu/packages/ghostscript.scm b/gnu/packages/ghostscript.scm
index 835ed475cc..2c58bca0bd 100644
--- a/gnu/packages/ghostscript.scm
+++ b/gnu/packages/ghostscript.scm
@@ -163,7 +163,7 @@ printing, and psresize, for adjusting page sizes.")
           (apply install args)
           (system* "make" "install-so")))
       %standard-phases)))))
-   (synopsis "GNU Ghostscript, an interpreter for the PostScript language and for PDF")
+   (synopsis "PostScript and PDF interpreter")
    (description
     "GNU Ghostscript is an interpreter for PostScript and Portable Document
 Format (PDF) files.
diff --git a/gnu/packages/glib.scm b/gnu/packages/glib.scm
index fdcc9bdc31..d594a1b068 100644
--- a/gnu/packages/glib.scm
+++ b/gnu/packages/glib.scm
@@ -120,7 +120,7 @@ shared NFS home directories.")
       #:configure-flags (list (string-append "--with-html-dir="
                                              (assoc-ref %outputs "doc")
                                              "/share/gtk-doc"))))
-   (synopsis "C library that provides core application building blocks")
+   (synopsis "Thread-safe general utility library; basis of GTK+ and GNOME")
    (description
     "GLib provides data structure handling for C, portability wrappers,
 and interfaces for such runtime functionality as an event loop, threads,
diff --git a/gnu/packages/global.scm b/gnu/packages/global.scm
index 6ef36d5aea..6ad79d1283 100644
--- a/gnu/packages/global.scm
+++ b/gnu/packages/global.scm
@@ -44,7 +44,7 @@
        (list (string-append "--with-ncurses="
                             (assoc-ref %build-inputs "ncurses")))))
     (home-page "http://www.gnu.org/software/global/")
-    (synopsis "GNU GLOBAL source code tag system")
+    (synopsis "Cross-environment source code tag system")
     (description
      "GNU GLOBAL is a source code tagging system that works the same way
 across diverse environments (Emacs, vi, less, Bash, web browser, etc).
diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm
index 1810b65fe8..f96071e072 100644
--- a/gnu/packages/gnupg.scm
+++ b/gnu/packages/gnupg.scm
@@ -69,8 +69,7 @@ Daemon and possibly more in the future.")
     (propagated-inputs
      `(("libgpg-error" ,libgpg-error)))
     (home-page "http://gnupg.org/")
-    (synopsis
-     "GNU Libgcrypt, a general-pupose cryptographic library")
+    (synopsis "Cryptographic function library")
     (description
      "GNU Libgcrypt is a general purpose cryptographic library based on
 the code from GnuPG.  It provides functions for all
@@ -166,8 +165,7 @@ specifications are building blocks of S/MIME and TLS.")
            (apply configure args)))
        %standard-phases)))
     (home-page "http://gnupg.org/")
-    (synopsis
-     "GNU Privacy Guard (GnuPG), GNU Project's implementation of the OpenPGP standard")
+    (synopsis "GNU Privacy Guard")
     (description
      "GnuPG is the GNU project's complete and free implementation of
 the OpenPGP standard as defined by RFC4880.  GnuPG allows to
diff --git a/gnu/packages/gnutls.scm b/gnu/packages/gnutls.scm
index dc571adc60..e817198db3 100644
--- a/gnu/packages/gnutls.scm
+++ b/gnu/packages/gnutls.scm
@@ -42,7 +42,7 @@
         "0gvgndypwicchf7m660zh7jdgmkfj9g9xavpcc08pyd0120y0bk7"))))
     (build-system gnu-build-system)
     (home-page "http://www.gnu.org/software/libtasn1/")
-    (synopsis "GNU Libtasn1, an ASN.1 library")
+    (synopsis "ASN.1 library")
     (description
      "Libtasn1 is the ASN.1 library used by GnuTLS, GNU Shishi and some
 other packages.  The goal of this implementation is to be highly
@@ -73,7 +73,7 @@ portable, and only require an ANSI C89 platform.")
        ("nettle" ,nettle)
        ("which" ,which)))
     (home-page "http://www.gnu.org/software/gnutls/")
-    (synopsis "The GNU Transport Layer Security Library")
+    (synopsis "Transport layer security library")
     (description
      "GnuTLS is a project that aims to develop a library which provides
 a secure layer, over a reliable transport layer. Currently the GnuTLS
diff --git a/gnu/packages/gperf.scm b/gnu/packages/gperf.scm
index 2425756f1b..3a9d2d97d8 100644
--- a/gnu/packages/gperf.scm
+++ b/gnu/packages/gperf.scm
@@ -37,8 +37,7 @@
     (build-system gnu-build-system)
     (arguments '(#:parallel-tests? #f))
     (home-page "http://www.gnu.org/software/gperf/")
-    (synopsis
-     "GNU gperf, a perfect hash function generator")
+    (synopsis "Perfect hash function generator")
     (description
      "GNU gperf is a perfect hash function generator.  For a given
 list of strings, it produces a hash function and hash table, in
diff --git a/gnu/packages/gprolog.scm b/gnu/packages/gprolog.scm
index ba84d9a836..c362a7bc11 100644
--- a/gnu/packages/gprolog.scm
+++ b/gnu/packages/gprolog.scm
@@ -45,9 +45,7 @@
                      (("= /bin/sh") (string-append "= " (which "sh")))))
                  %standard-phases)))
     (home-page "https://www.gnu.org/software/gprolog/")
-    (synopsis
-     "GNU Prolog, a free Prolog compiler with constraint solving over
-finite domains")
+    (synopsis "Prolog compiler")
     (description
      "GNU Prolog is a free Prolog compiler with constraint solving over
 finite domains developed by Daniel Diaz.
@@ -69,4 +67,4 @@ interface, sockets).
 GNU Prolog also includes an efficient constraint solver over finite domains.
 This opens contraint logic programming to the user combining the power of
 constraint programming to the declarativity of logic programming.")
-    (license (list gpl2+ lgpl3+))))
\ No newline at end of file
+    (license (list gpl2+ lgpl3+))))
diff --git a/gnu/packages/groff.scm b/gnu/packages/groff.scm
index dce87dde1e..5265faeee5 100644
--- a/gnu/packages/groff.scm
+++ b/gnu/packages/groff.scm
@@ -45,7 +45,7 @@
              ("perl" ,perl)
              ("psutils" ,psutils)
              ("texinfo" ,texinfo)))
-   (synopsis "GNU Troff text formatting system")
+   (synopsis "Typesetting from plain text mixed with formatting commands")
    (description
     "GNU Troff (Groff) is a software typesetting package which reads plain
 text mixed with formatting commands and produces formatted output.")
diff --git a/gnu/packages/grub.scm b/gnu/packages/grub.scm
index ee52a6110a..af9c135f2d 100644
--- a/gnu/packages/grub.scm
+++ b/gnu/packages/grub.scm
@@ -73,8 +73,7 @@
        ("qemu" ,qemu)
        ("xorriso" ,xorriso)))
     (home-page "http://www.gnu.org/software/grub/")
-    (synopsis
-     "GNU GRUB, the Grand Unified Boot Loader (2.x beta)")
+    (synopsis "GRand unified boot loader")
     (description
      "GNU GRUB is a Multiboot boot loader. It was derived from GRUB, GRand
 Unified Bootloader, which was originally designed and implemented by Erich
diff --git a/gnu/packages/gsasl.scm b/gnu/packages/gsasl.scm
index 832ae0c2ff..fb5712a7b0 100644
--- a/gnu/packages/gsasl.scm
+++ b/gnu/packages/gsasl.scm
@@ -61,7 +61,7 @@
              ("shishi" ,shishi)
              ("zlib" ,guix:zlib)
             ))
-   (synopsis "GNU GSS (Generic Security Service), a free implementatio of RFC 2743/2744")
+   (synopsis "Generic Security Service library")
    (description
     "GNU GSS is an implementation of the Generic Security Service Application
 Program Interface (GSS-API). GSS-API is used by network servers to provide
@@ -87,7 +87,7 @@ SMTP/IMAP servers. GSS consists of a library and a manual.")
              ("gss" ,gss)
              ("zlib" ,guix:zlib)
              ))
-   (synopsis "GNU SASL, an implementation of the Simple Authentication and Security Layer framework")
+   (synopsis "Simple Authentication and Security Layer library")
    (description
     "GNU SASL is an implementation of the Simple Authentication and Security
 Layer framework and a few common SASL mechanisms. SASL is used by network
diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm
index 58e7c2910c..763584d7dc 100644
--- a/gnu/packages/guile.scm
+++ b/gnu/packages/guile.scm
@@ -88,7 +88,7 @@
    ;; When cross-compiling, a native version of Guile itself is needed.
    (self-native-input? #t)
 
-   (synopsis "GNU Guile 1.8, an embeddable Scheme interpreter")
+   (synopsis "Scheme implementation intended especially for extensions")
    (description
 "GNU Guile 1.8 is an interpreter for the Scheme programming language,
 packaged as a library that can be embedded into programs to make them
@@ -137,7 +137,7 @@ extensible.  It supports many SRFIs.")
                        (string-append bash "/bin/bash")))))
                 %standard-phases)))
 
-   (synopsis "GNU Guile 2.0, an embeddable Scheme implementation")
+   (synopsis "Scheme implementation intended especially for extensions")
    (description
 "GNU Guile is an implementation of the Scheme programming language, with
 support for many SRFIs, packaged for use in a wide variety of environments.
@@ -231,8 +231,7 @@ many readers as needed).")
                                out)))))
                  %standard-phases)))
     (home-page "http://www.gnu.org/software/guile-ncurses/")
-    (synopsis
-     "GNU Guile-Ncurses, Scheme interface to the NCurses libraries")
+    (synopsis "Guile bindings to ncurses")
     (description
      "GNU Guile-Ncurses is a library for the Guile Scheme interpreter that
 provides functions for creating text user interfaces.  The text user interface
@@ -258,8 +257,7 @@ menu.")
      `(("ed" ,ed) ("which" ,which) ("guile" ,guile-1.8)
        ("patch/install" ,(search-patch "mcron-install.patch"))))
     (home-page "http://www.gnu.org/software/mcron/")
-    (synopsis
-     "GNU mcron, a flexible implementation of `cron' in Guile")
+    (synopsis "Run jobs at scheduled times")
     (description
      "The GNU package mcron (Mellor's cron) is a 100% compatible replacement
 for Vixie cron.  It is written in pure Guile, and allows configuration files
diff --git a/gnu/packages/help2man.scm b/gnu/packages/help2man.scm
index 0acd39a524..1dd0d71d91 100644
--- a/gnu/packages/help2man.scm
+++ b/gnu/packages/help2man.scm
@@ -45,7 +45,7 @@
        ;; ("gettext" ,gettext)
        ))
     (home-page "http://www.gnu.org/software/help2man/")
-    (synopsis "GNU help2man generates man pages from `--help' output")
+    (synopsis "Automatically generate man pages from program --help")
     (description
      "help2man produces simple manual pages from the ‘--help’ and
 ‘--version’ output of other commands.")
diff --git a/gnu/packages/idutils.scm b/gnu/packages/idutils.scm
index 775de18c5c..728bdeb51a 100644
--- a/gnu/packages/idutils.scm
+++ b/gnu/packages/idutils.scm
@@ -42,7 +42,7 @@
                ,(search-patch "diffutils-gets-undeclared.patch"))))
     (arguments `(#:patches (list (assoc-ref %build-inputs "patch/gets"))))
     (home-page "http://www.gnu.org/software/idutils/")
-    (synopsis "GNU Idutils, a text searching utility")
+    (synopsis "Identifier database utilities")
     (description
      "An \"ID database\" is a binary file containing a list of file
 names, a list of tokens, and a sparse matrix indicating which
diff --git a/gnu/packages/indent.scm b/gnu/packages/indent.scm
index c70a790e62..6789908a8d 100644
--- a/gnu/packages/indent.scm
+++ b/gnu/packages/indent.scm
@@ -34,7 +34,7 @@
             (sha256 (base32
                      "0f9655vqdvfwbxvs1gpa7py8k1z71aqh8hp73f65vazwbfz436wa"))))
    (build-system gnu-build-system)
-   (synopsis "GNU Indent, a program for code indentation and formatting")
+   (synopsis "Code reformatter")
    (description
     "GNU Indent can be used to make code easier to read. It can also convert
 from one style of writing C to another. Indent understands a substantial
diff --git a/gnu/packages/less.scm b/gnu/packages/less.scm
index 63a3d98a9b..ced14704ff 100644
--- a/gnu/packages/less.scm
+++ b/gnu/packages/less.scm
@@ -38,9 +38,7 @@
     (build-system gnu-build-system)
     (inputs `(("ncurses" ,ncurses)))
     (home-page "https://www.gnu.org/software/less/")
-    (synopsis
-     "GNU less is a program similar to more, but which allows backward
-movement in the file as well as forward movement")
+    (synopsis "Paginator for terminals")
     (description
      "GNU less is a program similar to more, but which allows backward
 movement in the file as well as forward movement. Also, less does not
@@ -48,4 +46,4 @@ have to read the entire input file before starting, so with large input
 files it starts up faster than text editors like vi. Less uses
 termcap (or terminfo on some systems), so it can run on a variety of
 terminals. There is even limited support for hardcopy terminals.")
-    (license gpl3+))) ; some files are under GPLv2+
\ No newline at end of file
+    (license gpl3+))) ; some files are under GPLv2+
diff --git a/gnu/packages/libidn.scm b/gnu/packages/libidn.scm
index b49a2018ca..dcb0872f30 100644
--- a/gnu/packages/libidn.scm
+++ b/gnu/packages/libidn.scm
@@ -35,7 +35,7 @@
                      "0g657kv60rh486m7bwyp5k24ljmym4wnb8nmk6d3i3qgr1qlqbqa"))))
    (build-system gnu-build-system)
 ;; FIXME: No Java and C# libraries are currently built.
-   (synopsis "GNU Libidn, a library to encode and decode internationalised domain names")
+   (synopsis "Internationalized string processing library")
    (description
     "GNU Libidn is a fully documented implementation of the Stringprep,
 Punycode and IDNA specifications. Libidn's purpose is to encode and decode
diff --git a/gnu/packages/libsigsegv.scm b/gnu/packages/libsigsegv.scm
index d73056892c..12cb4ba3b4 100644
--- a/gnu/packages/libsigsegv.scm
+++ b/gnu/packages/libsigsegv.scm
@@ -35,7 +35,7 @@
              (base32 "16hrs8k3nmc7a8jam5j1fpspd6sdpkamskvsdpcw6m29vnis8q44"))))
    (build-system gnu-build-system)
    (home-page "http://www.gnu.org/software/libsigsegv/")
-   (synopsis "GNU libsigsegv, a library to handle page faults in user mode")
+   (synopsis "Library for handling page faults")
    (description
 "GNU libsigsegv is a library for handling page faults in user mode. A page
 fault occurs when a program tries to access to a region of memory that is
diff --git a/gnu/packages/libunistring.scm b/gnu/packages/libunistring.scm
index 92241d891b..2dbfee70f1 100644
--- a/gnu/packages/libunistring.scm
+++ b/gnu/packages/libunistring.scm
@@ -36,7 +36,7 @@
               "18q620269xzpw39dwvr9zpilnl2dkw5z5kz3mxaadnpv4k3kw3b1"))))
    (propagated-inputs '())                  ; FIXME: add libiconv when !glibc
    (build-system gnu-build-system)
-   (synopsis "GNU Libunistring, a Unicode string library")
+   (synopsis "C library for manipulating Unicode strings")
    (description
     "This library provides functions for manipulating Unicode strings and for
 manipulating C strings according to the Unicode standard.
diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index b97315580b..ca4ca563a3 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -186,7 +186,7 @@
                   'install ,install-phase
                   (alist-delete 'configure %standard-phases)))
        #:tests? #f))
-    (synopsis "GNU Linux-Libre kernel")
+    (synopsis "100% free redistribution of a cleaned Linux kernel")
     (description "Linux-Libre operating system kernel.")
     (license gpl2)
     (home-page "http://www.gnu.org/software/linux-libre/"))))
diff --git a/gnu/packages/lsh.scm b/gnu/packages/lsh.scm
index 5b3e9a7e0b..c031b287a1 100644
--- a/gnu/packages/lsh.scm
+++ b/gnu/packages/lsh.scm
@@ -117,8 +117,7 @@
              (which "cat"))))
         %standard-phases)))
     (home-page "http://www.lysator.liu.se/~nisse/lsh/")
-    (synopsis
-     "GNU lsh, a GPL'd implementation of the SSH protocol")
+    (synopsis "GNU implementation of the Secure Shell (ssh) protocols")
     (description
      "lsh is a free implementation (in the GNU sense) of the ssh
 version 2 protocol, currently being standardised by the IETF
diff --git a/gnu/packages/m4.scm b/gnu/packages/m4.scm
index eb114c7514..0be1824382 100644
--- a/gnu/packages/m4.scm
+++ b/gnu/packages/m4.scm
@@ -61,7 +61,7 @@
              ("patch/readlink-EINVAL"
               ,(search-patch "m4-readlink-EINVAL.patch"))
              ("patch/gets" ,(search-patch "m4-gets-undeclared.patch"))))
-   (synopsis "GNU M4, a macro processor")
+   (synopsis "Macro processor")
    (description
     "GNU M4 is an implementation of the traditional Unix macro processor.  It
 is mostly SVR4 compatible although it has some extensions (for example,
diff --git a/gnu/packages/mailutils.scm b/gnu/packages/mailutils.scm
index d9f26323e8..15ca939e66 100644
--- a/gnu/packages/mailutils.scm
+++ b/gnu/packages/mailutils.scm
@@ -82,7 +82,7 @@
        ("patch/gets-undeclared"
         ,(search-patch "m4-gets-undeclared.patch"))))
     (home-page "http://www.gnu.org/software/mailutils/")
-    (synopsis "A rich and powerful protocol-independent mail framework")
+    (synopsis "Utilities and library for reading and serving mail")
     (description
      "GNU Mailutils is a rich and powerful protocol-independent mail
 framework.  It contains a series of useful mail libraries, clients, and
diff --git a/gnu/packages/multiprecision.scm b/gnu/packages/multiprecision.scm
index 7778552b40..a6130dccfa 100644
--- a/gnu/packages/multiprecision.scm
+++ b/gnu/packages/multiprecision.scm
@@ -46,7 +46,7 @@
                   ;; sub-architectures.
                   "--enable-fat"
                   "--enable-cxx")))
-   (synopsis "GMP, the GNU multiple precision arithmetic library")
+   (synopsis "Multiple-precision arithmetic library")
    (description
     "GMP is a free library for arbitrary precision arithmetic, operating on
 signed integers, rational numbers, and floating point numbers.  There is no
@@ -82,8 +82,7 @@ faster algorithms.")
                      "0ym1ylcq803n52qrggxqmkz66gbn8ncc3ybawal31v5y5p1srma9"))))
    (build-system gnu-build-system)
    (propagated-inputs `(("gmp" ,gmp)))            ; <mpfr.h> refers to <gmp.h>
-   (synopsis "GNU MPFR, a library for multiple-precision floating-point
-arithmetic")
+   (synopsis "C library for arbitrary precision floating-point arithmetic")
    (description
     "The GNU MPFR library is a C library for multiple-precision
 floating-point computations with correct rounding.  MPFR is based on the GMP
@@ -109,8 +108,7 @@ double-precision floating-point arithmetic (53-bit mantissa).")
    (build-system gnu-build-system)
    (propagated-inputs `(("gmp" ,gmp)              ; <mpc.h> refers to both
                         ("mpfr" ,mpfr)))
-   (synopsis "GNU MPC, a library for multiprecision complex arithmetic
-with exact rounding")
+   (synopsis "C library for arbitrary precision complex arithmetic")
    (description
     "GNU MPC is a C library for the arithmetic of complex numbers with
 arbitrarily high precision and correct rounding of the result. It extends
diff --git a/gnu/packages/nano.scm b/gnu/packages/nano.scm
index 09fbe7f168..00cdd6debb 100644
--- a/gnu/packages/nano.scm
+++ b/gnu/packages/nano.scm
@@ -42,11 +42,10 @@
      `(("gettext" ,guix:gettext)
        ("ncurses" ,ncurses)))
     (home-page "http://www.nano-editor.org/")
-    (synopsis
-     "A small, user-friendly console text editor")
+    (synopsis "A small, user-friendly console text editor")
     (description
      "GNU nano is designed to be a free replacement for the Pico text
 editor, part of the Pine email suite from The University of
 Washington. It aims to emulate Pico as closely as possible and perhaps
 include extra functionality.")
-    (license gpl3+))) ; some files are under GPLv2+
\ No newline at end of file
+    (license gpl3+))) ; some files are under GPLv2+
diff --git a/gnu/packages/ncurses.scm b/gnu/packages/ncurses.scm
index f790e6e38f..5199ec7c23 100644
--- a/gnu/packages/ncurses.scm
+++ b/gnu/packages/ncurses.scm
@@ -107,8 +107,7 @@
                     ,configure-phase
                     %standard-phases)))))
      (self-native-input? #t)
-     (synopsis
-      "GNU Ncurses, a free software emulation of curses in SVR4 and more")
+     (synopsis "Terminal emulation (termcap, terminfo) library")
      (description
       "The Ncurses (new curses) library is a free software emulation of curses
 in System V Release 4.0, and more.  It uses Terminfo format, supports pads
diff --git a/gnu/packages/nettle.scm b/gnu/packages/nettle.scm
index 6a0b6ef40a..3ea4eb79e1 100644
--- a/gnu/packages/nettle.scm
+++ b/gnu/packages/nettle.scm
@@ -39,7 +39,7 @@
     (inputs `(("m4" ,m4)))
     (propagated-inputs `(("gmp" ,gmp)))
     (home-page "http://www.lysator.liu.se/~nisse/nettle/")
-    (synopsis "GNU Nettle, a cryptographic library")
+    (synopsis "C library for low-level crytographic functionality")
     (description
      "Nettle is a cryptographic library that is designed to fit easily
 in more or less any context: In crypto toolkits for object-oriented
diff --git a/gnu/packages/oggvorbis.scm b/gnu/packages/oggvorbis.scm
index 636bf44106..888e5715f2 100644
--- a/gnu/packages/oggvorbis.scm
+++ b/gnu/packages/oggvorbis.scm
@@ -94,8 +94,7 @@ polyphonic) audio and music at fixed and variable bitrates from 16 to
     (build-system gnu-build-system)
     (inputs `(("libogg" ,libogg)))
     (home-page "https://gnu.org/software/speex")
-    (synopsis
-     "GNU Speex, a patent-free voice codec")
+    (synopsis "Library for patent-free audio compression format")
     (description
      "GNU Speex is a patent-free voice codec.  It is designed to
 compress voice at bitrates in the 2--45 kbps range.  Possible
diff --git a/gnu/packages/parted.scm b/gnu/packages/parted.scm
index b99c52e457..1f266c9035 100644
--- a/gnu/packages/parted.scm
+++ b/gnu/packages/parted.scm
@@ -58,8 +58,7 @@
        ("readline" ,readline)
        ("util-linux" ,util-linux)))
     (home-page "http://www.gnu.org/software/parted/")
-    (synopsis
-     "GNU Parted, a tool to manipulate partitions")
+    (synopsis "Disk partition editor")
     (description
      "GNU Parted is an industrial-strength package for creating, destroying,
 resizing, checking and copying partitions, and the file systems on them.  This
@@ -68,4 +67,4 @@ usage, copying data on hard disks and disk imaging.
 
 It contains a library, libparted, and a command-line frontend, parted, which
 also serves as a sample implementation and script backend.")
-    (license gpl3+)))
\ No newline at end of file
+    (license gpl3+)))
diff --git a/gnu/packages/pth.scm b/gnu/packages/pth.scm
index b0d5092cb0..c3f572574e 100644
--- a/gnu/packages/pth.scm
+++ b/gnu/packages/pth.scm
@@ -37,7 +37,7 @@
     (build-system gnu-build-system)
     (arguments '(#:parallel-build? #f))
     (home-page "http://www.gnu.org/software/pth")
-    (synopsis "The GNU Portable Threads library")
+    (synopsis "Portable thread library")
     (description
      "Pth is a very portable POSIX/ANSI-C based library for Unix
 platforms which provides non-preemptive priority-based scheduling for
diff --git a/gnu/packages/readline.scm b/gnu/packages/readline.scm
index e73b293ba3..8857666fcc 100644
--- a/gnu/packages/readline.scm
+++ b/gnu/packages/readline.scm
@@ -62,7 +62,7 @@
                              'install 'post-install
                              ,post-install-phase
                              %standard-phases)))
-      (synopsis "GNU Readline, a library for interactive line editing")
+      (synopsis "Edit command lines while typing, with history support")
       (description
        "The GNU Readline library provides a set of functions for use by
 applications that allow users to edit command lines as they are typed in.
diff --git a/gnu/packages/recutils.scm b/gnu/packages/recutils.scm
index fecb209deb..7b4828995e 100644
--- a/gnu/packages/recutils.scm
+++ b/gnu/packages/recutils.scm
@@ -46,8 +46,7 @@
              ("patch/gets"
               ,(search-patch "diffutils-gets-undeclared.patch"))))
    (arguments `(#:patches (list (assoc-ref %build-inputs "patch/gets"))))
-   (synopsis "GNU recutils, tools and libraries to access human-editable,
-text-based databases")
+   (synopsis "Manipulate plain text files as databases")
    (description
     "GNU recutils is a set of tools and libraries to access human-editable,
 text-based databases called recfiles.  The data is stored as a sequence of
diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index 4b42f8c53c..49b6df9b0d 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -102,7 +102,7 @@
               (base32
                "0pclakzwxbqgy6wqwvs6ml62wgby8ba8xzmwzdwhx1v8wv05yw1j"))))))))
     (home-page "http://www.gnu.org/software/mit-scheme/")
-    (synopsis "MIT/GNU Scheme, a native code Scheme compiler")
+    (synopsis "Scheme implementation with integrated editor and debugger")
     (description
      "MIT/GNU Scheme is an implementation of the Scheme programming
 language, providing an interpreter, compiler, source-code debugger,
diff --git a/gnu/packages/screen.scm b/gnu/packages/screen.scm
index ea1c21716a..5bace12070 100644
--- a/gnu/packages/screen.scm
+++ b/gnu/packages/screen.scm
@@ -40,7 +40,7 @@
      `(("ncurses", ncurses)
        ("perl" ,perl)))
     (home-page "http://www.gnu.org/software/screen/")
-    (synopsis "GNU Screen, a terminal multiplexer")
+    (synopsis "Full-screen window manager providing multiple terminals")
     (description
      "GNU screen is a full-screen window manager that multiplexes a physical
 terminal between several processes, typically interactive shells. Each virtual
diff --git a/gnu/packages/shishi.scm b/gnu/packages/shishi.scm
index 767037a580..0a49f47ded 100644
--- a/gnu/packages/shishi.scm
+++ b/gnu/packages/shishi.scm
@@ -46,8 +46,7 @@
        ("libgcrypt" ,libgcrypt)
        ("libtasn1" ,libtasn1)))
     (home-page "http://www.gnu.org/software/shishi/")
-    (synopsis
-     "GNU Shishi, an implementation of the Kerberos 5 network security system")
+    (synopsis "Implementation of the Kerberos 5 network security system")
     (description
      "Shishi contains a library ('libshishi') that can be used by application
 developers to add support for Kerberos 5.  Shishi contains a command line
diff --git a/gnu/packages/smalltalk.scm b/gnu/packages/smalltalk.scm
index 233068509d..1b4a3289ac 100644
--- a/gnu/packages/smalltalk.scm
+++ b/gnu/packages/smalltalk.scm
@@ -47,8 +47,7 @@
                        (("@LIBC_SO_DIR@")  (string-append libc "/lib")))))
                 %standard-phases)))
     (home-page "https://www.gnu.org/software/smalltalk/")
-    (synopsis
-     "GNU Smalltalk, a free implementation of the Smalltalk-80 language")
+    (synopsis "Smalltalk environment")
     (description
      "GNU Smalltalk is a free implementation of the Smalltalk-80 language.
 
diff --git a/gnu/packages/system.scm b/gnu/packages/system.scm
index 1eddd6de86..5bd8cbe881 100644
--- a/gnu/packages/system.scm
+++ b/gnu/packages/system.scm
@@ -38,8 +38,7 @@
         "18w0dbg77i56cx1bwa789w0qi3l4xkkbascxcv2b6gbm0zmjg1g6"))))
     (build-system gnu-build-system)
     (home-page "http://www.gnu.org/software/pies/")
-    (synopsis
-     "GNU Pies, a program invocation and execution supervisor")
+    (synopsis "Program invocation and execution supervisor")
     (description
      "The name Pies (pronounced \"p-yes\") stands for Program Invocation
 and Execution Supervisor.  This utility starts and controls execution of
@@ -81,8 +80,7 @@ it can replace the inetd utility!")
     (inputs `(("patch/gets" ,(search-patch "diffutils-gets-undeclared.patch"))
               ("ncurses" ,ncurses)))
     (home-page "http://www.gnu.org/software/inetutils/")
-    (synopsis
-     "GNU Inetutils, a collection of common network programs")
+    (synopsis "Basic networking utilities")
     (description
      "The GNU network utilities suite provides the following tools:
 ftp(d), hostname, ifconfig, inetd, logger, ping, rcp, rexec(d),
diff --git a/gnu/packages/texinfo.scm b/gnu/packages/texinfo.scm
index 4194f48ffe..b418acf35d 100644
--- a/gnu/packages/texinfo.scm
+++ b/gnu/packages/texinfo.scm
@@ -42,7 +42,7 @@
     ;; TODO: Remove Perl from here when 'patch-shebang' DTRT with /usr/bin/env.
     (propagated-inputs `(("perl" ,perl)))         ; yuck!
     (home-page "http://www.gnu.org/software/texinfo/")
-    (synopsis "GNU Texinfo, the GNU documentation system")
+    (synopsis "The GNU documentation format")
     (description
      "Texinfo is the official documentation format of the GNU project.
 It was invented by Richard Stallman and Bob Chassell many years
diff --git a/gnu/packages/time.scm b/gnu/packages/time.scm
index cfb3261f94..8d55905eec 100644
--- a/gnu/packages/time.scm
+++ b/gnu/packages/time.scm
@@ -49,9 +49,7 @@
                                     (string-append "--prefix=" out)))))
                       %standard-phases)))
     (home-page "http://www.gnu.org/software/time/")
-    (synopsis
-     "GNU Time, a tool that runs programs and summarizes the system
-resources they use")
+    (synopsis "Run a command, then display its resource usage")
     (description
      "The 'time' command runs another program, then displays information
 about the resources used by that program, collected by the system while
diff --git a/gnu/packages/wdiff.scm b/gnu/packages/wdiff.scm
index 02d536c7de..b9fccb97db 100644
--- a/gnu/packages/wdiff.scm
+++ b/gnu/packages/wdiff.scm
@@ -48,8 +48,7 @@
     (inputs `(("screen" ,screen)
               ("which" ,which)))
     (home-page "https://www.gnu.org/software/wdiff/")
-    (synopsis
-     "GNU Wdiff, a tool for comparing files on a word by word basis")
+    (synopsis "Word difference finder")
     (description
      "GNU Wdiff is a front end to 'diff' for comparing files on a word per
 word basis.  A word is anything between whitespace.  This is useful for
@@ -58,4 +57,4 @@ paragraphs have been refilled.  It works by creating two temporary files, one
 word per line, and then executes 'diff' on these files.  It collects the
 'diff' output and uses it to produce a nicer display of word differences
 between the original files.")
-    (license gpl3+)))
\ No newline at end of file
+    (license gpl3+)))
diff --git a/gnu/packages/wget.scm b/gnu/packages/wget.scm
index ea31a1e70d..0436c0d8c3 100644
--- a/gnu/packages/wget.scm
+++ b/gnu/packages/wget.scm
@@ -51,8 +51,7 @@
                                       '("doc/texi2pod.pl" "tests/run-px")))
                           %standard-phases)))
     (home-page "http://www.gnu.org/software/wget/")
-    (synopsis
-     "GNU Wget, a tool for retrieving files using HTTP, HTTPS, and FTP")
+    (synopsis "Non-interactive command-line utility for downloading files")
     (description
      "GNU Wget is a free software package for retrieving files using HTTP,
 HTTPS and FTP, the most widely-used Internet protocols.  It is a
diff --git a/gnu/packages/which.scm b/gnu/packages/which.scm
index aa5330cad7..27d8094b00 100644
--- a/gnu/packages/which.scm
+++ b/gnu/packages/which.scm
@@ -36,8 +36,7 @@
         "1y2p50zadb36izzh2zw4dm5hvdiydqf3qa88l8kav20dcmfbc5yl"))))
     (build-system gnu-build-system)
     (home-page "https://gnu.org/software/which/")
-    (synopsis
-     "GNU Which shows the full path of (shell) commands")
+    (synopsis "Find full path of shell commands")
     (description
      "GNU Which takes one or more arguments. For each of its arguments
 it prints to stdout the full path of the executables that would have
diff --git a/gnu/packages/zile.scm b/gnu/packages/zile.scm
index b5366c046f..6e540ccfab 100644
--- a/gnu/packages/zile.scm
+++ b/gnu/packages/zile.scm
@@ -45,7 +45,7 @@
        ("perl" ,perl)
        ("help2man" ,help2man)))
     (home-page "http://www.gnu.org/software/zile/")
-    (synopsis "GNU Zile, a lightweight Emacs clone")
+    (synopsis "Zile is lossy Emacs, a lightweight Emacs clone")
     (description
      "GNU Zile, which is a lightweight Emacs clone.  Zile is short
 for Zile Is Lossy Emacs.  Zile has been written to be as

From 0e993428ce5ebd34d3bd9cb200140ffb2a5ef232 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 17 Apr 2013 18:09:43 +0200
Subject: [PATCH 33/74] build: Add `sync-synopses.scm'.

* build-aux/sync-synopses.scm: New file.
* Makefile.am (EXTRA_DIST): Add it.
  (dist-hook): New target.
---
 Makefile.am                 |  5 +++
 build-aux/sync-synopses.scm | 61 +++++++++++++++++++++++++++++++++++++
 2 files changed, 66 insertions(+)
 create mode 100644 build-aux/sync-synopses.scm

diff --git a/Makefile.am b/Makefile.am
index df0a5138dc..3e697a258a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -319,6 +319,7 @@ EXTRA_DIST =					\
   .dir-locals.el				\
   hydra.scm					\
   build-aux/download.scm			\
+  build-aux/sync-synopses.scm			\
   srfi/srfi-64.scm				\
   srfi/srfi-64.upstream.scm			\
   tests/test.drv				\
@@ -366,3 +367,7 @@ AM_DISTCHECK_CONFIGURE_FLAGS =			\
   --with-libgcrypt-prefix="$(LIBGCRYPT_PREFIX)"	\
   --with-nix-prefix="$(NIX_PREFIX)"		\
   --enable-daemon
+
+dist-hook:
+	-$(top_builddir)/pre-inst-env $(GUILE)		\
+	   $(top_srcdir)/build-aux/sync-synopses.scm
diff --git a/build-aux/sync-synopses.scm b/build-aux/sync-synopses.scm
new file mode 100644
index 0000000000..9aaff11ce0
--- /dev/null
+++ b/build-aux/sync-synopses.scm
@@ -0,0 +1,61 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+;;;
+;;; Report synopses that defer from those found in the GNU Womb.
+;;;
+
+(use-modules (guix gnu-maintenance)
+             (guix packages)
+             (guix utils)
+             (guix ui)
+             (gnu packages)
+             (srfi srfi-1)
+             (srfi srfi-26)
+             (ice-9 match))
+
+(define official
+  ;; GNU package descriptors from the Womb.
+  (official-gnu-packages))
+
+(define gnus
+  ;; GNU packages available in the distro.
+  (let ((lookup (lambda (p)
+                  (find (lambda (descriptor)
+                          (equal? (gnu-package-name descriptor)
+                                  (package-name p)))
+                        official))))
+    (fold-packages (lambda (package result)
+                     (or (and=> (lookup package)
+                                (cut alist-cons package <> result))
+                         result))
+                   '())))
+
+;; Iterate over GNU packages.  Report those whose synopsis defers from that
+;; found upstream.
+(for-each (match-lambda
+           ((package . descriptor)
+            (let ((upstream   (gnu-package-doc-summary descriptor))
+                  (downstream (package-synopsis package))
+                  (loc        (package-location package)))
+              (unless (and upstream (string=? upstream downstream))
+                (format (guix-warning-port)
+                        "~a: ~a: proposed synopsis: ~s~%"
+                        (location->string loc) (package-name package)
+                        upstream)))))
+          gnus)

From b52cb20d434d36ede63e6b20599c5d50a664e79c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 17 Apr 2013 22:43:14 +0200
Subject: [PATCH 34/74] guix package: Allow the search of the latest release to
 be interrupted.

* guix/scripts/package.scm (%sigint-prompt): New variable.
  (call-with-sigint-handler): New procedure.
  (waiting): Use it.
---
 guix/scripts/package.scm | 37 ++++++++++++++++++++++++++++++-------
 1 file changed, 30 insertions(+), 7 deletions(-)

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index f83c0573e7..4295abaf57 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -266,19 +266,42 @@ matching packages."
                        (assoc-ref (derivation-outputs drv) sub-drv))))
          `(,name ,out))))))
 
+(define %sigint-prompt
+  ;; The prompt to jump to upon SIGINT.
+  (make-prompt-tag "interruptible"))
+
+(define (call-with-sigint-handler thunk handler)
+  "Call THUNK and return its value.  Upon SIGINT, call HANDLER with the signal
+number in the context of the continuation of the call to this function, and
+return its return value."
+  (call-with-prompt %sigint-prompt
+                    (lambda ()
+                      (sigaction SIGINT
+                        (lambda (signum)
+                          (sigaction SIGINT SIG_DFL)
+                          (abort-to-prompt %sigint-prompt signum)))
+                      (thunk))
+                    (lambda (k signum)
+                      (handler signum))))
+
 (define-syntax-rule (waiting exp fmt rest ...)
   "Display the given message while EXP is being evaluated."
   (let* ((message (format #f fmt rest ...))
          (blank   (make-string (string-length message) #\space)))
     (display message (current-error-port))
     (force-output (current-error-port))
-    (let ((result exp))
-      ;; Clear the line.
-      (display #\cr (current-error-port))
-      (display blank (current-error-port))
-      (display #\cr (current-error-port))
-      (force-output (current-error-port))
-      exp)))
+    (call-with-sigint-handler
+     (lambda ()
+       (let ((result exp))
+         ;; Clear the line.
+         (display #\cr (current-error-port))
+         (display blank (current-error-port))
+         (display #\cr (current-error-port))
+         (force-output (current-error-port))
+         exp))
+     (lambda (signum)
+       (format (current-error-port) "  interrupted by signal ~a~%" SIGINT)
+       #f))))
 
 (define (check-package-freshness package)
   "Check whether PACKAGE has a newer version available upstream, and report

From 3b78d1eab826f2e79364ef38cfdc0d4bc0a5f414 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 17 Apr 2013 22:44:19 +0200
Subject: [PATCH 35/74] doc: Transparent binary deployment is implemented.

* doc/guix.texi (Features): Remove footnote saying that transparent
  binary deployment is not implemented.
---
 doc/guix.texi | 5 +----
 1 file changed, 1 insertion(+), 4 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index b77335d2c2..188ab1ae73 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -447,11 +447,8 @@ scripts, etc.  This direct correspondence allows users to make sure a
 given package installation matches the current state of their
 distribution, and helps maximize @dfn{reproducibility}.
 
-@c FIXME: Remove footnote when it's implemented.
 This foundation allows Guix to support @dfn{transparent binary/source
-deployment}@footnote{This feature is not implemented as of version
-@value{VERSION}.  Please contact @email{bug-guix@@gnu.org} for more
-details.}.  When a pre-built binary for a @file{/nix/store} path is
+deployment}.  When a pre-built binary for a @file{/nix/store} path is
 available from an external source, Guix just downloads it; otherwise, it
 builds the package from source, locally.
 

From 6c1cd80d8fcba1c5cfbd872e714c0e5603c1a3e4 Mon Sep 17 00:00:00 2001
From: Nikita Karetnikov <nikita@karetnikov.org>
Date: Thu, 18 Apr 2013 15:22:40 +0000
Subject: [PATCH 36/74] tests: Use a new synopsis of GNU Hello.

* tests/guix-package.sh: Use a new synopsis of GNU Hello, which was
  added in f50d2669e3e624365221cc81918ba55fdce94107.
---
 tests/guix-package.sh | 21 +++++++++++----------
 1 file changed, 11 insertions(+), 10 deletions(-)

diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index f84893ba0b..7b101aa501 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -62,18 +62,19 @@ then
     # name and version string.
     installed="`guix package -p "$profile" --list-installed | cut -f1 | xargs echo | sort`"
     case "x$installed" in
-	"guile-bootstrap make-boot0")
-	    true;;
-	"make-boot0 guile-bootstrap")
-	    true;;
-	"*")
+        "guile-bootstrap make-boot0")
+            true;;
+        "make-boot0 guile-bootstrap")
+            true;;
+        "*")
             false;;
     esac
 
     test "`guix package -p "$profile" -I 'g.*e' | cut -f1`" = "guile-bootstrap"
 
     # Search.
-    test "`guix package -s "GNU Hello" | grep ^name:`" = "name: hello"
+    test "`guix package -s "An example GNU package" | grep ^name:`" = \
+        "name: hello"
     test "`guix package -s "n0t4r341p4ck4g3"`" = ""
 
     # Remove a package.
@@ -92,10 +93,10 @@ then
     # Move to the empty profile.
     for i in `seq 1 3`
     do
-	guix package --bootstrap --roll-back -p "$profile"
-	! test -f "$profile/bin"
-	! test -f "$profile/lib"
-	test "`readlink_base "$profile"`" = "$profile-0-link"
+        guix package --bootstrap --roll-back -p "$profile"
+        ! test -f "$profile/bin"
+        ! test -f "$profile/lib"
+        test "`readlink_base "$profile"`" = "$profile-0-link"
     done
 
     # Reinstall after roll-back to the empty profile.

From 48febeb81a06f95f2af98e153868e6d29a4ba353 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 18 Apr 2013 22:03:04 +0200
Subject: [PATCH 37/74] doc: Mention the home page.

* doc/guix.texi (Installation): Add a sentence pointing to the home
  page.  Suggested by Arne Babenhauserheide.
---
 doc/guix.texi | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 188ab1ae73..96ffd51730 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -141,8 +141,10 @@ Distribution}.
 @node Installation
 @chapter Installation
 
-This section describes the software requirements of Guix, as well as how
-to install it and get ready to use it.
+GNU Guix is available for download from its website at
+@url{http://www.gnu.org/software/guix/}.  This section describes the
+software requirements of Guix, as well as how to install it and get
+ready to use it.
 
 The build procedure for Guix is the same as for other GNU software, and
 is not covered here.  Please see the files @file{README} and

From ea0ee755bd54db2c3766714946c24df4e9b94fc0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 18 Apr 2013 22:22:30 +0200
Subject: [PATCH 38/74] daemon: Really enable the substituter by default.

* nix/nix-daemon/guix-daemon.cc (main): Really enable the substituter by
  default.  Reported by Mark H. Weaver.
---
 nix/nix-daemon/guix-daemon.cc | 6 ++----
 1 file changed, 2 insertions(+), 4 deletions(-)

diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc
index 0e2f36150b..0f21e4f99e 100644
--- a/nix/nix-daemon/guix-daemon.cc
+++ b/nix/nix-daemon/guix-daemon.cc
@@ -204,10 +204,8 @@ main (int argc, char *argv[])
       settings.substituters.clear ();
       string subs = getEnv ("NIX_SUBSTITUTERS", "default");
       if (subs == "default")
-	/* XXX: No substituters until we have something that works.  */
-	settings.substituters.clear ();
-	// settings.substituters.push_back (settings.nixLibexecDir
-	// 				 + "/guix/substitute-binary");
+	settings.substituters.push_back (settings.nixLibexecDir
+					 + "/guix/substitute-binary");
       else
 	settings.substituters = tokenizeString<Strings> (subs, ":");
 

From 6858f9d13217b14eeeacede9c42a279468242891 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 18 Apr 2013 22:46:34 +0200
Subject: [PATCH 39/74] daemon: Add `--no-substitutes'.

Suggested by Mark H. Weaver.

* nix/nix-daemon/guix-daemon.cc (GUIX_OPT_NO_SUBSTITUTES): New macro.
  (options): Add `--no-substitutes'.
  (parse_opt): Add `GUIX_OPT_NO_SUBSTITUTES' case.
  (main): Leave `settings.substituters' empty when
  `settings.useSubstitutes' is false.
---
 doc/guix.texi                 |  4 ++++
 nix/nix-daemon/guix-daemon.cc | 25 ++++++++++++++++++-------
 2 files changed, 22 insertions(+), 7 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 96ffd51730..f149eee6dd 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -295,6 +295,10 @@ The following command-line options are supported:
 Take users from @var{group} to run build processes (@pxref{Setting Up
 the Daemon, build users}).
 
+@item --no-substitutes
+Do not use substitutes for build products.  That is, always build things
+locally instead of allowing downloads of pre-built binaries.
+
 @item --cache-failures
 Cache build failures.  By default, only successful builds are cached.
 
diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc
index 0f21e4f99e..5f0710c256 100644
--- a/nix/nix-daemon/guix-daemon.cc
+++ b/nix/nix-daemon/guix-daemon.cc
@@ -65,6 +65,7 @@ builds derivations on behalf of its clients.";
 #define GUIX_OPT_DEBUG 9
 #define GUIX_OPT_CHROOT_DIR 10
 #define GUIX_OPT_LISTEN 11
+#define GUIX_OPT_NO_SUBSTITUTES 12
 
 static const struct argp_option options[] =
   {
@@ -90,6 +91,8 @@ static const struct argp_option options[] =
     },
     { "build-users-group", GUIX_OPT_BUILD_USERS_GROUP, "GROUP", 0,
       "Perform builds as a user of GROUP" },
+    { "no-substitutes", GUIX_OPT_NO_SUBSTITUTES, 0, 0,
+      "Do not use substitutes" },
     { "cache-failures", GUIX_OPT_CACHE_FAILURES, 0, 0,
       "Cache build failures" },
     { "lose-logs", GUIX_OPT_LOSE_LOGS, 0, 0,
@@ -152,6 +155,9 @@ parse_opt (int key, char *arg, struct argp_state *state)
 	  exit (EXIT_FAILURE);
 	}
       break;
+    case GUIX_OPT_NO_SUBSTITUTES:
+      settings.useSubstitutes = false;
+      break;
     case GUIX_OPT_DEBUG:
       verbosity = lvlDebug;
       break;
@@ -202,16 +208,21 @@ main (int argc, char *argv[])
 
       /* Use our substituter by default.  */
       settings.substituters.clear ();
-      string subs = getEnv ("NIX_SUBSTITUTERS", "default");
-      if (subs == "default")
-	settings.substituters.push_back (settings.nixLibexecDir
-					 + "/guix/substitute-binary");
-      else
-	settings.substituters = tokenizeString<Strings> (subs, ":");
-
+      settings.useSubstitutes = true;
 
       argp_parse (&argp, argc, argv, 0, 0, 0);
 
+      if (settings.useSubstitutes)
+	{
+	  string subs = getEnv ("NIX_SUBSTITUTERS", "default");
+
+	  if (subs == "default")
+	    settings.substituters.push_back (settings.nixLibexecDir
+					     + "/guix/substitute-binary");
+	  else
+	    settings.substituters = tokenizeString<Strings> (subs, ":");
+	}
+
       if (geteuid () == 0 && settings.buildUsersGroup.empty ())
 	fprintf (stderr, "warning: daemon is running as root, so "
 		 "using `--build-users-group' is highly recommended\n");

From 0ff3e3aa9bea8c82c921db88fc03cb7361b886f7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 20 Apr 2013 10:53:31 +0200
Subject: [PATCH 40/74] daemon: Gracefully handle cases where the daemon does
 not return a status code.

* guix/store.scm (process-stderr): Check for EOF before doing (read-int p).
---
 guix/store.scm | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/guix/store.scm b/guix/store.scm
index b1b60babf0..b82588b2a0 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -336,7 +336,10 @@ encoding conversion errors."
              #f))
           ((= k %stderr-error)
            (let ((error  (read-latin1-string p))
-                 (status (if (>= (nix-server-minor-version server) 8)
+                 ;; Currently the daemon fails to send a status code for early
+                 ;; errors like DB schema version mismatches, so check for EOF.
+                 (status (if (and (>= (nix-server-minor-version server) 8)
+                                  (not (eof-object? (lookahead-u8 p))))
                              (read-int p)
                              1)))
              (raise (condition (&nix-protocol-error

From f7758740eda6b866233333a766e29183d16fe154 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 20 Apr 2013 11:44:42 +0200
Subject: [PATCH 41/74] gnu: gdbm, nano: Synchronize synopses.

* gnu/packages/gdbm.scm, gnu/packages/nano.scm: Synchronize synopses
  with the Womb.
---
 gnu/packages/gdbm.scm | 3 ++-
 gnu/packages/nano.scm | 2 +-
 2 files changed, 3 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/gdbm.scm b/gnu/packages/gdbm.scm
index 76733dba65..6159cc25da 100644
--- a/gnu/packages/gdbm.scm
+++ b/gnu/packages/gdbm.scm
@@ -37,7 +37,8 @@
     (arguments `(#:configure-flags '("--enable-libgdbm-compat")))
     (build-system gnu-build-system)
     (home-page "http://www.gnu.org/software/gdbm/")
-    (synopsis "GNU dbm key/value database library")
+    (synopsis
+     "Hash library of database functions compatible with traditional dbm")
     (description
      "GNU dbm (or GDBM, for short) is a library of database functions
 that use extensible hashing and work similar to the standard UNIX dbm.
diff --git a/gnu/packages/nano.scm b/gnu/packages/nano.scm
index 00cdd6debb..f80400d88b 100644
--- a/gnu/packages/nano.scm
+++ b/gnu/packages/nano.scm
@@ -42,7 +42,7 @@
      `(("gettext" ,guix:gettext)
        ("ncurses" ,ncurses)))
     (home-page "http://www.nano-editor.org/")
-    (synopsis "A small, user-friendly console text editor")
+    (synopsis "Small, user-friendly console text editor")
     (description
      "GNU nano is designed to be a free replacement for the Pico text
 editor, part of the Pine email suite from The University of

From f286f716344df693c392f6bdd902db07a9d91841 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 20 Apr 2013 11:52:50 +0200
Subject: [PATCH 42/74] snix: Prefer synopses from the Womb rather than from
 Nixpkgs.

* guix/snix.scm (snix-derivation->guix-package): When NAME is
  in (official-gnu-packages), use this synopsis instead of the one from
  Nixpkgs.
---
 guix/snix.scm | 13 +++++++++++--
 1 file changed, 11 insertions(+), 2 deletions(-)

diff --git a/guix/snix.scm b/guix/snix.scm
index 0c19fecb28..04b5e7db2a 100644
--- a/guix/snix.scm
+++ b/guix/snix.scm
@@ -34,6 +34,7 @@
   #:use-module (guix utils)
   #:use-module (guix base32)
   #:use-module (guix config)
+  #:use-module (guix gnu-maintenance)
   #:export (open-nixpkgs
             xml->snix
             nixpkgs->guix-package))
@@ -435,8 +436,16 @@ location of DERIVATION."
 
              (home-page ,(and=> (find-attribute-by-name "homepage" meta)
                                 attribute-value))
-             (synopsis ,(and=> (find-attribute-by-name "description" meta)
-                               attribute-value))
+             (synopsis
+              ;; For GNU packages, prefer the official synopsis.
+              ,(or (false-if-exception
+                    (and=> (find (lambda (gnu-package)
+                                   (equal? (gnu-package-name gnu-package)
+                                           name))
+                                 (official-gnu-packages))
+                           gnu-package-doc-summary))
+                   (and=> (find-attribute-by-name "description" meta)
+                          attribute-value)))
              (description
               ,(and=> (find-attribute-by-name "longDescription" meta)
                       attribute-value))

From 4c7cacf117e226b0bc3c99625c911b074e9d8ce8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 20 Apr 2013 15:12:24 +0200
Subject: [PATCH 43/74] substitute-binary: Remove expired cache entries once in
 a while.

* guix/scripts/substitute-binary.scm (%narinfo-expired-cache-entry-removal-delay):
  New variable.
  (obsolete?): New procedure, formerly in `lookup-narinfo'.
  (lookup-narinfo): Adjust accordingly.
  (remove-expired-cached-narinfos, maybe-remove-expired-cached-narinfo):
  New procedures.
  (guix-substitute-binary): Call `maybe-remove-expired-cached-narinfo'.
---
 guix/scripts/substitute-binary.scm | 75 ++++++++++++++++++++++++++----
 1 file changed, 66 insertions(+), 9 deletions(-)

diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 804121b6c8..7e059be596 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -28,6 +28,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 threads)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
@@ -64,6 +65,10 @@
   ;; Likewise, but for negative lookups---i.e., cached lookup failures.
   (* 3 3600))
 
+(define %narinfo-expired-cache-entry-removal-delay
+  ;; How often we want to remove files corresponding to expired cache entries.
+  (* 7 24 3600))
+
 (define (with-atomic-file-output file proc)
   "Call PROC with an output port for the file that is going to replace FILE.
 Upon success, FILE is atomically replaced by what has been written to the
@@ -263,19 +268,17 @@ reading PORT."
                                        ".narinfo"))
               (cute read-narinfo <> (cache-url cache)))))
 
+(define (obsolete? date now ttl)
+  "Return #t if DATE is obsolete compared to NOW + TTL seconds."
+  (time>? (subtract-duration now (make-time time-duration 0 ttl))
+          (make-time time-monotonic 0 date)))
+
 (define (lookup-narinfo cache path)
   "Check locally if we have valid info about PATH, otherwise go to CACHE and
 check what it has."
   (define now
     (current-time time-monotonic))
 
-  (define (->time seconds)
-    (make-time time-monotonic 0 seconds))
-
-  (define (obsolete? date ttl)
-    (time>? (subtract-duration now (make-time time-duration 0 ttl))
-            (->time date)))
-
   (define cache-file
     (string-append %narinfo-cache-directory "/"
                    (store-path-hash-part path)))
@@ -294,13 +297,13 @@ check what it has."
                            (('narinfo ('version 0) ('date date)
                                       ('value #f))
                             ;; A cached negative lookup.
-                            (if (obsolete? date %narinfo-negative-ttl)
+                            (if (obsolete? date now %narinfo-negative-ttl)
                                 (values #f #f)
                                 (values #t #f)))
                            (('narinfo ('version 0) ('date date)
                                       ('value value))
                             ;; A cached positive lookup
-                            (if (obsolete? date %narinfo-ttl)
+                            (if (obsolete? date now %narinfo-ttl)
                                 (values #f #f)
                                 (values #t (string->narinfo value))))))))
                    (lambda _
@@ -314,6 +317,59 @@ check what it has."
               (write (cache-entry narinfo) out)))
           narinfo))))
 
+(define (remove-expired-cached-narinfos)
+  "Remove expired narinfo entries from the cache.  The sole purpose of this
+function is to make sure `%narinfo-cache-directory' doesn't grow
+indefinitely."
+  (define now
+    (current-time time-monotonic))
+
+  (define (expired? file)
+    (catch 'system-error
+      (lambda ()
+        (call-with-input-file file
+          (lambda (port)
+            (match (read port)
+              (('narinfo ('version 0) ('date date)
+                         ('value #f))
+               (obsolete? date now %narinfo-negative-ttl))
+              (('narinfo ('version 0) ('date date)
+                         ('value _))
+               (obsolete? date now %narinfo-ttl))
+              (_ #t)))))
+      (lambda args
+        ;; FILE may have been deleted.
+        #t)))
+
+  (for-each (lambda (file)
+              (let ((file (string-append %narinfo-cache-directory
+                                         "/" file)))
+                (when (expired? file)
+                  ;; Wrap in `false-if-exception' because FILE might have been
+                  ;; deleted in the meantime (TOCTTOU).
+                  (false-if-exception (delete-file file)))))
+            (scandir %narinfo-cache-directory
+                     (lambda (file)
+                       (= (string-length file) 32)))))
+
+(define (maybe-remove-expired-cached-narinfo)
+  "Remove expired narinfo entries from the cache if deemed necessary."
+  (define now
+    (current-time time-monotonic))
+
+  (define expiry-file
+    (string-append %narinfo-cache-directory "/last-expiry-cleanup"))
+
+  (define last-expiry-date
+    (or (false-if-exception
+         (call-with-input-file expiry-file read))
+        0))
+
+  (when (obsolete? last-expiry-date now %narinfo-expired-cache-entry-removal-delay)
+    (remove-expired-cached-narinfos)
+    (call-with-output-file expiry-file
+      (cute write (time-second now) <>))))
+
 (define (filtered-port command input)
   "Return an input port (and PID) where data drained from INPUT is filtered
 through COMMAND.  INPUT must be a file input port."
@@ -351,6 +407,7 @@ through COMMAND.  INPUT must be a file input port."
 (define (guix-substitute-binary . args)
   "Implement the build daemon's substituter protocol."
   (mkdir-p %narinfo-cache-directory)
+  (maybe-remove-expired-cached-narinfo)
   (match args
     (("--query")
      (let ((cache (delay (open-cache %cache-url))))

From c6d7e299ae0acb14c76465c7036fdbddf2ef495e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 20 Apr 2013 17:47:59 +0200
Subject: [PATCH 44/74] gnu: Add GCC 4.8.0 and Binutils 2.23.2.

* gnu/packages/base.scm (binutils-2.23, ld-wrapper-2.23, gcc-4.8): New
  variables.
---
 gnu/packages/base.scm | 43 ++++++++++++++++++++++++++++++++++++++++++-
 gnu/packages/gcc.scm  |  3 ++-
 2 files changed, 44 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/base.scm b/gnu/packages/base.scm
index 1eaa4fb860..3597e6fad1 100644
--- a/gnu/packages/base.scm
+++ b/gnu/packages/base.scm
@@ -18,7 +18,8 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu packages base)
-  #:use-module (guix licenses)
+  #:use-module ((guix licenses)
+                #:select (gpl3+ lgpl2.0+))
   #:use-module (gnu packages)
   #:use-module (gnu packages acl)
   #:use-module (gnu packages bash)
@@ -374,6 +375,17 @@ BFD (Binary File Descriptor) library, `gprof', `nm', `strip', etc.")
    (license gpl3+)
    (home-page "http://www.gnu.org/software/binutils/")))
 
+(define-public binutils-2.23
+  (package (inherit binutils)
+    (version "2.23.2")
+    (source (origin
+             (method url-fetch)
+             (uri (string-append "mirror://gnu/binutils/binutils-"
+                                 version ".tar.bz2"))
+             (sha256
+              (base32
+               "15qhbkz3r266xaa52slh857qn3abw7rb2x2jnhpfrafpzrb4x4gy"))))))
+
 (define-public glibc
   (package
    (name "glibc")
@@ -928,6 +940,35 @@ store.")
               ,@(fold alist-delete (package-inputs ld-wrapper-boot3)
                       '("guile" "bash"))))))
 
+(define-public ld-wrapper-2.23         ; TODO: remove when Binutils is updated
+  (package (inherit ld-wrapper)
+    (inputs `(("binutils" ,binutils-2.23)
+              ,@(alist-delete "binutils" (package-inputs ld-wrapper))))))
+
+(define-public gcc-4.8
+  ;; FIXME: Move to gcc.scm when Binutils is updated.
+  (package (inherit gcc-4.7)
+    (version "4.8.0")
+    (source (origin
+             (method url-fetch)
+             (uri (string-append "mirror://gnu/gcc/gcc-"
+                                 version "/gcc-" version ".tar.bz2"))
+             (sha256
+              (base32
+               "0b6cp9d1sas3vq6dj3zrgd134p9b569fqhbixb9cl7mp698zwdxh"))))
+    (inputs `(("gmp" ,gmp)
+              ("mpfr" ,mpfr)
+              ("mpc" ,mpc)
+              ("isl" ,isl)
+              ("cloog" ,cloog)
+              ("zlib" ,(@ (gnu packages compression) zlib))
+
+              ;; With ld from Binutils 2.22, we get the following error while
+              ;; linking gcov:
+              ;; ld: gcov: hidden symbol `__deregister_frame_info' in /nix/store/47myfniw4x7kfc601d7q1yvz5mixlr00-gcc-4.7.2/lib/gcc/x86_64-unknown-linux-gnu/4.7.2/libgcc_eh.a(unwind-dw2-fde-dip.o) is referenced by DSO
+              ;; See <http://gcc.gnu.org/bugzilla/show_bug.cgi?id=57015>.
+              ("ld-wrapper" ,ld-wrapper-2.23)))))
+
 (define-public %final-inputs
   ;; Final derivations used as implicit inputs by `gnu-build-system'.
   (let ((finalize (cut package-with-explicit-inputs <> %boot4-inputs
diff --git a/gnu/packages/gcc.scm b/gnu/packages/gcc.scm
index 164b982ab1..a784118dd6 100644
--- a/gnu/packages/gcc.scm
+++ b/gnu/packages/gcc.scm
@@ -17,7 +17,8 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu packages gcc)
-  #:use-module (guix licenses)
+  #:use-module ((guix licenses)
+                #:select (gpl3+ gpl2+ lgpl2.1+ lgpl2.0+))
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
   #:use-module (gnu packages compression)

From 98eb8cbe8d0bdebde0e151bfb309aa27abaef4d7 Mon Sep 17 00:00:00 2001
From: Nikita Karetnikov <nikita@karetnikov.org>
Date: Sun, 21 Apr 2013 08:08:40 +0000
Subject: [PATCH 45/74] ui: Add a 'define-diagnostic' macro.

* guix/ui.scm (define-diagnostic): New macro, which is based on the
  previous version of 'warning'.
  (warning, leave): Redefine using 'define-diagnostic'.
  (report-error): New macro.
  (install-locale): Use 'warning' instead of 'format'.
  (call-with-error-handling): Adjust 'leave'.
* gnu/packages.scm (package-files): Use 'warning' instead of 'format'.
* guix/gnu-maintenance.scm (http-fetch): Use 'warning' and 'leave'.
* guix/scripts/build.scm (derivations-from-package-expressions, guix-build):
  Adjust 'leave'.
* guix/scripts/download.scm (guix-download): Adjust 'leave'.
* guix/scripts/gc.scm (size->number, %options): Adjust 'leave'.
* guix/scripts/package.scm (roll-back, guix-package): Adjust 'leave'.
* po/POTFILES.in: Add 'guix/gnu-maintenance.scm'.
---
 gnu/packages.scm          |  6 ++--
 guix/gnu-maintenance.scm  | 12 +++----
 guix/scripts/build.scm    | 14 ++++----
 guix/scripts/download.scm |  4 +--
 guix/scripts/gc.scm       |  7 ++--
 guix/scripts/package.scm  |  5 ++-
 guix/ui.scm               | 76 +++++++++++++++++++--------------------
 po/POTFILES.in            |  1 +
 8 files changed, 62 insertions(+), 63 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index f4d93a789d..e9f2540b91 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -19,6 +19,7 @@
 
 (define-module (gnu packages)
   #:use-module (guix packages)
+  #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 vlist)
@@ -90,9 +91,8 @@
                       result)
                     (const #f)                    ; skip
                     (lambda (path stat errno result)
-                      (format (current-error-port)
-                              (_ "warning: cannot access `~a': ~a~%")
-                              path (strerror errno))
+                      (warning (_ "cannot access `~a': ~a~%")
+                               path (strerror errno))
                       result)
                     '()
                     %distro-module-directory
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 89e7f25589..0dc2fab092 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -29,6 +29,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (system foreign)
   #:use-module (guix ftp-client)
+  #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix packages)
   #:export (gnu-package-name
@@ -84,12 +85,11 @@
                 ;; (see <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
                 ;; Since users may still be using these versions, warn them and
                 ;; bail out.
-                (format (current-error-port)
-                        "warning: using Guile ~a, ~a ~s encoding~%"
-                        (version)
-                        "which does not support HTTP"
-                        (response-transfer-encoding resp))
-                (error "download failed; use a newer Guile"
+                (warning (_ "using Guile ~a, ~a ~s encoding~%")
+                         (version)
+                         "which does not support HTTP"
+                         (response-transfer-encoding resp))
+                (leave (_ "download failed; use a newer Guile~%")
                        uri resp)))
              ((string? data)                 ; old `http-get' returns a string
               (open-input-string data))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index f296f3031f..0bf154dd41 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -43,12 +43,11 @@
 When SOURCE? is true, return the derivations of the package sources."
   (let ((p (read/eval-package-expression str)))
     (if source?
-        (let ((source (package-source p))
-              (loc    (package-location p)))
+        (let ((source (package-source p)))
           (if source
               (package-source-derivation (%store) source)
-              (leave (_ "~a: error: package `~a' has no source~%")
-                     (location->string loc) (package-name p))))
+              (leave (_ "package `~a' has no source~%")
+                     (package-name p))))
         (package-derivation (%store) p system))))
 
 
@@ -169,7 +168,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
             (add-indirect-root (%store) root))
            ((paths ...)
             (fold (lambda (path count)
-                    (let ((root (string-append root "-" (number->string count))))
+                    (let ((root (string-append root
+                                               "-"
+                                               (number->string count))))
                       (symlink path root)
                       (add-indirect-root (%store) root))
                     (+ 1 count))
@@ -177,8 +178,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
                   paths))))
        (lambda args
          (leave (_ "failed to create GC root `~a': ~a~%")
-                root (strerror (system-error-errno args)))
-         (exit 1)))))
+                root (strerror (system-error-errno args)))))))
 
   (define newest-available-packages
     (memoize find-newest-available-packages))
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index 7c00312c74..c5c56c5054 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -114,7 +114,7 @@ and the hash of its contents.\n"))
            (store (open-connection))
            (arg   (assq-ref opts 'argument))
            (uri   (or (string->uri arg)
-                      (leave (_ "guix-download: ~a: failed to parse URI~%")
+                      (leave (_ "~a: failed to parse URI~%")
                              arg)))
            (path  (case (uri-scheme uri)
                     ((file)
@@ -127,7 +127,7 @@ and the hash of its contents.\n"))
                                       (basename (uri-path uri))))))
            (hash  (call-with-input-file
                       (or path
-                          (leave (_ "guix-download: ~a: download failed~%")
+                          (leave (_ "~a: download failed~%")
                                  arg))
                     (compose sha256 get-bytevector-all)))
            (fmt   (assq-ref opts 'format)))
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 3d918923f8..7625bc46e6 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -87,9 +87,8 @@ interpreted."
              ("TB"  (expt 10 12))
              (""    1)
              (_
-              (leave (_ "error: unknown unit: ~a~%") unit)
-              (exit 1))))
-        (leave (_ "error: invalid number: ~a") numstr))))
+              (leave (_ "unknown unit: ~a~%") unit))))
+        (leave (_ "invalid number: ~a~%") numstr))))
 
 (define %options
   ;; Specification of the command-line options.
@@ -110,7 +109,7 @@ interpreted."
                       (let ((amount (size->number arg)))
                         (if arg
                             (alist-cons 'min-freed amount result)
-                            (leave (_ "error: invalid amount of storage: ~a~%")
+                            (leave (_ "invalid amount of storage: ~a~%")
                                    arg))))
                      (#f result)))))
         (option '(#\d "delete") #f #f
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 4295abaf57..c5656efc14 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -208,7 +208,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
       (switch-symlinks profile previous-profile))
 
     (cond ((not (file-exists? profile))           ; invalid profile
-           (leave (_ "error: profile `~a' does not exist~%")
+           (leave (_ "profile `~a' does not exist~%")
                   profile))
           ((zero? number)                         ; empty profile
            (format (current-error-port)
@@ -477,8 +477,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
     (define (ensure-output p sub-drv)
       (if (member sub-drv (package-outputs p))
           p
-          (leave (_ "~a: error: package `~a' lacks output `~a'~%")
-                 (location->string (package-location p))
+          (leave (_ "package `~a' lacks output `~a'~%")
                  (package-full-name p)
                  sub-drv)))
 
diff --git a/guix/ui.scm b/guix/ui.scm
index 938b5d259c..e42c331ed6 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -70,9 +71,8 @@
     (lambda _
       (setlocale LC_ALL ""))
     (lambda args
-      (format (current-error-port)
-              (_ "warning: failed to install locale: ~a~%")
-              (strerror (system-error-errno args))))))
+      (warning (_ "failed to install locale: ~a~%")
+               (strerror (system-error-errno args))))))
 
 (define (initialize-guix)
   "Perform the usual initialization for stand-alone Guix commands."
@@ -81,12 +81,6 @@
   (setvbuf (current-output-port) _IOLBF)
   (setvbuf (current-error-port) _IOLBF))
 
-(define-syntax-rule (leave fmt args ...)
-  "Format FMT and ARGS to the error port and exit."
-  (begin
-    (format (current-error-port) fmt args ...)
-    (exit 1)))
-
 (define* (show-version-and-exit #:optional (command (car (command-line))))
   "Display version information for COMMAND and `(exit 0)'."
   (simple-format #t "~a (~a) ~a~%"
@@ -111,16 +105,16 @@ General help using GNU software: <http://www.gnu.org/gethelp/>"))
                     (file     (location-file location))
                     (line     (location-line location))
                     (column   (location-column location)))
-               (leave (_ "~a:~a:~a: error: package `~a' has an invalid input: ~s~%")
+               (leave (_ "~a:~a:~a: package `~a' has an invalid input: ~s~%")
                       file line column
                       (package-full-name package) input)))
             ((nix-connection-error? c)
-             (leave (_ "error: failed to connect to `~a': ~a~%")
+             (leave (_ "failed to connect to `~a': ~a~%")
                     (nix-connection-error-file c)
                     (strerror (nix-connection-error-code c))))
             ((nix-protocol-error? c)
              ;; FIXME: Server-provided error messages aren't i18n'd.
-             (leave (_ "error: build failed: ~a~%")
+             (leave (_ "build failed: ~a~%")
                     (nix-protocol-error-message c))))
     (thunk)))
 
@@ -375,35 +369,41 @@ WIDTH columns."
 (define guix-warning-port
   (make-parameter (current-warning-port)))
 
-(define-syntax warning
-  (lambda (s)
-    "Emit a warming.  The macro assumes that `_' is bound to `gettext'."
-    ;; All this just to preserve `-Wformat' warnings.  Too much?
+(define-syntax-rule (define-diagnostic name prefix)
+  "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
+messages."
+  (define-syntax name
+    (lambda (x)
+      (define (augmented-format-string fmt)
+        (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))
 
-    (define (augmented-format-string fmt)
-      (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))
+      (syntax-case x (N_ _)                    ; these are literals, yeah...
+        ((name (_ fmt) args (... ...))
+         (string? (syntax->datum #'fmt))
+         (with-syntax ((fmt*   (augmented-format-string #'fmt))
+                       (prefix (datum->syntax x prefix)))
+           #'(format (guix-warning-port) (gettext fmt*)
+                     (program-name) (program-name) prefix
+                     args (... ...))))
+        ((name (N_ singular plural n) args (... ...))
+         (and (string? (syntax->datum #'singular))
+              (string? (syntax->datum #'plural)))
+         (with-syntax ((s      (augmented-format-string #'singular))
+                       (p      (augmented-format-string #'plural))
+                       (prefix (datum->syntax x prefix)))
+           #'(format (guix-warning-port)
+                     (ngettext s p n %gettext-domain)
+                     (program-name) (program-name) prefix
+                     args (... ...))))))))
 
-    (define prefix
-      #'(_ "warning: "))
+(define-diagnostic warning "warning: ") ; emit a warning
 
-    (syntax-case s (N_ _)                        ; these are literals, yeah...
-      ((warning (_ fmt) args ...)
-       (string? (syntax->datum #'fmt))
-       (with-syntax ((fmt*   (augmented-format-string #'fmt))
-                     (prefix prefix))
-         #'(format (guix-warning-port) (gettext fmt*)
-                   (program-name) (program-name) prefix
-                   args ...)))
-      ((warning (N_ singular plural n) args ...)
-       (and (string? (syntax->datum #'singular))
-            (string? (syntax->datum #'plural)))
-       (with-syntax ((s (augmented-format-string #'singular))
-                     (p (augmented-format-string #'plural))
-                     (b prefix))
-         #'(format (guix-warning-port)
-                   (ngettext s p n %gettext-domain)
-                   (program-name) (program-name) b
-                   args ...))))))
+(define-diagnostic report-error "error: ")
+(define-syntax-rule (leave args ...)
+  "Emit an error message and exit."
+  (begin
+    (report-error args ...)
+    (exit 1)))
 
 (define (guix-main arg0 . args)
   (initialize-guix)
diff --git a/po/POTFILES.in b/po/POTFILES.in
index bdb894db20..528e7a6aa7 100644
--- a/po/POTFILES.in
+++ b/po/POTFILES.in
@@ -9,4 +9,5 @@ guix/scripts/download.scm
 guix/scripts/package.scm
 guix/scripts/gc.scm
 guix/scripts/pull.scm
+guix/gnu-maintenance.scm
 guix/ui.scm

From fcdf58c46ceca31145ae817b7dee820ecf864b8f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 21 Apr 2013 11:18:22 +0200
Subject: [PATCH 46/74] gnu: guile: Update to 2.0.9.

* gnu/packages/guile.scm (guile-2.0): Update to 2.0.9.
  (guile-2.0/fixed): Keep at 2.0.7.
---
 gnu/packages/guile.scm | 14 +++++++++++---
 1 file changed, 11 insertions(+), 3 deletions(-)

diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm
index 763584d7dc..e0896ec6e8 100644
--- a/gnu/packages/guile.scm
+++ b/gnu/packages/guile.scm
@@ -99,14 +99,14 @@ extensible.  It supports many SRFIs.")
 (define-public guile-2.0
   (package
    (name "guile")
-   (version "2.0.7")
+   (version "2.0.9")
    (source (origin
             (method url-fetch)
             (uri (string-append "mirror://gnu/guile/guile-" version
                                 ".tar.xz"))
             (sha256
              (base32
-              "0f53pxkia4v17n0avwqlcjpy0n89hkazm2xsa6p84lv8k6k8y9vg"))))
+              "0nw9y8vjyz4r61v06p9msks5lm58pd91irmzg4k487vmv743h2pp"))))
    (build-system gnu-build-system)
    (native-inputs `(("pkgconfig" ,pkg-config)))
    (inputs `(("libffi" ,libffi)
@@ -151,7 +151,15 @@ call interface, and powerful string processing.")
 (define-public guile-2.0/fixed
   ;; A package of Guile 2.0 that's rarely changed.  It is the one used
   ;; in the `base' module, and thus changing it entails a full rebuild.
-  guile-2.0)
+  (package (inherit guile-2.0)
+    (version "2.0.7")
+    (source (origin
+             (method url-fetch)
+             (uri (string-append "mirror://gnu/guile/guile-" version
+                                 ".tar.xz"))
+             (sha256
+              (base32
+               "0f53pxkia4v17n0avwqlcjpy0n89hkazm2xsa6p84lv8k6k8y9vg"))))))
 
 
 ;;;

From 238328c9901267ef32a8cd6edba1692ee4a4f1a5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 21 Apr 2013 11:53:06 +0200
Subject: [PATCH 47/74] ui: Move definition of `install-locale' after that of
 the `warning' macro.

* guix/ui.scm (install-locale): Move definition after that of `warning'.
---
 guix/ui.scm | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/guix/ui.scm b/guix/ui.scm
index e42c331ed6..778711be92 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -65,15 +65,6 @@
 (define _ (cut gettext <> %gettext-domain))
 (define N_ (cut ngettext <> <> <> %gettext-domain))
 
-(define (install-locale)
-  "Install the current locale settings."
-  (catch 'system-error
-    (lambda _
-      (setlocale LC_ALL ""))
-    (lambda args
-      (warning (_ "failed to install locale: ~a~%")
-               (strerror (system-error-errno args))))))
-
 (define (initialize-guix)
   "Perform the usual initialization for stand-alone Guix commands."
   (install-locale)
@@ -405,6 +396,15 @@ messages."
     (report-error args ...)
     (exit 1)))
 
+(define (install-locale)
+  "Install the current locale settings."
+  (catch 'system-error
+    (lambda _
+      (setlocale LC_ALL ""))
+    (lambda args
+      (warning (_ "failed to install locale: ~a~%")
+               (strerror (system-error-errno args))))))
+
 (define (guix-main arg0 . args)
   (initialize-guix)
   (let ()

From bfda2997c8d4f0ac14f1bd54f87cd320039cfd3d Mon Sep 17 00:00:00 2001
From: Nikita Karetnikov <nikita@karetnikov.org>
Date: Sun, 21 Apr 2013 18:41:30 +0000
Subject: [PATCH 48/74] guix download: Add supported formats to '--help'.

* guix/scripts/download.scm (show-help): Add supported formats.
---
 guix/scripts/download.scm | 9 ++++++---
 1 file changed, 6 insertions(+), 3 deletions(-)

diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index c5c56c5054..c8760454de 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -55,11 +55,14 @@ store path."
   `((format . ,bytevector->nix-base32-string)))
 
 (define (show-help)
-  (display (_ "Usage: guix download [OPTION]... URL
+  (display (_ "Usage: guix download [OPTION] URL
 Download the file at URL, add it to the store, and print its store path
-and the hash of its contents.\n"))
+and the hash of its contents.
+
+Supported formats: 'nix-base32' (default), 'base32', and 'base16'
+('hex' and 'hexadecimal' can be used as well).\n"))
   (format #t (_ "
-  -f, --format=FMT       write the hash in the given format (default: `nix-base32')"))
+  -f, --format=FMT       write the hash in the given format"))
   (newline)
   (display (_ "
   -h, --help             display this help and exit"))

From 6c365eca6dafca37f0ac34d55221bcf197df49a3 Mon Sep 17 00:00:00 2001
From: Nikita Karetnikov <nikita@karetnikov.org>
Date: Sun, 21 Apr 2013 17:20:00 +0000
Subject: [PATCH 49/74] Add 'guix hash'.

* guix/scripts/hash.scm: New file.
* Makefile.am (MODULES): Add it.
* po/POTFILES.in: Add it.
* doc/guix.texi (Invoking guix hash): New node.
  (Defining Packages): Add a cross-reference to the 'Invoking guix
  hash' node.
---
 Makefile.am           |   1 +
 doc/guix.texi         |  37 ++++++++++++-
 guix/scripts/hash.scm | 120 ++++++++++++++++++++++++++++++++++++++++++
 po/POTFILES.in        |   1 +
 4 files changed, 157 insertions(+), 2 deletions(-)
 create mode 100644 guix/scripts/hash.scm

diff --git a/Makefile.am b/Makefile.am
index 3e697a258a..d1ae126f80 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -30,6 +30,7 @@ MODULES =					\
   guix/scripts/import.scm			\
   guix/scripts/package.scm			\
   guix/scripts/gc.scm				\
+  guix/scripts/hash.scm				\
   guix/scripts/pull.scm				\
   guix/scripts/substitute-binary.scm		\
   guix/base32.scm				\
diff --git a/doc/guix.texi b/doc/guix.texi
index f149eee6dd..e23eab0f81 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -814,8 +814,9 @@ the GNU mirrors defined in @code{(guix download)}.
 The @code{sha256} field specifies the expected SHA256 hash of the file
 being downloaded.  It is mandatory, and allows Guix to check the
 integrity of the file.  The @code{(base32 @dots{})} form introduces the
-base32 representation of the hash.  A convenient way to obtain this
-information is with the @code{guix download} tool.
+base32 representation of the hash.  You can obtain this information with
+the @code{guix hash} (@pxref{Invoking guix hash}) and @code{guix
+download} tools.
 
 @item
 @cindex GNU Build System
@@ -1094,6 +1095,7 @@ space.
 
 @menu
 * Invoking guix build:: Building packages from the command line.
+* Invoking guix hash:: Computing the cryptographic hash of a file.
 @end menu
 
 @node Invoking guix build
@@ -1189,6 +1191,37 @@ the @code{package-derivation} procedure of the @code{(guix packages)}
 module, and to the @code{build-derivations} procedure of the @code{(guix
 store)} module.
 
+@node Invoking guix hash
+@section Invoking @command{guix hash}
+
+The @command{guix hash} command allows to check the integrity of a file.
+It is primarily a convenience tool for anyone contributing to the
+distribution: it computes the cryptographic hash of a file, which can be
+used in the definition of a package (@pxref{Defining Packages}).
+
+The general syntax is:
+
+@example
+guix hash @var{option} @var{file}
+@end example
+
+@command{guix hash} has the following option:
+
+@table @code
+
+@item --format=@var{fmt}
+@itemx -f @var{fmt}
+Write the hash in the given format.
+
+Supported formats: @code{nix-base32}, @code{base32}, @code{base16}
+(@code{hex} and @code{hexadecimal} can be used as well).
+
+If the @option{--format} option is not specified, @command{guix hash}
+will output the hash in @code{nix-base32}.  This representation is used
+in the definitions of packages.
+
+@end table
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
new file mode 100644
index 0000000000..ad05a4e66f
--- /dev/null
+++ b/guix/scripts/hash.scm
@@ -0,0 +1,120 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts hash)
+    #:use-module (guix base32)
+    #:use-module (guix ui)
+    #:use-module (guix utils)
+    #:use-module (rnrs io ports)
+    #:use-module (rnrs files)
+    #:use-module (ice-9 match)
+    #:use-module (srfi srfi-1)
+    #:use-module (srfi srfi-26)
+    #:use-module (srfi srfi-37)
+    #:export (guix-hash))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+  ;; Alist of default option values.
+  `((format . ,bytevector->nix-base32-string)))
+
+(define (show-help)
+  (display (_ "Usage: guix hash [OPTION] FILE
+Return the cryptographic hash of FILE.
+
+Supported formats: 'nix-base32' (default), 'base32', and 'base16'
+('hex' and 'hexadecimal' can be used as well).\n"))
+  (format #t (_ "
+  -f, --format=FMT       write the hash in the given format"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specification of the command-line options.
+  (list (option '(#\f "format") #t #f
+                (lambda (opt name arg result)
+                  (define fmt-proc
+                    (match arg
+                      ("nix-base32"
+                       bytevector->nix-base32-string)
+                      ("base32"
+                       bytevector->base32-string)
+                      ((or "base16" "hex" "hexadecimal")
+                       bytevector->base16-string)
+                      (x
+                       (leave (_ "unsupported hash format: ~a~%")
+                              arg))))
+
+                  (alist-cons 'format fmt-proc
+                              (alist-delete 'format result))))
+
+        (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix hash")))))
+
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-hash . args)
+  (define (parse-options)
+    ;; Return the alist of option values.
+    (args-fold args %options
+               (lambda (opt name arg result)
+                 (leave (_ "unrecognized option: ~a~%")
+                        name))
+               (lambda (arg result)
+                 (alist-cons 'argument arg result))
+               %default-options))
+
+    (let* ((opts (parse-options))
+           (args (filter-map (match-lambda
+                              (('argument . value)
+                               value)
+                              (_ #f))
+                             (reverse opts)))
+           (fmt  (assq-ref opts 'format)))
+
+      (match args
+        ((file)
+         (catch 'system-error
+           (lambda ()
+             (format #t "~a~%"
+                     (call-with-input-file file
+                       (compose fmt sha256 get-bytevector-all))))
+           (lambda args
+             (leave (_ "~a~%")
+                    (strerror (system-error-errno args))))))
+        (_
+         (leave (_ "wrong number of arguments~%"))))))
diff --git a/po/POTFILES.in b/po/POTFILES.in
index 528e7a6aa7..3b01e2a2a5 100644
--- a/po/POTFILES.in
+++ b/po/POTFILES.in
@@ -8,6 +8,7 @@ guix/scripts/build.scm
 guix/scripts/download.scm
 guix/scripts/package.scm
 guix/scripts/gc.scm
+guix/scripts/hash.scm
 guix/scripts/pull.scm
 guix/gnu-maintenance.scm
 guix/ui.scm

From 861693f3e71fed8663a3ef9c336c3f3345e1e039 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 21 Apr 2013 22:40:23 +0200
Subject: [PATCH 50/74] Factorize `download-and-store'.

* guix/download.scm (download-to-store): New procedure.
* guix/scripts/download.scm (fetch-and-store): Remove.
  (guix-download): Use `download-to-store' instead.
* guix/ui.scm (call-with-temporary-output-file): Move to...
* guix/utils.scm (call-with-temporary-output-file): ... here.
---
 guix/download.scm         | 19 +++++++++++++++++--
 guix/scripts/download.scm | 23 +++--------------------
 guix/ui.scm               | 16 ----------------
 guix/utils.scm            | 16 ++++++++++++++++
 4 files changed, 36 insertions(+), 38 deletions(-)

diff --git a/guix/download.scm b/guix/download.scm
index ea00798b4b..b315b4c1d0 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -21,13 +21,15 @@
   #:use-module (ice-9 match)
   #:use-module (guix derivations)
   #:use-module (guix packages)
-  #:use-module ((guix store) #:select (derivation-path?))
+  #:use-module ((guix store) #:select (derivation-path? add-to-store))
+  #:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:))
   #:use-module (guix utils)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:export (%mirrors
-            url-fetch))
+            url-fetch
+            download-to-store))
 
 ;;; Commentary:
 ;;;
@@ -231,4 +233,17 @@ must be a list of symbol/URL-list pairs."
                                   #:guile-for-build guile-for-build
                                   #:env-vars env-vars)))
 
+(define* (download-to-store store url #:optional (name (basename url))
+                            #:key (log (current-error-port)))
+  "Download from URL to STORE, either under NAME or URL's basename if
+omitted.  Write progress reports to LOG."
+  (call-with-temporary-output-file
+   (lambda (temp port)
+     (let ((result
+            (parameterize ((current-output-port log))
+              (build:url-fetch url temp #:mirrors %mirrors))))
+       (close port)
+       (and result
+            (add-to-store store name #f "sha256" temp))))))
+
 ;;; download.scm ends here
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index c8760454de..220211e6b8 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -21,30 +21,15 @@
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix base32)
-  #:use-module ((guix download) #:select (%mirrors))
-  #:use-module (guix build download)
+  #:use-module (guix download)
   #:use-module (web uri)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11)
-  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:export (guix-download))
 
-(define (fetch-and-store store fetch name)
-  "Call FETCH for URI, and pass it the name of a file to write to; eventually,
-copy data from that port to STORE, under NAME.  Return the resulting
-store path."
-  (call-with-temporary-output-file
-   (lambda (temp port)
-     (let ((result
-            (parameterize ((current-output-port (current-error-port)))
-              (fetch temp))))
-       (close port)
-       (and result
-            (add-to-store store name #f "sha256" temp))))))
 
 ;;;
 ;;; Command-line options.
@@ -124,10 +109,8 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16'
                      (add-to-store store (basename (uri-path uri))
                                    #f "sha256" (uri-path uri)))
                     (else
-                     (fetch-and-store store
-                                      (cut url-fetch arg <>
-                                           #:mirrors %mirrors)
-                                      (basename (uri-path uri))))))
+                     (download-to-store store (uri->string uri)
+                                        (basename (uri-path uri))))))
            (hash  (call-with-input-file
                       (or path
                           (leave (_ "~a: download failed~%")
diff --git a/guix/ui.scm b/guix/ui.scm
index 778711be92..9ea2f02ce2 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -41,7 +41,6 @@
             with-error-handling
             read/eval-package-expression
             location->string
-            call-with-temporary-output-file
             switch-symlinks
             config-directory
             fill-paragraph
@@ -205,21 +204,6 @@ available for download."
     (($ <location> file line column)
      (format #f "~a:~a:~a" file line column))))
 
-(define (call-with-temporary-output-file proc)
-  "Call PROC with a name of a temporary file and open output port to that
-file; close the file and delete it when leaving the dynamic extent of this
-call."
-  (let* ((template (string-copy "guix-file.XXXXXX"))
-         (out      (mkstemp! template)))
-    (dynamic-wind
-      (lambda ()
-        #t)
-      (lambda ()
-        (proc template out))
-      (lambda ()
-        (false-if-exception (close out))
-        (false-if-exception (delete-file template))))))
-
 (define (switch-symlinks link target)
   "Atomically switch LINK, a symbolic link, to point to TARGET.  Works
 both when LINK already exists and when it does not."
diff --git a/guix/utils.scm b/guix/utils.scm
index f13e585e2b..ad1c463be8 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -60,6 +60,7 @@
             version-compare
             version>?
             package-name->name+version
+            call-with-temporary-output-file
             fold2))
 
 
@@ -464,6 +465,21 @@ introduce the version part."
       ((head tail ...)
        (loop tail (cons head prefix))))))
 
+(define (call-with-temporary-output-file proc)
+  "Call PROC with a name of a temporary file and open output port to that
+file; close the file and delete it when leaving the dynamic extent of this
+call."
+  (let* ((template (string-copy "guix-file.XXXXXX"))
+         (out      (mkstemp! template)))
+    (dynamic-wind
+      (lambda ()
+        #t)
+      (lambda ()
+        (proc template out))
+      (lambda ()
+        (false-if-exception (close out))
+        (false-if-exception (delete-file template))))))
+
 (define fold2
   (case-lambda
     ((proc seed1 seed2 lst)

From 6ed80bed48208d4a6e7a8aa394689b7274bace87 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 21 Apr 2013 02:54:56 -0400
Subject: [PATCH 51/74] gnu: gprolog: Update to 1.4.3 and download from GNU
 mirrors

* gnu/packages/gprolog.scm (gprolog): Update to 1.4.3.
  Download from GNU mirrors.
---
 gnu/packages/gprolog.scm | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git a/gnu/packages/gprolog.scm b/gnu/packages/gprolog.scm
index c362a7bc11..7f7cbe0178 100644
--- a/gnu/packages/gprolog.scm
+++ b/gnu/packages/gprolog.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,15 +26,15 @@
 (define-public gprolog
   (package
     (name "gprolog")
-    (version "1.4.2")
+    (version "1.4.3")
     (source
      (origin
       (method url-fetch)
-      (uri (string-append "http://www.gprolog.org/gprolog-"
-                          version ".tar.gz"))
+      (uri (string-append "mirror://gnu/gprolog/gprolog-" version
+                          ".tar.gz"))
       (sha256
        (base32
-        "0y25c2gwz41i6g28qyfjklrmanzgk0c8cr4jn2s7s8qgd9dnm1fm"))))
+        "16yl6q9ydx9d8lphg9xkk53l1m0fq0kpvrhry8njsxhhncazm4j2"))))
     (build-system gnu-build-system)
     (arguments
      `(#:phases (alist-cons-before

From 2306f7ab4bab7bf916bc7997a4aae48008690135 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 21 Apr 2013 22:41:17 -0400
Subject: [PATCH 52/74] gnu: groff: Update to 1.22.2.

* gnu/packages/groff.scm (groff): Update to 1.22.2.
---
 gnu/packages/groff.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/groff.scm b/gnu/packages/groff.scm
index 5265faeee5..0bdb67f0bb 100644
--- a/gnu/packages/groff.scm
+++ b/gnu/packages/groff.scm
@@ -31,13 +31,13 @@
 (define-public groff
   (package
    (name "groff")
-   (version "1.22.1")
+   (version "1.22.2")
    (source (origin
             (method url-fetch)
             (uri (string-append "mirror://gnu/groff/groff-" version
                                 ".tar.gz"))
             (sha256 (base32
-                     "1kihja9sj182pqms8lah2nn3y96rqccws7w04f7f7wpy84vs5bvn"))))
+                     "0xi07nhj5vdgax37rj25mwxzdmsz1ifx50hjgc6hqbkpqkd6821q"))))
    (build-system gnu-build-system)
    (inputs `(("bison" ,bison)
              ("ghostscript" ,ghostscript)

From 693b57e41c9e472f712495a99fc43bfde1dd02c2 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 21 Apr 2013 22:52:35 -0400
Subject: [PATCH 53/74] gnu: smalltalk: Update to 3.2.5.

* gnu/packages/smalltalk.scm (smalltalk): Update to 3.2.5.
---
 gnu/packages/smalltalk.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/smalltalk.scm b/gnu/packages/smalltalk.scm
index 1b4a3289ac..976e526a7b 100644
--- a/gnu/packages/smalltalk.scm
+++ b/gnu/packages/smalltalk.scm
@@ -26,7 +26,7 @@
 (define-public smalltalk
   (package
     (name "smalltalk")
-    (version "3.2.4")
+    (version "3.2.5")
     (source
      (origin
       (method url-fetch)
@@ -34,7 +34,7 @@
                           version ".tar.xz"))
       (sha256
        (base32
-        "1bdhbppjv1fswh4ls9q90zix38l1hg9qd4c4bz1pbg1af991xq3a"))))
+        "1k2ssrapfzhngc7bg1zrnd9n2vyxp9c9m70byvsma6wapbvib6l1"))))
     (build-system gnu-build-system)
     (inputs `(("zip" ,zip)))
     (arguments

From 19c9664d9350afddb34fb9ea339ad243a5246718 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 21 Apr 2013 22:56:01 -0400
Subject: [PATCH 54/74] gnu: xorriso: Update to 1.2.8.

* gnu/packages/cdrom.scm (xorriso): Update to 1.2.8.
---
 gnu/packages/cdrom.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/cdrom.scm b/gnu/packages/cdrom.scm
index ccab52fc56..4f721ba624 100644
--- a/gnu/packages/cdrom.scm
+++ b/gnu/packages/cdrom.scm
@@ -88,14 +88,14 @@ well as utility programs such as an audio CD player and an extractor.")
 (define-public xorriso
   (package
     (name "xorriso")
-    (version "1.2.4")
+    (version "1.2.8")
     (source (origin
              (method url-fetch)
              (uri (string-append "mirror://gnu/xorriso/xorriso-"
                                  version ".tar.gz"))
              (sha256
               (base32
-               "1b2xh2x9fz4ihwfrmjzhbkfsrwi9c3zpmchgk7hqlkydzfgydwz8"))))
+               "1h3w9ymhsi0wghcnl7mmlml40rm4yill1c75g90xc7r1a2g8k1mn"))))
     (build-system gnu-build-system)
     (inputs
      `(("acl" ,acl)

From b2a886f6c7c8424ce024020aaa8927be9811f40b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 22 Apr 2013 13:24:16 +0200
Subject: [PATCH 55/74] ui: Move macro definitions before any use.

* guix/ui.scm (define-diagnostic, warning, report-error, leave): Move
  definitions before any use.  Reported by Nikita Karetnikov.
  (install-locale): Move back close to `initialize-guix'.
---
 guix/ui.scm | 90 ++++++++++++++++++++++++++---------------------------
 1 file changed, 45 insertions(+), 45 deletions(-)

diff --git a/guix/ui.scm b/guix/ui.scm
index 9ea2f02ce2..ff0966e85c 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -64,6 +64,51 @@
 (define _ (cut gettext <> %gettext-domain))
 (define N_ (cut ngettext <> <> <> %gettext-domain))
 
+(define-syntax-rule (define-diagnostic name prefix)
+  "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
+messages."
+  (define-syntax name
+    (lambda (x)
+      (define (augmented-format-string fmt)
+        (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))
+
+      (syntax-case x (N_ _)                    ; these are literals, yeah...
+        ((name (_ fmt) args (... ...))
+         (string? (syntax->datum #'fmt))
+         (with-syntax ((fmt*   (augmented-format-string #'fmt))
+                       (prefix (datum->syntax x prefix)))
+           #'(format (guix-warning-port) (gettext fmt*)
+                     (program-name) (program-name) prefix
+                     args (... ...))))
+        ((name (N_ singular plural n) args (... ...))
+         (and (string? (syntax->datum #'singular))
+              (string? (syntax->datum #'plural)))
+         (with-syntax ((s      (augmented-format-string #'singular))
+                       (p      (augmented-format-string #'plural))
+                       (prefix (datum->syntax x prefix)))
+           #'(format (guix-warning-port)
+                     (ngettext s p n %gettext-domain)
+                     (program-name) (program-name) prefix
+                     args (... ...))))))))
+
+(define-diagnostic warning "warning: ") ; emit a warning
+
+(define-diagnostic report-error "error: ")
+(define-syntax-rule (leave args ...)
+  "Emit an error message and exit."
+  (begin
+    (report-error args ...)
+    (exit 1)))
+
+(define (install-locale)
+  "Install the current locale settings."
+  (catch 'system-error
+    (lambda _
+      (setlocale LC_ALL ""))
+    (lambda args
+      (warning (_ "failed to install locale: ~a~%")
+               (strerror (system-error-errno args))))))
+
 (define (initialize-guix)
   "Perform the usual initialization for stand-alone Guix commands."
   (install-locale)
@@ -344,51 +389,6 @@ WIDTH columns."
 (define guix-warning-port
   (make-parameter (current-warning-port)))
 
-(define-syntax-rule (define-diagnostic name prefix)
-  "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
-messages."
-  (define-syntax name
-    (lambda (x)
-      (define (augmented-format-string fmt)
-        (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))
-
-      (syntax-case x (N_ _)                    ; these are literals, yeah...
-        ((name (_ fmt) args (... ...))
-         (string? (syntax->datum #'fmt))
-         (with-syntax ((fmt*   (augmented-format-string #'fmt))
-                       (prefix (datum->syntax x prefix)))
-           #'(format (guix-warning-port) (gettext fmt*)
-                     (program-name) (program-name) prefix
-                     args (... ...))))
-        ((name (N_ singular plural n) args (... ...))
-         (and (string? (syntax->datum #'singular))
-              (string? (syntax->datum #'plural)))
-         (with-syntax ((s      (augmented-format-string #'singular))
-                       (p      (augmented-format-string #'plural))
-                       (prefix (datum->syntax x prefix)))
-           #'(format (guix-warning-port)
-                     (ngettext s p n %gettext-domain)
-                     (program-name) (program-name) prefix
-                     args (... ...))))))))
-
-(define-diagnostic warning "warning: ") ; emit a warning
-
-(define-diagnostic report-error "error: ")
-(define-syntax-rule (leave args ...)
-  "Emit an error message and exit."
-  (begin
-    (report-error args ...)
-    (exit 1)))
-
-(define (install-locale)
-  "Install the current locale settings."
-  (catch 'system-error
-    (lambda _
-      (setlocale LC_ALL ""))
-    (lambda args
-      (warning (_ "failed to install locale: ~a~%")
-               (strerror (system-error-errno args))))))
-
 (define (guix-main arg0 . args)
   (initialize-guix)
   (let ()

From d66c70967f9bd792acdd00036292dc0a7b858742 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 22 Apr 2013 23:07:13 +0200
Subject: [PATCH 56/74] packages: Add `package-field-location'.

* guix/packages.scm (package-field-location): New procedure.
* build-aux/sync-synopses.scm: Use it instead of `package-location'.
* tests/packages.scm ("package-field-location"): New test.
---
 build-aux/sync-synopses.scm |  2 +-
 guix/packages.scm           | 47 +++++++++++++++++++++++++++++++++++++
 tests/packages.scm          | 21 +++++++++++++++++
 3 files changed, 69 insertions(+), 1 deletion(-)

diff --git a/build-aux/sync-synopses.scm b/build-aux/sync-synopses.scm
index 9aaff11ce0..3681b8c623 100644
--- a/build-aux/sync-synopses.scm
+++ b/build-aux/sync-synopses.scm
@@ -52,7 +52,7 @@
            ((package . descriptor)
             (let ((upstream   (gnu-package-doc-summary descriptor))
                   (downstream (package-synopsis package))
-                  (loc        (package-location package)))
+                  (loc        (package-field-location package 'synopsis)))
               (unless (and upstream (string=? upstream downstream))
                 (format (guix-warning-port)
                         "~a: ~a: proposed synopsis: ~s~%"
diff --git a/guix/packages.scm b/guix/packages.scm
index 81f09d638e..8490bfe438 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -28,6 +28,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module ((ice-9 rdelim) #:select (read-line))
+  #:use-module (ice-9 regex)
   #:re-export (%current-system)
   #:export (origin
             origin?
@@ -58,6 +60,7 @@
             package-maintainers
             package-properties
             package-location
+            package-field-location
 
             package-transitive-inputs
             package-transitive-propagated-inputs
@@ -159,6 +162,50 @@ representation."
                                                        package)
                                                       16)))))
 
+(define (package-field-location package field)
+  "Return an estimate of the source code location of the definition of FIELD
+for PACKAGE."
+  (define field-rx
+    (make-regexp (string-append "\\("
+                                (regexp-quote (symbol->string field))
+                                "[[:blank:]]*")))
+  (define (seek-to-line port line)
+    (let ((line (- line 1)))
+      (let loop ()
+        (when (< (port-line port) line)
+          (unless (eof-object? (read-line port))
+            (loop))))))
+
+  (define (find-line port)
+    (let loop ((line (read-line port)))
+      (cond ((eof-object? line)
+             (values #f #f))
+            ((regexp-exec field-rx line)
+             =>
+             (lambda (match)
+               ;; At this point `port-line' points to the next line, so need
+               ;; need to add one.
+               (values (port-line port)
+                       (match:end match))))
+            (else
+             (loop (read-line port))))))
+
+  (match (package-location package)
+    (($ <location> file line column)
+     (catch 'system
+       (lambda ()
+         (call-with-input-file (search-path %load-path file)
+           (lambda (port)
+             (seek-to-line port line)
+             (let-values (((line column)
+                           (find-line port)))
+               (if (and line column)
+                   (location file line column)
+                   (package-location package))))))
+       (lambda _
+         (package-location package))))
+    (_ #f)))
+
 
 ;; Error conditions.
 
diff --git a/tests/packages.scm b/tests/packages.scm
index c5d9d280ed..bf82aba858 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -52,6 +52,27 @@
            (home-page #f) (license #f)
            extra-fields ...))
 
+(test-assert "package-field-location"
+  (let ()
+    (define (goto port line column)
+      (unless (and (= (port-column port) (- column 1))
+                   (= (port-line port) (- line 1)))
+        (unless (eof-object? (get-char port))
+          (goto port line column))))
+
+    (define read-at
+      (match-lambda
+       (($ <location> file line column)
+        (call-with-input-file (search-path %load-path file)
+          (lambda (port)
+            (goto port line column)
+            (read port))))))
+
+    (and (equal? (read-at (package-field-location %bootstrap-guile 'name))
+                 (package-name %bootstrap-guile))
+         (equal? (read-at (package-field-location %bootstrap-guile 'version))
+                 (package-version %bootstrap-guile)))))
+
 (test-assert "package-transitive-inputs"
   (let* ((a (dummy-package "a"))
          (b (dummy-package "b"

From 867b14108d4ee1313c02d29283fb0aa22c60e806 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 24 Apr 2013 17:13:21 -0400
Subject: [PATCH 57/74] gnu: hop: Update hash to match hop-2.4.0.tar.gz, which
 was modified in place.

* gnu/packages/scheme.scm (hop): Update the hash.
---
 gnu/packages/scheme.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index 49b6df9b0d..5eebb58379 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -197,7 +197,7 @@ between Scheme and C# programs.")
                                  version ".tar.gz"))
              (sha256
               (base32
-               "04fhy5jp9lq12fmdqfjzj1w32f7nxc80fagbj7pfci7xh86nm2c5"))))
+               "1v2r4ga58kk1sx0frn8qa8ccmjpic9csqzpk499wc95y9c4b1wy3"))))
     (build-system gnu-build-system)
     (arguments
      '(#:phases

From 5fe21fbeefe109f400aef40a51f71af111546fa3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 24 Apr 2013 14:44:33 +0200
Subject: [PATCH 58/74] utils: Fix column number returned by
 `source-properties->location'.

* guix/utils.scm (source-properties->location): Use COL, not COL + 1.
---
 guix/utils.scm | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/guix/utils.scm b/guix/utils.scm
index ad1c463be8..4f399b95c3 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -533,5 +533,6 @@ etc."
   (let ((file (assq-ref loc 'filename))
         (line (assq-ref loc 'line))
         (col  (assq-ref loc 'column)))
-    ;; In accordance with the GCS, start line and column numbers at 1.
-    (location file (and line (+ line 1)) (and col (+ col 1)))))
+    ;; In accordance with the GCS, start line and column numbers at 1.  Note
+    ;; that unlike LINE and `port-column', COL is actually 1-indexed here...
+    (location file (and line (+ line 1)) col)))

From f903dc056a5176033daca7a69d5b2c8376ff0677 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 24 Apr 2013 14:43:31 +0200
Subject: [PATCH 59/74] packages: Use `read' and source properties for
 `package-field-location'.

* guix/packages.scm (package-field-location): Rewrite using `read' and
  source properties.  Change to return #f upon failure.
* tests/packages.scm ("package-field-location"): Check for #f upon failure.
* build-aux/sync-synopses.scm: Adjust accordingly.
---
 build-aux/sync-synopses.scm |  3 +-
 guix/packages.scm           | 56 ++++++++++++++-----------------------
 tests/packages.scm          |  3 +-
 3 files changed, 25 insertions(+), 37 deletions(-)

diff --git a/build-aux/sync-synopses.scm b/build-aux/sync-synopses.scm
index 3681b8c623..c1049d3398 100644
--- a/build-aux/sync-synopses.scm
+++ b/build-aux/sync-synopses.scm
@@ -52,7 +52,8 @@
            ((package . descriptor)
             (let ((upstream   (gnu-package-doc-summary descriptor))
                   (downstream (package-synopsis package))
-                  (loc        (package-field-location package 'synopsis)))
+                  (loc        (or (package-field-location package 'synopsis)
+                                  (package-location package))))
               (unless (and upstream (string=? upstream downstream))
                 (format (guix-warning-port)
                         "~a: ~a: proposed synopsis: ~s~%"
diff --git a/guix/packages.scm b/guix/packages.scm
index 8490bfe438..ec5420f6c0 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -28,8 +28,6 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
-  #:use-module ((ice-9 rdelim) #:select (read-line))
-  #:use-module (ice-9 regex)
   #:re-export (%current-system)
   #:export (origin
             origin?
@@ -163,32 +161,13 @@ representation."
                                                       16)))))
 
 (define (package-field-location package field)
-  "Return an estimate of the source code location of the definition of FIELD
-for PACKAGE."
-  (define field-rx
-    (make-regexp (string-append "\\("
-                                (regexp-quote (symbol->string field))
-                                "[[:blank:]]*")))
-  (define (seek-to-line port line)
-    (let ((line (- line 1)))
-      (let loop ()
-        (when (< (port-line port) line)
-          (unless (eof-object? (read-line port))
-            (loop))))))
-
-  (define (find-line port)
-    (let loop ((line (read-line port)))
-      (cond ((eof-object? line)
-             (values #f #f))
-            ((regexp-exec field-rx line)
-             =>
-             (lambda (match)
-               ;; At this point `port-line' points to the next line, so need
-               ;; need to add one.
-               (values (port-line port)
-                       (match:end match))))
-            (else
-             (loop (read-line port))))))
+  "Return the source code location of the definition of FIELD for PACKAGE, or
+#f if it could not be determined."
+  (define (goto port line column)
+    (unless (and (= (port-column port) (- column 1))
+                 (= (port-line port) (- line 1)))
+      (unless (eof-object? (read-char port))
+        (goto port line column))))
 
   (match (package-location package)
     (($ <location> file line column)
@@ -196,14 +175,21 @@ for PACKAGE."
        (lambda ()
          (call-with-input-file (search-path %load-path file)
            (lambda (port)
-             (seek-to-line port line)
-             (let-values (((line column)
-                           (find-line port)))
-               (if (and line column)
-                   (location file line column)
-                   (package-location package))))))
+             (goto port line column)
+             (match (read port)
+               (('package inits ...)
+                (let ((field (assoc field inits)))
+                  (match field
+                    ((_ value)
+                     (and=> (or (source-properties value)
+                                (source-properties field))
+                            source-properties->location))
+                    (_
+                     #f))))
+               (_
+                #f)))))
        (lambda _
-         (package-location package))))
+         #f)))
     (_ #f)))
 
 
diff --git a/tests/packages.scm b/tests/packages.scm
index bf82aba858..22985d6e9a 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -71,7 +71,8 @@
     (and (equal? (read-at (package-field-location %bootstrap-guile 'name))
                  (package-name %bootstrap-guile))
          (equal? (read-at (package-field-location %bootstrap-guile 'version))
-                 (package-version %bootstrap-guile)))))
+                 (package-version %bootstrap-guile))
+         (not (package-field-location %bootstrap-guile 'does-not-exist)))))
 
 (test-assert "package-transitive-inputs"
   (let* ((a (dummy-package "a"))

From 0fdd3bea58a872f2734c7d8747d7dbdd108d97d8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 24 Apr 2013 23:48:36 +0200
Subject: [PATCH 60/74] Add `guix refresh' and related auto-update tools.

* guix/gnu-maintenance.scm (ftp-server/directory)[quirks]: Add glib.
  (package-update-path, download-tarball, package-update,
  update-package-source): New procedures.
* guix/gnupg.scm, guix/scripts/refresh.scm: New files.
* Makefile.am (MODULES): Add them.
* guix/utils.scm (file-extension): New procedure.
---
 Makefile.am              |   2 +
 guix/gnu-maintenance.scm | 124 +++++++++++++++++++++++++++++++-
 guix/gnupg.scm           | 152 +++++++++++++++++++++++++++++++++++++++
 guix/scripts/refresh.scm | 137 +++++++++++++++++++++++++++++++++++
 guix/utils.scm           |   6 ++
 5 files changed, 420 insertions(+), 1 deletion(-)
 create mode 100644 guix/gnupg.scm
 create mode 100644 guix/scripts/refresh.scm

diff --git a/Makefile.am b/Makefile.am
index d1ae126f80..442e53e7f6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -33,6 +33,7 @@ MODULES =					\
   guix/scripts/hash.scm				\
   guix/scripts/pull.scm				\
   guix/scripts/substitute-binary.scm		\
+  guix/scripts/refresh.scm			\
   guix/base32.scm				\
   guix/utils.scm				\
   guix/serialization.scm			\
@@ -47,6 +48,7 @@ MODULES =					\
   guix/build-system/perl.scm			\
   guix/build-system/trivial.scm			\
   guix/ftp-client.scm				\
+  guix/gnupg.scm				\
   guix/store.scm				\
   guix/ui.scm					\
   guix/build/download.scm			\
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 0dc2fab092..619cb3106a 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -32,6 +32,12 @@
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix packages)
+  #:use-module ((guix download) #:select (download-to-store))
+  #:use-module (guix gnupg)
+  #:use-module (rnrs io ports)
+  #:use-module (guix base32)
+  #:use-module ((guix build utils)
+                #:select (substitute))
   #:export (gnu-package-name
             gnu-package-mundane-name
             gnu-package-copyright-holder
@@ -50,7 +56,10 @@
 
             releases
             latest-release
-            gnu-package-name->name+version))
+            gnu-package-name->name+version
+            package-update-path
+            package-update
+            update-package-source))
 
 ;;; Commentary:
 ;;;
@@ -234,6 +243,7 @@ stored."
       ("mit-scheme"   "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg")
       ("icecat"       "ftp.gnu.org" "/gnu/gnuzilla")
       ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite")
+      ("glib"         "ftp.gnome.org" "/pub/gnome/sources/glib")
       ("TeXmacs"      "ftp.texmacs.org" "/TeXmacs/targz")))
 
   (match (assoc project quirks)
@@ -320,4 +330,116 @@ pairs.  Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
         (values name+version #f)
         (values (match:substring match 1) (match:substring match 2)))))
 
+
+;;;
+;;; Auto-update.
+;;;
+
+(define (package-update-path package)
+  "Return an update path for PACKAGE, or #f if no update is needed."
+  (and (gnu-package? package)
+       (match (latest-release (package-name package))
+         ((name+version . directory)
+          (let-values (((_ new-version)
+                        (package-name->name+version name+version)))
+            (and (version>? name+version (package-full-name package))
+                 `(,new-version . ,directory))))
+         (_ #f))))
+
+(define* (download-tarball store project directory version
+                           #:optional (archive-type "gz"))
+  "Download PROJECT's tarball over FTP and check its OpenPGP signature.  On
+success, return the tarball file name."
+  (let* ((server  (ftp-server/directory project))
+         (base    (string-append project "-" version ".tar." archive-type))
+         (url     (string-append "ftp://" server "/" directory "/" base))
+         (sig-url (string-append url ".sig"))
+         (tarball (download-to-store store url))
+         (sig     (download-to-store store sig-url)))
+    (let ((ret (gnupg-verify* sig tarball)))
+      (if ret
+          tarball
+          (begin
+            (warning (_ "signature verification failed for `~a'")
+                     base)
+            (warning (_ "(could be because the public key is not in your keyring)"))
+            #f)))))
+
+(define (package-update store package)
+  "Return the new version and the file name of the new version tarball for
+PACKAGE, or #f and #f when PACKAGE is up-to-date."
+  (match (package-update-path package)
+    ((version . directory)
+     (let-values (((name)
+                   (package-name package))
+                  ((archive-type)
+                   (let ((source (package-source package)))
+                     (or (and (origin? source)
+                              (file-extension (origin-uri source)))
+                         "gz"))))
+       (let ((tarball (download-tarball store name directory version
+                                        archive-type)))
+         (values version tarball))))
+    (_
+     (values #f #f))))
+
+(define (update-package-source package version hash)
+  "Modify the source file that defines PACKAGE to refer to VERSION,
+whose tarball has SHA256 HASH (a bytevector).  Return the new version string
+if an update was made, and #f otherwise."
+  (define (new-line line matches replacement)
+    ;; Iterate over MATCHES and return the modified line based on LINE.
+    ;; Replace each match with REPLACEMENT.
+    (let loop ((m* matches)                       ; matches
+               (o  0)                             ; offset in L
+               (r  '()))                          ; result
+      (match m*
+        (()
+         (let ((r (cons (substring line o) r)))
+           (string-concatenate-reverse r)))
+        ((m . rest)
+         (loop rest
+               (match:end m)
+               (cons* replacement
+                      (substring line o (match:start m))
+                      r))))))
+
+  (define (update-source file old-version version
+                         old-hash hash)
+    ;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION
+    ;; and occurrences of OLD-HASH by HASH (base32 representation thereof).
+
+    ;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in
+    ;; different unrelated places, we may modify it more than needed, for
+    ;; instance.  We should try to make changes only within the sexp that
+    ;; corresponds to the definition of PACKAGE.
+    (let ((old-hash (bytevector->nix-base32-string old-hash))
+          (hash     (bytevector->nix-base32-string hash)))
+      (substitute file
+                  `((,(regexp-quote old-version)
+                     . ,(cut new-line <> <> version))
+                    (,(regexp-quote old-hash)
+                     . ,(cut new-line <> <> hash))))
+      version))
+
+  (let ((name (package-name package))
+        (loc  (package-field-location package 'version)))
+    (if loc
+        (let ((old-version (package-version package))
+              (old-hash    (origin-sha256 (package-source package)))
+              (file        (and=> (location-file loc)
+                                  (cut search-path %load-path <>))))
+          (if file
+              (update-source file
+                             old-version version
+                             old-hash hash)
+              (begin
+                (warning (_ "~a: could not locate source file")
+                         (location-file loc))
+                #f)))
+        (begin
+          (format (current-error-port)
+                  (_ "~a: ~a: no `version' field in source; skipping~%")
+                  name (package-location package))))))
+
 ;;; gnu-maintenance.scm ends here
diff --git a/guix/gnupg.scm b/guix/gnupg.scm
new file mode 100644
index 0000000000..ee67bea91b
--- /dev/null
+++ b/guix/gnupg.scm
@@ -0,0 +1,152 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2010, 2011, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix gnupg)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 rdelim)
+  #:use-module (srfi srfi-1)
+  #:export (gnupg-verify
+            gnupg-verify*
+            gnupg-status-good-signature?
+            gnupg-status-missing-key?))
+
+;;; Commentary:
+;;;
+;;; GnuPG interface.
+;;;
+;;; Code:
+
+(define %gpg-command "gpg2")
+(define %openpgp-key-server "keys.gnupg.net")
+
+(define (gnupg-verify sig file)
+  "Verify signature SIG for FILE.  Return a status s-exp if GnuPG failed."
+
+  (define (status-line->sexp line)
+    ;; See file `doc/DETAILS' in GnuPG.
+    (define sigid-rx
+      (make-regexp
+       "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
+    (define goodsig-rx
+      (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
+    (define validsig-rx
+      (make-regexp
+       "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
+    (define expkeysig-rx                    ; good signature, but expired key
+      (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
+    (define errsig-rx
+      (make-regexp
+       "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)"))
+
+    (cond ((regexp-exec sigid-rx line)
+           =>
+           (lambda (match)
+             `(signature-id ,(match:substring match 1) ; sig id
+                            ,(match:substring match 2) ; date
+                            ,(string->number           ; timestamp
+                              (match:substring match 3)))))
+          ((regexp-exec goodsig-rx line)
+           =>
+           (lambda (match)
+             `(good-signature ,(match:substring match 1)    ; key id
+                              ,(match:substring match 2)))) ; user name
+          ((regexp-exec validsig-rx line)
+           =>
+           (lambda (match)
+             `(valid-signature ,(match:substring match 1) ; fingerprint
+                               ,(match:substring match 2) ; sig creation date
+                               ,(string->number           ; timestamp
+                                 (match:substring match 3)))))
+          ((regexp-exec expkeysig-rx line)
+           =>
+           (lambda (match)
+             `(expired-key-signature ,(match:substring match 1) ; fingerprint
+                                     ,(match:substring match 2)))) ; user name
+          ((regexp-exec errsig-rx line)
+           =>
+           (lambda (match)
+             `(signature-error ,(match:substring match 1) ; key id or fingerprint
+                               ,(match:substring match 2) ; pubkey algo
+                               ,(match:substring match 3) ; hash algo
+                               ,(match:substring match 4) ; sig class
+                               ,(string->number           ; timestamp
+                                 (match:substring match 5))
+                               ,(let ((rc
+                                       (string->number ; return code
+                                        (match:substring match 6))))
+                                  (case rc
+                                    ((9) 'missing-key)
+                                    ((4) 'unknown-algorithm)
+                                    (else rc))))))
+          (else
+           `(unparsed-line ,line))))
+
+  (define (parse-status input)
+    (let loop ((line   (read-line input))
+               (result '()))
+      (if (eof-object? line)
+          (reverse result)
+          (loop (read-line input)
+                (cons (status-line->sexp line) result)))))
+
+  (let* ((pipe   (open-pipe* OPEN_READ %gpg-command "--status-fd=1"
+                             "--verify" sig file))
+         (status (parse-status pipe)))
+    ;; 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
+a key-id/user pair; return #f otherwise."
+  (any (lambda (sexp)
+         (match sexp
+           (((or 'good-signature 'expired-key-signature) key-id user)
+            (cons key-id user))
+           (_ #f)))
+       status))
+
+(define (gnupg-status-missing-key? status)
+  "If STATUS denotes a missing-key error, then return the key-id of the
+missing key."
+  (any (lambda (sexp)
+         (match sexp
+           (('signature-error key-id _ ...)
+            key-id)
+           (_ #f)))
+       status))
+
+(define (gnupg-receive-keys key-id server)
+  (system* %gpg-command "--keyserver" server "--recv-keys" key-id))
+
+(define* (gnupg-verify* sig file #:optional (server %openpgp-key-server))
+  "Like `gnupg-verify', but try downloading the public key if it's missing.
+Return #t if the signature was good, #f otherwise."
+  (let ((status (gnupg-verify sig file)))
+    (or (gnupg-status-good-signature? status)
+        (let ((missing (gnupg-status-missing-key? status)))
+          (and missing
+               (begin
+                 ;; Download the missing key and try again.
+                 (gnupg-receive-keys missing server)
+                 (gnupg-status-good-signature? (gnupg-verify sig file))))))))
+
+;;; gnupg.scm ends here
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
new file mode 100644
index 0000000000..036da38a3f
--- /dev/null
+++ b/guix/scripts/refresh.scm
@@ -0,0 +1,137 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts refresh)
+  #:use-module (guix ui)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix packages)
+  #:use-module (guix gnu-maintenance)
+  #:use-module (gnu packages)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-37)
+  #:use-module (rnrs io ports)
+  #:export (guix-refresh))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+  ;; Alist of default option values.
+  '())
+
+(define %options
+  ;; Specification of the command-line options.
+  (list (option '(#\n "dry-run") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'dry-run? #t result)))
+
+        (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix refresh")))))
+
+(define (show-help)
+  (display (_ "Usage: guix refresh [OPTION]... PACKAGE...
+Update package definitions to match the latest upstream version.\n"))
+  (display (_ "
+  -n, --dry-run          do not build the derivations"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-refresh . args)
+  (define (parse-options)
+    ;; Return the alist of option values.
+    (args-fold args %options
+               (lambda (opt name arg result)
+                 (leave (_ "~A: unrecognized option~%") name))
+               (lambda (arg result)
+                 (alist-cons 'argument arg result))
+               %default-options))
+
+  (let* ((opts     (parse-options))
+         (dry-run? (assoc-ref opts 'dry-run?))
+         (packages (match (concatenate
+                           (filter-map (match-lambda
+                                        (('argument . value)
+                                         (let ((p (find-packages-by-name value)))
+                                           (unless p
+                                             (leave (_ "~a: no package by that name")
+                                                    value))
+                                           p))
+                                        (_ #f))
+                                       opts))
+                     (()                          ; default to all packages
+                      ;; TODO: Keep only the newest of each package.
+                      (fold-packages cons '()))
+                     (some                        ; user-specified packages
+                      some))))
+   (with-error-handling
+     (if dry-run?
+         (for-each (lambda (package)
+                     (match (false-if-exception (package-update-path package))
+                       ((new-version . directory)
+                        (let ((loc (or (package-field-location package 'version)
+                                       (package-location package))))
+                          (format (current-error-port)
+                                  (_ "~a: ~a would be upgraded from ~a to ~a~%")
+                                  (location->string loc)
+                                  (package-name package) (package-version package)
+                                  new-version)))
+                       (_ #f)))
+                   packages)
+         (let ((store (open-connection)))
+           (for-each (lambda (package)
+                       (let-values (((version tarball)
+                                     (catch #t
+                                       (lambda ()
+                                         (package-update store package))
+                                       (lambda _
+                                         (values #f #f))))
+                                    ((loc)
+                                     (or (package-field-location package
+                                                                 'version)
+                                         (package-location package))))
+                         (when version
+                           (format (current-error-port)
+                                   (_ "~a: ~a: updating from version ~a to version ~a...~%")
+                                   (location->string loc) (package-name package)
+                                   (package-version package) version)
+                           (let ((hash (call-with-input-file tarball
+                                         (compose sha256 get-bytevector-all))))
+                             (update-package-source package version hash)))))
+                     packages))))))
diff --git a/guix/utils.scm b/guix/utils.scm
index 4f399b95c3..3cbed2fd0f 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -60,6 +60,7 @@
             version-compare
             version>?
             package-name->name+version
+            file-extension
             call-with-temporary-output-file
             fold2))
 
@@ -465,6 +466,11 @@ introduce the version part."
       ((head tail ...)
        (loop tail (cons head prefix))))))
 
+(define (file-extension file)
+  "Return the extension of FILE or #f if there is none."
+  (let ((dot (string-rindex file #\.)))
+    (and dot (substring file (+ 1 dot) (string-length file)))))
+
 (define (call-with-temporary-output-file proc)
   "Call PROC with a name of a temporary file and open output port to that
 file; close the file and delete it when leaving the dynamic extent of this

From cac137aa8490e15052c31e7d9b4d1b68c25cd212 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 24 Apr 2013 23:17:31 +0200
Subject: [PATCH 61/74] gnu-maintenance: Optimize `latest-release'.

* guix/gnu-maintenance.scm (tarball-regexp, sans-extension,
  release-file): New procedures.
  (%alpha-tarball-rx): New variable.
  (releases): Use them instead of local copies.
  (latest-release): Rewrite to not do a recursive search of all
  versions and instead jump directly to the latest.
---
 guix/gnu-maintenance.scm | 87 ++++++++++++++++++++++++++--------------
 1 file changed, 58 insertions(+), 29 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 619cb3106a..49b10565db 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -252,30 +252,34 @@ stored."
     (_
      (values "ftp.gnu.org" (string-append "/gnu/" project)))))
 
+(define tarball-regexp
+  (memoize
+   (lambda (project)
+     "Return a regexp matching tarball names for PROJECT."
+     (make-regexp (string-append "^" project
+                                 "-([0-9]|[^-])*(-src)?\\.tar\\.")))))
+
+(define %alpha-tarball-rx
+  (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
+
+(define (sans-extension tarball)
+  "Return TARBALL without its .tar.* extension."
+  (let ((end (string-contains tarball ".tar")))
+    (substring tarball 0 end)))
+
+(define (release-file project file)
+  "Return #f if FILE is not a release tarball of PROJECT, otherwise return
+PACKAGE-VERSION."
+  (and (not (string-suffix? ".sig" file))
+       (regexp-exec (tarball-regexp project) file)
+       (not (regexp-exec %alpha-tarball-rx file))
+       (let ((s (sans-extension file)))
+         (and (regexp-exec %package-name-rx s) s))))
+
 (define (releases project)
   "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]|[^-])*(-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)))
-
-  (define (release-file file)
-    ;; Return #f if FILE is not a release tarball, otherwise return
-    ;; PACKAGE-VERSION.
-    (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) s))))
-
   (let-values (((server directory) (ftp-server/directory project)))
     (define conn (ftp-open server))
 
@@ -301,7 +305,7 @@ pairs.  Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
                   ;; guile-www; in mit-scheme, filter out binaries.
                   (filter-map (match-lambda
                                 ((file 'file . _)
-                                 (and=> (release-file file)
+                                 (and=> (release-file project file)
                                         (cut cons <> directory)))
                                 (_ #f))
                               files)
@@ -309,14 +313,39 @@ pairs.  Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
 
 (define (latest-release project)
   "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f."
-  (let ((releases (releases project)))
-    (and (not (null? releases))
-         (fold (lambda (release latest)
-                 (if (version>? (car release) (car latest))
-                     release
-                     latest))
-               '("" . "")
-               releases))))
+  (define (latest a b)
+    (if (version>? a b) a b))
+
+  (define contains-digit?
+    (cut string-any char-set:digit <>))
+
+  (let-values (((server directory) (ftp-server/directory project)))
+    (define conn (ftp-open server))
+
+    (let loop ((directory directory))
+      (let* ((entries (ftp-list conn directory))
+             (subdirs (filter-map (match-lambda
+                                   ((dir 'directory . _) dir)
+                                   (_ #f))
+                                  entries)))
+        (match subdirs
+          (()
+           ;; No sub-directories, so assume that tarballs are here.
+           (let ((files (filter-map (match-lambda
+                                     ((file 'file . _)
+                                      (release-file project file))
+                                     (_ #f))
+                                    entries)))
+             (and=> (reduce latest #f files)
+                    (cut cons <> directory))))
+          ((subdirs ...)
+           ;; Assume that SUBDIRS correspond to versions, and jump into the
+           ;; one with the highest version number.  Filter out sub-directories
+           ;; that do not contain digits---e.g., /gnuzilla/lang.
+           (let* ((subdirs (filter contains-digit? subdirs))
+                  (target  (reduce latest #f subdirs)))
+             (and target
+                  (loop (string-append directory "/" target))))))))))
 
 (define %package-name-rx
   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses

From d55a99fed30b2ee47725f07bf26208fb4b13a110 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 24 Apr 2013 23:37:14 +0200
Subject: [PATCH 62/74] gnu-maintenance: Optimize `release-file'.

* guix/gnu-maintenance.scm (tarball-regexp): Remove.
  (%tarball-rx): New variable.
  (release-file): Adjust to use %TARBALL-RX.
---
 guix/gnu-maintenance.scm | 21 ++++++++++-----------
 1 file changed, 10 insertions(+), 11 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 49b10565db..30c45ec0c6 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -252,26 +252,25 @@ stored."
     (_
      (values "ftp.gnu.org" (string-append "/gnu/" project)))))
 
-(define tarball-regexp
-  (memoize
-   (lambda (project)
-     "Return a regexp matching tarball names for PROJECT."
-     (make-regexp (string-append "^" project
-                                 "-([0-9]|[^-])*(-src)?\\.tar\\.")))))
-
-(define %alpha-tarball-rx
-  (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
-
 (define (sans-extension tarball)
   "Return TARBALL without its .tar.* extension."
   (let ((end (string-contains tarball ".tar")))
     (substring tarball 0 end)))
 
+(define %tarball-rx
+  (make-regexp "^(.+)-([0-9]|[^-])*(-src)?\\.tar\\."))
+
+(define %alpha-tarball-rx
+  (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
+
 (define (release-file project file)
   "Return #f if FILE is not a release tarball of PROJECT, otherwise return
 PACKAGE-VERSION."
   (and (not (string-suffix? ".sig" file))
-       (regexp-exec (tarball-regexp project) file)
+       (and=> (regexp-exec %tarball-rx file)
+              (lambda (match)
+                ;; Filter out unrelated files, like `guile-www-1.1.1'.
+                (equal? project (match:substring match 1))))
        (not (regexp-exec %alpha-tarball-rx file))
        (let ((s (sans-extension file)))
          (and (regexp-exec %package-name-rx s) s))))

From 65b96a0c10abf88dbdf1668e15d5af0120dc92f7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 24 Apr 2013 23:49:05 +0200
Subject: [PATCH 63/74] gnu-maintenance: Optimize `gnu-package?'.

* guix/gnu-maintenance.scm (gnu-package?): Capture a memoizing version
  of `gnu-package?'.
---
 guix/gnu-maintenance.scm | 19 ++++++++++---------
 1 file changed, 10 insertions(+), 9 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 30c45ec0c6..36aad7a987 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -210,16 +210,17 @@
 
 (define gnu-package?
   (memoize
-   (lambda (package)
-     "Return true if PACKAGE is a GNU package.  This procedure may access the
+   (let ((official-gnu-packages (memoize official-gnu-packages)))
+     (lambda (package)
+       "Return true if PACKAGE is a GNU package.  This procedure may access the
 network to check in GNU's database."
-     ;; TODO: Find a way to determine that a package is non-GNU without going
-     ;; through the network.
-     (let ((url  (and=> (package-source package) origin-uri))
-           (name (package-name package)))
-       (or (and (string? url) (string-prefix? "mirror://gnu" url))
-           (and (member name (map gnu-package-name (official-gnu-packages)))
-                #t))))))
+       ;; TODO: Find a way to determine that a package is non-GNU without going
+       ;; through the network.
+       (let ((url  (and=> (package-source package) origin-uri))
+             (name (package-name package)))
+         (or (and (string? url) (string-prefix? "mirror://gnu" url))
+             (and (member name (map gnu-package-name (official-gnu-packages)))
+                  #t)))))))
 
 
 ;;;

From 825d0ebc5bce008c58e9525eda071cd1880ffb0c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 25 Apr 2013 00:06:19 +0200
Subject: [PATCH 64/74] gnu: libtasn1: Update to 3.3.

* gnu/packages/gnutls.scm (libtasn1): Update to 3.3.
---
 gnu/packages/gnutls.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/gnutls.scm b/gnu/packages/gnutls.scm
index e817198db3..77eb30c3dd 100644
--- a/gnu/packages/gnutls.scm
+++ b/gnu/packages/gnutls.scm
@@ -31,7 +31,7 @@
 (define-public libtasn1
   (package
     (name "libtasn1")
-    (version "3.2")
+    (version "3.3")
     (source
      (origin
       (method url-fetch)
@@ -39,7 +39,7 @@
                           version ".tar.gz"))
       (sha256
        (base32
-        "0gvgndypwicchf7m660zh7jdgmkfj9g9xavpcc08pyd0120y0bk7"))))
+        "1h1sz5py8zlg4yczybr6wa925pyadvjcxrdmhilwaqqgs4n2lrcj"))))
     (build-system gnu-build-system)
     (home-page "http://www.gnu.org/software/libtasn1/")
     (synopsis "ASN.1 library")

From f6f207b80317634cf832b229160e9036dd75be1b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 25 Apr 2013 00:06:39 +0200
Subject: [PATCH 65/74] gnu: nettle: Update to 2.7.

* gnu/packages/nettle.scm (nettle): Update to 2.7.
---
 gnu/packages/nettle.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/nettle.scm b/gnu/packages/nettle.scm
index 3ea4eb79e1..e4dbadecce 100644
--- a/gnu/packages/nettle.scm
+++ b/gnu/packages/nettle.scm
@@ -27,14 +27,14 @@
 (define-public nettle
   (package
     (name "nettle")
-    (version "2.6")
+    (version "2.7")
     (source (origin
              (method url-fetch)
              (uri (string-append "mirror://gnu/nettle/nettle-"
                                  version ".tar.gz"))
              (sha256
               (base32
-               "0mminj3fg0vba8qx4q6dbf0xz6fskamli7z2r8rci5xrcd7n5pv0"))))
+               "1mnl5i1136p47lrklm0mhnnv3gjakza385zvxz12qf057h9ym562"))))
     (build-system gnu-build-system)
     (inputs `(("m4" ,m4)))
     (propagated-inputs `(("gmp" ,gmp)))

From 9e623d068dc5ed9c9e0ac5bdf2dce1d6b78ed6ac Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 25 Apr 2013 00:10:15 +0200
Subject: [PATCH 66/74] gnu: wdiff: Update to 1.2.1.

* gnu/packages/wdiff.scm (wdiff): Update to 1.2.1.  Add Texinfo as an input.
---
 gnu/packages/wdiff.scm | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

diff --git a/gnu/packages/wdiff.scm b/gnu/packages/wdiff.scm
index b9fccb97db..6aa6b2a67a 100644
--- a/gnu/packages/wdiff.scm
+++ b/gnu/packages/wdiff.scm
@@ -21,13 +21,14 @@
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix build-system gnu)
+  #:use-module (gnu packages texinfo)
   #:use-module (gnu packages screen)
   #:use-module (gnu packages which))
 
 (define-public wdiff
   (package
     (name "wdiff")
-    (version "1.1.2")
+    (version "1.2.1")
     (source
      (origin
       (method url-fetch)
@@ -35,7 +36,7 @@
                           version ".tar.gz"))
       (sha256
        (base32
-        "0q78y5awvjjmsvizqilbpwany62shlmlq2ayxkjbygmdafpk1k8j"))))
+        "1gb5hpiyikada9bwz63q3g96zs383iskiir0xsqynqnvq1vd4n41"))))
     (build-system gnu-build-system)
     (arguments
      `(#:phases (alist-cons-before
@@ -46,7 +47,10 @@
                       (string-append "#!" (which "sh")))))
                  %standard-phases)))
     (inputs `(("screen" ,screen)
-              ("which" ,which)))
+              ("which" ,which)
+
+              ;; For some reason wdiff.info gets rebuilt.
+              ("texinfo" ,texinfo)))
     (home-page "https://www.gnu.org/software/wdiff/")
     (synopsis "Word difference finder")
     (description

From 1c9e7d65d4ca8674e674b339740f575f8edb5db2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 25 Apr 2013 22:06:48 +0200
Subject: [PATCH 67/74] web: Factorize `http-get' hackery.

This should fix `substitute-binary --query' on Guile 2.0.5.

* guix/web.scm: New file.
* Makefile.am (MODULES): Add it.
* po/POTFILES.in: Add it.
* guix/gnu-maintenance.scm (http-fetch): Remove.
  (%package-list-url): Turn into a URI.
  (official-gnu-packages): Add #:text? #t to `http-fetch' call.
* guix/scripts/substitute-binary.scm (fetch): Remove `http' case, and
  use `http-fetch' instead.
---
 Makefile.am                        |  1 +
 guix/gnu-maintenance.scm           | 45 +++-------------
 guix/scripts/substitute-binary.scm | 26 +--------
 guix/web.scm                       | 85 ++++++++++++++++++++++++++++++
 po/POTFILES.in                     |  1 +
 5 files changed, 95 insertions(+), 63 deletions(-)
 create mode 100644 guix/web.scm

diff --git a/Makefile.am b/Makefile.am
index 442e53e7f6..907be9e141 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -48,6 +48,7 @@ MODULES =					\
   guix/build-system/perl.scm			\
   guix/build-system/trivial.scm			\
   guix/ftp-client.scm				\
+  guix/web.scm					\
   guix/gnupg.scm				\
   guix/store.scm				\
   guix/ui.scm					\
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 36aad7a987..4c7241fc88 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -28,6 +28,7 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (system foreign)
+  #:use-module (guix web)
   #:use-module (guix ftp-client)
   #:use-module (guix ui)
   #:use-module (guix utils)
@@ -73,45 +74,11 @@
 ;;; List of GNU packages.
 ;;;
 
-(define (http-fetch uri)
-  "Return an input port containing the textual data at URI, a string."
-  (let*-values (((resp data)
-                 (let ((uri (string->uri uri)))
-                   ;; Try hard to use the API du jour to get an input port.
-                   (if (version>? "2.0.7" (version))
-                       (if (defined? 'http-get*)
-                           (http-get* uri)
-                           (http-get uri))       ; old Guile, returns a string
-                       (http-get uri #:streaming? #t)))) ; 2.0.8 or later
-               ((code)
-                (response-code resp)))
-    (case code
-      ((200)
-       (cond ((not data)
-              (begin
-                ;; XXX: Guile 2.0.5 and earlier did not support chunked transfer
-                ;; encoding, which is required when fetching %PACKAGE-LIST-URL
-                ;; (see <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
-                ;; Since users may still be using these versions, warn them and
-                ;; bail out.
-                (warning (_ "using Guile ~a, ~a ~s encoding~%")
-                         (version)
-                         "which does not support HTTP"
-                         (response-transfer-encoding resp))
-                (leave (_ "download failed; use a newer Guile~%")
-                       uri resp)))
-             ((string? data)                 ; old `http-get' returns a string
-              (open-input-string data))
-             (else                           ; input port
-              data)))
-      (else
-       (error "download failed" uri code
-              (response-reason-phrase resp))))))
-
 (define %package-list-url
-  (string-append "http://cvs.savannah.gnu.org/"
-                 "viewvc/*checkout*/gnumaint/"
-                 "gnupackages.txt?root=womb"))
+  (string->uri
+   (string-append "http://cvs.savannah.gnu.org/"
+                  "viewvc/*checkout*/gnumaint/"
+                  "gnupackages.txt?root=womb")))
 
 (define-record-type* <gnu-package-descriptor>
   gnu-package-descriptor
@@ -197,7 +164,7 @@
                                "savannah" "fsd" "language" "logo"
                                "doc-category" "doc-summary" "doc-urls"
                                "download-url")))
-        (group-package-fields (http-fetch %package-list-url)
+        (group-package-fields (http-fetch %package-list-url #:text? #t)
                               '(())))))
 
 (define (find-packages regexp)
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 7e059be596..87561db4b3 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -35,8 +35,7 @@
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (web uri)
-  #:use-module (web client)
-  #:use-module (web response)
+  #:use-module (guix web)
   #:export (guix-substitute-binary))
 
 ;;; Comment:
@@ -128,28 +127,7 @@ provide."
      (let ((port (open-input-file (uri-path uri))))
        (values port (stat:size (stat port)))))
     ((http)
-     (let*-values (((resp port)
-                    ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated
-                    ;; in 2.0.8 (!).  Assume it is available here.
-                    (if (version>? "2.0.7" (version))
-                        (http-get* uri #:decode-body? #f)
-                        (http-get uri #:streaming? #t)))
-                   ((code)
-                    (response-code resp))
-                   ((size)
-                    (response-content-length resp)))
-       (case code
-         ((200)                                   ; OK
-          (values port size))
-         ((301                                    ; moved permanently
-           302)                                   ; found (redirection)
-          (let ((uri (response-location resp)))
-            (format #t "following redirection to `~a'...~%"
-                    (uri->string uri))
-            (fetch uri)))
-         (else
-          (error "download failed" (uri->string uri)
-                 code (response-reason-phrase resp))))))))
+     (http-fetch uri #:text? #f))))
 
 (define-record-type <cache>
   (%make-cache url store-directory wants-mass-query?)
diff --git a/guix/web.scm b/guix/web.scm
new file mode 100644
index 0000000000..9d0ee40624
--- /dev/null
+++ b/guix/web.scm
@@ -0,0 +1,85 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix web)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (srfi srfi-11)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs bytevectors)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:export (http-fetch))
+
+;;; Commentary:
+;;;
+;;; Web client portable among Guile versions.
+;;;
+;;; Code:
+
+(define* (http-fetch uri #:key (text? #f))
+  "Return an input port containing the data at URI, and the expected number of
+bytes available or #f.  If TEXT? is true, the data at URI is considered to be
+textual.  Follow any HTTP redirection."
+  (let loop ((uri uri))
+    (let*-values (((resp data)
+                   ;; Try hard to use the API du jour to get an input port.
+                   ;; On Guile 2.0.5 and before, we can only get a string or
+                   ;; bytevector, and not an input port.  Work around that.
+                   (if (version>? "2.0.7" (version))
+                       (if (defined? 'http-get*)
+                           (http-get* uri #:decode-body? text?) ; 2.0.7
+                           (http-get uri #:decode-body? text?)) ; 2.0.5-
+                       (http-get uri #:streaming? #t)))         ; 2.0.9+
+                  ((code)
+                   (response-code resp)))
+      (case code
+        ((200)
+         (let ((len (response-content-length resp)))
+           (cond ((not data)
+                  (begin
+                    ;; XXX: Guile 2.0.5 and earlier did not support chunked
+                    ;; transfer encoding, which is required for instance when
+                    ;; fetching %PACKAGE-LIST-URL (see
+                    ;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
+                    ;; Since users may still be using these versions, warn them
+                    ;; and bail out.
+                    (warning (_ "using Guile ~a, ~a ~s encoding~%")
+                             (version)
+                             "which does not support HTTP"
+                             (response-transfer-encoding resp))
+                    (leave (_ "download failed; use a newer Guile~%")
+                           uri resp)))
+                 ((string? data)                   ; `http-get' from 2.0.5-
+                  (values (open-input-string data) len))
+                 ((bytevector? data)               ; likewise
+                  (values (open-bytevector-input-port data) len))
+                 (else                             ; input port
+                  (values data len)))))
+        ((301                                      ; moved permanently
+          302)                                     ; found (redirection)
+         (let ((uri (response-location resp)))
+           (format #t "following redirection to `~a'...~%"
+                   (uri->string uri))
+           (loop uri)))
+        (else
+         (error "download failed" uri code
+                (response-reason-phrase resp)))))))
+
+;;; web.scm ends here
diff --git a/po/POTFILES.in b/po/POTFILES.in
index 3b01e2a2a5..6e1ba82951 100644
--- a/po/POTFILES.in
+++ b/po/POTFILES.in
@@ -12,3 +12,4 @@ guix/scripts/hash.scm
 guix/scripts/pull.scm
 guix/gnu-maintenance.scm
 guix/ui.scm
+guix/web.scm

From 37a5340262fd916b2c7b8d175282987a6d4449bb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 25 Apr 2013 22:56:25 +0200
Subject: [PATCH 68/74] refresh: Add `--select'.

* guix/scripts/refresh.scm (%options): Add `--select'.
  (show-help): Likewise.  Augment initial help text.
  (guix-refresh)[core-package?]: New procedure.
  Use it when selecting packages.
---
 guix/scripts/refresh.scm | 119 +++++++++++++++++++++++++++------------
 1 file changed, 82 insertions(+), 37 deletions(-)

diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 036da38a3f..da318b07ad 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -23,6 +23,7 @@
   #:use-module (guix packages)
   #:use-module (guix gnu-maintenance)
   #:use-module (gnu packages)
+  #:use-module ((gnu packages base) #:select (%final-inputs))
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
@@ -46,6 +47,15 @@
   (list (option '(#\n "dry-run") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'dry-run? #t result)))
+        (option '(#\s "select") #t #f
+                (lambda (opt name arg result)
+                  (match arg
+                    ((or "core" "non-core")
+                     (alist-cons 'select (string->symbol arg)
+                                 result))
+                    (x
+                     (leave (_ "~a: invalid selection; expected `core' or `non-core'")
+                            arg)))))
 
         (option '(#\h "help") #f #f
                 (lambda args
@@ -57,9 +67,16 @@
 
 (define (show-help)
   (display (_ "Usage: guix refresh [OPTION]... PACKAGE...
-Update package definitions to match the latest upstream version.\n"))
+Update package definitions to match the latest upstream version.
+
+When PACKAGE... is given, update only the specified packages.  Otherwise
+update all the packages of the distribution, or the subset thereof
+specified with `--select'.\n"))
   (display (_ "
   -n, --dry-run          do not build the derivations"))
+  (display (_ "
+  -s, --select=SUBSET    select all the packages in SUBSET, one of
+                         `core' or `non-core'"))
   (newline)
   (display (_ "
   -h, --help             display this help and exit"))
@@ -83,6 +100,26 @@ Update package definitions to match the latest upstream version.\n"))
                  (alist-cons 'argument arg result))
                %default-options))
 
+  (define core-package?
+    (let* ((input->package (match-lambda
+                            ((name (? package? package) _ ...) package)
+                            (_ #f)))
+           (final-inputs   (map input->package %final-inputs))
+           (core           (append final-inputs
+                                   (append-map (compose (cut filter-map input->package <>)
+                                                        package-transitive-inputs)
+                                               final-inputs)))
+           (names          (delete-duplicates (map package-name core))))
+      (lambda (package)
+        "Return true if PACKAGE is likely a \"core package\"---i.e., one whose
+update would trigger a complete rebuild."
+        ;; Compare by name because packages in base.scm basically inherit
+        ;; other packages.  So, even if those packages are not core packages
+        ;; themselves, updating them would also update those who inherit from
+        ;; them.
+        ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input.
+        (member (package-name package) names))))
+
   (let* ((opts     (parse-options))
          (dry-run? (assoc-ref opts 'dry-run?))
          (packages (match (concatenate
@@ -96,42 +133,50 @@ Update package definitions to match the latest upstream version.\n"))
                                         (_ #f))
                                        opts))
                      (()                          ; default to all packages
-                      ;; TODO: Keep only the newest of each package.
-                      (fold-packages cons '()))
+                      (let ((select? (match (assoc-ref opts 'select)
+                                       ('core core-package?)
+                                       ('non-core (negate core-package?))
+                                       (_ (const #t)))))
+                        ;; TODO: Keep only the newest of each package.
+                        (fold-packages (lambda (package result)
+                                         (if (select? package)
+                                             (cons package result)
+                                             result))
+                                       '())))
                      (some                        ; user-specified packages
                       some))))
-   (with-error-handling
-     (if dry-run?
-         (for-each (lambda (package)
-                     (match (false-if-exception (package-update-path package))
-                       ((new-version . directory)
-                        (let ((loc (or (package-field-location package 'version)
-                                       (package-location package))))
-                          (format (current-error-port)
-                                  (_ "~a: ~a would be upgraded from ~a to ~a~%")
-                                  (location->string loc)
-                                  (package-name package) (package-version package)
-                                  new-version)))
-                       (_ #f)))
-                   packages)
-         (let ((store (open-connection)))
-           (for-each (lambda (package)
-                       (let-values (((version tarball)
-                                     (catch #t
-                                       (lambda ()
-                                         (package-update store package))
-                                       (lambda _
-                                         (values #f #f))))
-                                    ((loc)
-                                     (or (package-field-location package
-                                                                 'version)
-                                         (package-location package))))
-                         (when version
+    (with-error-handling
+      (if dry-run?
+          (for-each (lambda (package)
+                      (match (false-if-exception (package-update-path package))
+                        ((new-version . directory)
+                         (let ((loc (or (package-field-location package 'version)
+                                        (package-location package))))
                            (format (current-error-port)
-                                   (_ "~a: ~a: updating from version ~a to version ~a...~%")
-                                   (location->string loc) (package-name package)
-                                   (package-version package) version)
-                           (let ((hash (call-with-input-file tarball
-                                         (compose sha256 get-bytevector-all))))
-                             (update-package-source package version hash)))))
-                     packages))))))
+                                   (_ "~a: ~a would be upgraded from ~a to ~a~%")
+                                   (location->string loc)
+                                   (package-name package) (package-version package)
+                                   new-version)))
+                        (_ #f)))
+                    packages)
+          (let ((store (open-connection)))
+            (for-each (lambda (package)
+                        (let-values (((version tarball)
+                                      (catch #t
+                                        (lambda ()
+                                          (package-update store package))
+                                        (lambda _
+                                          (values #f #f))))
+                                     ((loc)
+                                      (or (package-field-location package
+                                                                  'version)
+                                          (package-location package))))
+                          (when version
+                            (format (current-error-port)
+                                    (_ "~a: ~a: updating from version ~a to version ~a...~%")
+                                    (location->string loc) (package-name package)
+                                    (package-version package) version)
+                            (let ((hash (call-with-input-file tarball
+                                          (compose sha256 get-bytevector-all))))
+                              (update-package-source package version hash)))))
+                      packages))))))

From 43d8f4904c8dbd4d28017ce63b929ebb27a897d6 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 25 Apr 2013 23:01:05 +0200
Subject: [PATCH 69/74] doc: Add note on installing Guix from Guix.

* README (Installing Guix from Guix): New section.
  Suggested by Alex Sassmannshausen <alex.sassmannshausen@gmail.com>.
---
 README | 10 ++++++++++
 1 file changed, 10 insertions(+)

diff --git a/README b/README
index 09433586be..98e38b4f24 100644
--- a/README
+++ b/README
@@ -51,6 +51,16 @@ The "autoreconf -vi" command can be used to generate the build system
 infrastructure; it reports an error if an inappropriate version of the
 above packages is being used.
 
+* Installing Guix from Guix
+
+You can re-build and re-install Guix using a system that already runs Guix.
+To do so:
+
+  - install the dependencies (see 'Requirements' above) using Guix
+  - re-run the configure script passing it the option
+    `--with-libgcrypt-prefix=$HOME/.guix-profile/'
+  - run "make" and "make install"
+
 * How It Works
 
 Guix does the high-level preparation of a /derivation/.  A derivation is

From dfb43e45b5d5a421be21422f825ae48cd44c1188 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 25 Apr 2013 23:07:24 +0200
Subject: [PATCH 70/74] gnu-maintenance: Add newline in warning messages.

* guix/gnu-maintenance.scm (download-tarball): Add newline in warning
  messages.
---
 guix/gnu-maintenance.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 4c7241fc88..be739e34a3 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -356,9 +356,9 @@ success, return the tarball file name."
       (if ret
           tarball
           (begin
-            (warning (_ "signature verification failed for `~a'")
+            (warning (_ "signature verification failed for `~a'~%")
                      base)
-            (warning (_ "(could be because the public key is not in your keyring)"))
+            (warning (_ "(could be because the public key is not in your keyring)~%"))
             #f)))))
 
 (define (package-update store package)

From 6c211361fecc1979b71043155fe826fda0d71f93 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 25 Apr 2013 23:07:59 +0200
Subject: [PATCH 71/74] gnu: ed: Update to 1.8.

* gnu/packages/ed.scm (ed): Update to 1.8.
---
 gnu/packages/ed.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/ed.scm b/gnu/packages/ed.scm
index 0f387be797..e9ded33dd8 100644
--- a/gnu/packages/ed.scm
+++ b/gnu/packages/ed.scm
@@ -26,14 +26,14 @@
 (define-public ed
   (package
     (name "ed")
-    (version "1.6")
+    (version "1.8")
     (source (origin
              (method url-fetch)
              (uri (string-append "mirror://gnu/ed/ed-"
                                  version ".tar.gz"))
              (sha256
               (base32
-               "0rcay0wci2kiwil2h505b674cblmn4nq8pqw9g9pgqmaqjq6f711"))))
+               "0wvj190ky5i0gm0pilx9k75l6alyc6h5s14fm3dbk90y7g9kihb4"))))
     (build-system gnu-build-system)
     (arguments
      '(#:configure-flags '("CC=gcc")

From acfc0df5cee7a05b8bfc64282d64000481421b13 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 25 Apr 2013 23:18:20 +0200
Subject: [PATCH 72/74] gnu: nano: Update to 2.3.2.

* gnu/packages/nano.scm (nano): Update to 2.3.2.
---
 gnu/packages/nano.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/nano.scm b/gnu/packages/nano.scm
index f80400d88b..6ded15df2a 100644
--- a/gnu/packages/nano.scm
+++ b/gnu/packages/nano.scm
@@ -28,7 +28,7 @@
 (define-public nano
   (package
     (name "nano")
-    (version "2.2.6")
+    (version "2.3.2")
     (source
      (origin
       (method url-fetch)
@@ -36,7 +36,7 @@
                           version ".tar.gz"))
       (sha256
        (base32
-        "0yp6pid67k8h7394spzw0067fl2r7rxm2b6kfccg87g8nlry2s5y"))))
+        "1s3b21h5p7r8xafw0gahswj16ai6k2vnjhmd15b491hl0x494c7z"))))
     (build-system gnu-build-system)
     (inputs
      `(("gettext" ,guix:gettext)

From 777fabf096fff03eb4886f1e9ef7d02d9a4c65b1 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 25 Apr 2013 23:19:52 +0200
Subject: [PATCH 73/74] gnu: dejagnu: Update to 1.5.1.

* gnu/packages/dejagnu.scm (dejagnu): Update to 1.5.1.
---
 gnu/packages/dejagnu.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/dejagnu.scm b/gnu/packages/dejagnu.scm
index 999d976ec7..3318c81726 100644
--- a/gnu/packages/dejagnu.scm
+++ b/gnu/packages/dejagnu.scm
@@ -26,7 +26,7 @@
 (define-public dejagnu
   (package
     (name "dejagnu")
-    (version "1.5")
+    (version "1.5.1")
     (source
      (origin
       (method url-fetch)
@@ -34,7 +34,7 @@
                           version ".tar.gz"))
       (sha256
        (base32
-        "1nx3x3h96a82q92q108q71giv2nz9xmbbn2nrlr3wvvs6l45id68"))))
+        "1lik8h4qi7x0mhsi8xmj91an1yb63rjbk6v4xrmzgiy5lk8lgrv0"))))
     (build-system gnu-build-system)
     (inputs `(("expect" ,expect)))
     (arguments

From 2b6bdf7eb3c95716ac107ea6caea2e0b7077ae77 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 25 Apr 2013 23:21:49 +0200
Subject: [PATCH 74/74] gnu: libgcrypt: Update to 1.5.2.

* gnu/packages/gnupg.scm (libgcrypt): Update to 1.5.2.
---
 gnu/packages/gnupg.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm
index f96071e072..2a610af2ed 100644
--- a/gnu/packages/gnupg.scm
+++ b/gnu/packages/gnupg.scm
@@ -57,14 +57,14 @@ Daemon and possibly more in the future.")
 (define-public libgcrypt
   (package
     (name "libgcrypt")
-    (version "1.5.1")
+    (version "1.5.2")
     (source (origin
              (method url-fetch)
              (uri (string-append "mirror://gnupg/libgcrypt/libgcrypt-"
                                  version ".tar.bz2"))
              (sha256
               (base32
-               "09z5zbxhvg6c7n8qcm8h9ygr28qli2n83hfq1f69jsg711cb37md"))))
+               "0gwnzqd64cpwdmk93nll54nidsr74jpimxzj4p4z7502ylwl66p4"))))
     (build-system gnu-build-system)
     (propagated-inputs
      `(("libgpg-error" ,libgpg-error)))