Merge branch 'master' into gtk-rebuild

Conflicts:
	gnu/packages/gtk.scm

12 files changed, 991 insertions, 401 deletions

diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm
index e9900689fa..eedebb4bac 100644
--- a/guix/scripts/authenticate.scm
+++ b/guix/scripts/authenticate.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -82,12 +82,6 @@ to stdout upon success."
         (leave (_ "error: corrupt signature data: ~a~%")
                (canonical-sexp->string signature)))))
 
-(define %default-port-conversion-strategy
-  ;; This fluid is in Guile > 2.0.5.
-  (if (defined? '%default-port-conversion-strategy)
-      (@ (guile) %default-port-conversion-strategy)
-      (make-fluid #f)))
-
 
 ;;;
 ;;; Entry point with 'openssl'-compatible interface.  We support this
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 370c2a37ff..2307f76b42 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -37,6 +37,7 @@
   #:autoload   (guix download) (download-to-store)
   #:export (%standard-build-options
             set-build-options-from-command-line
+            set-build-options-from-command-line*
             show-build-options-help
 
             guix-build))
@@ -139,6 +140,9 @@ options handled by 'set-build-options-from-command-line', and listed in
                      #:print-build-trace (assoc-ref opts 'print-build-trace?)
                      #:verbosity (assoc-ref opts 'verbosity)))
 
+(define set-build-options-from-command-line*
+  (store-lift set-build-options-from-command-line))
+
 (define %standard-build-options
   ;; List of standard command-line options for tools that build something.
   (list (option '(#\L "load-path") #t #f
@@ -228,6 +232,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
   (display (_ "
   -S, --source           build the packages' source derivations"))
   (display (_ "
+      --sources[=TYPE]   build source derivations; TYPE may optionally be one
+                         of \"package\", \"all\" (default), or \"transitive\""))
+  (display (_ "
   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
   (display (_ "
       --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
@@ -262,10 +269,22 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
          (option '(#\V "version") #f #f
                  (lambda args
                    (show-version-and-exit "guix build")))
-
          (option '(#\S "source") #f #f
                  (lambda (opt name arg result)
-                   (alist-cons 'source? #t result)))
+                   (alist-cons 'source #t result)))
+         (option '("sources") #f #t
+                 (lambda (opt name arg result)
+                   (match arg
+                     ("package"
+                      (alist-cons 'source #t result))
+                     ((or "all" #f)
+                      (alist-cons 'source package-direct-sources result))
+                     ("transitive"
+                      (alist-cons 'source package-transitive-sources result))
+                     (else
+                      (leave (_ "invalid argument: '~a' option argument: ~a, ~
+must be one of 'package', 'all', or 'transitive'~%")
+                             name arg)))))
          (option '(#\s "system") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
@@ -308,28 +327,34 @@ build."
       (triplet
        (cut package-cross-derivation <> <> triplet <>))))
 
-  (define src?   (assoc-ref opts 'source?))
+  (define src    (assoc-ref opts 'source))
   (define sys    (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
 
   (parameterize ((%graft? graft?))
     (let ((opts (options/with-source store
                                      (options/resolve-packages store opts))))
-      (filter-map (match-lambda
-                   (('argument . (? package? p))
-                    (if src?
+      (concatenate
+       (filter-map (match-lambda
+                    (('argument . (? package? p))
+                     (match src
+                       (#f
+                        (list (package->derivation store p sys)))
+                       (#t
                         (let ((s (package-source p)))
-                          (package-source-derivation store s))
-                        (package->derivation store p sys)))
-                   (('argument . (? derivation? drv))
-                    drv)
-                   (('argument . (? derivation-path? drv))
-                    (call-with-input-file drv read-derivation))
-                   (('argument . (? store-path?))
-                    ;; Nothing to do; maybe for --log-file.
-                    #f)
-                   (_ #f))
-                  opts))))
+                          (list (package-source-derivation store s))))
+                       (proc
+                        (map (cut package-source-derivation store <>)
+                             (proc p)))))
+                    (('argument . (? derivation? drv))
+                     (list drv))
+                    (('argument . (? derivation-path? drv))
+                     (list (call-with-input-file drv read-derivation)))
+                    (('argument . (? store-path?))
+                     ;; Nothing to do; maybe for --log-file.
+                     #f)
+                    (_ #f))
+                   opts)))))
 
 (define (options/resolve-packages store opts)
   "Return OPTS with package specification strings replaced by actual
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 80ae924410..d053daf02e 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
+;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,9 +23,9 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix profiles)
+  #:use-module (guix search-paths)
   #:use-module (guix utils)
   #:use-module (guix monads)
-  #:use-module (guix build utils)
   #:use-module (guix scripts build)
   #:use-module (gnu packages)
   #:use-module (ice-9 format)
@@ -35,32 +36,20 @@
   #:use-module (srfi srfi-98)
   #:export (guix-environment))
 
-(define (for-each-search-path proc inputs derivations pure?)
-  "Apply PROC for each native search path in INPUTS in addition to 'PATH'.
-Use the output paths of DERIVATIONS to build each search path.  When PURE? is
-#t, the existing search path value is ignored.  Otherwise, the existing search
-path value is appended."
-  (let ((paths (append-map (lambda (drv)
-                             (map (match-lambda
-                                   ((_ . output)
-                                    (derivation-output-path output)))
-                                  (derivation-outputs drv)))
-                           derivations)))
-    (for-each (match-lambda
-               (($ <search-path-specification>
-                   variable directories separator)
-                (let* ((current (getenv variable))
-                       (path    (search-path-as-list directories paths))
-                       (value   (list->search-path-as-string path separator)))
-                  (proc variable
-                        (if (and current (not pure?))
-                            (string-append value separator current)
-                            value)))))
-              (cons* (search-path-specification
-                      (variable "PATH")
-                      (files '("bin" "sbin")))
-                     (delete-duplicates
-                      (append-map package-native-search-paths inputs))))))
+(define (evaluate-input-search-paths inputs derivations)
+  "Evaluate the native search paths of INPUTS, a list of packages, of the
+outputs of DERIVATIONS, and return a list of search-path/value pairs."
+  (let ((directories (append-map (lambda (drv)
+                                   (map (match-lambda
+                                          ((_ . output)
+                                           (derivation-output-path output)))
+                                        (derivation-outputs drv)))
+                                 derivations))
+        (paths       (cons $PATH
+                           (delete-duplicates
+                            (append-map package-native-search-paths
+                                        inputs)))))
+    (evaluate-search-paths paths directories)))
 
 ;; Protect some env vars from purification.  Borrowed from nix-shell.
 (define %precious-variables
@@ -80,15 +69,26 @@ as 'HOME' and 'USER' are left untouched."
 PURE? is #t, unset the variables in the current environment.  Otherwise,
 augment existing enviroment variables with additional search paths."
   (when pure? (purify-environment))
-  (for-each-search-path setenv inputs derivations pure?))
+  (for-each (match-lambda
+              ((($ <search-path-specification> variable _ separator) . value)
+               (let ((current (getenv variable)))
+                 (setenv variable
+                         (if (and current (not pure?))
+                             (string-append value separator current)
+                             value)))))
+            (evaluate-input-search-paths inputs derivations)))
 
 (define (show-search-paths inputs derivations pure?)
   "Display the needed search paths to build an environment that contains the
 packages within INPUTS.  When PURE? is #t, do not augment existing environment
 variables with additional search paths."
-  (for-each-search-path (lambda (variable value)
-                          (format #t "export ~a=\"~a\"~%" variable value))
-                        inputs derivations pure?))
+  (for-each (match-lambda
+              ((search-path . value)
+               (display
+                (search-path-definition search-path value
+                                        #:kind (if pure? 'exact 'prefix)))
+               (newline)))
+            (evaluate-input-search-paths inputs derivations)))
 
 (define (show-help)
   (display (_ "Usage: guix environment [OPTION]... PACKAGE...
@@ -191,13 +191,6 @@ packages."
   (delete-duplicates
    (append-map transitive-inputs packages)))
 
-;; TODO: Deduplicate these.
-(define show-what-to-build*
-  (store-lift show-what-to-build))
-
-(define set-build-options-from-command-line*
-  (store-lift set-build-options-from-command-line))
-
 (define (build-inputs inputs opts)
   "Build the packages in INPUTS using the build options in OPTS."
   (let ((substitutes? (assoc-ref opts 'substitutes?))
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index ed16cab8f9..4bae65a1ec 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -44,6 +44,8 @@ Invoke the garbage collector.\n"))
   (display (_ "
   -d, --delete           attempt to delete PATHS"))
   (display (_ "
+      --optimize         optimize the store by deduplicating identical files"))
+  (display (_ "
       --list-dead        list dead paths"))
   (display (_ "
       --list-live        list live paths"))
@@ -88,6 +90,10 @@ Invoke the garbage collector.\n"))
                 (lambda (opt name arg result)
                   (alist-cons 'action 'delete
                               (alist-delete 'action result))))
+        (option '("optimize") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'action 'optimize
+                              (alist-delete 'action result))))
         (option '("list-dead") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-dead
@@ -169,6 +175,8 @@ Invoke the garbage collector.\n"))
          (list-relatives requisites))
         ((list-referrers)
          (list-relatives referrers))
+        ((optimize)
+         (optimize-store store))
         ((list-dead)
          (for-each (cut simple-format #t "~a~%" <>)
                    (dead-paths store)))
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 7e75c10b3e..06b4c17573 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -73,7 +73,7 @@ rather than \\n."
 ;;; Entry point.
 ;;;
 
-(define importers '("gnu" "nix" "pypi" "cpan"))
+(define importers '("gnu" "nix" "pypi" "cpan" "hackage"))
 
 (define (resolve-importer name)
   (let ((module (resolve-interface
diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm
new file mode 100644
index 0000000000..f7c18cd3bf
--- /dev/null
+++ b/guix/scripts/import/hackage.scm
@@ -0,0 +1,106 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
+;;;
+;;; 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 import hackage)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix import hackage)
+  #:use-module (guix scripts import)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:export (guix-import-hackage))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+  '((include-test-dependencies? . #t)))
+
+(define (show-help)
+  (display (_ "Usage: guix import hackage PACKAGE-NAME
+Import and convert the Hackage package for PACKAGE-NAME.  If PACKAGE-NAME
+includes a suffix constituted by a dash followed by a numerical version (as
+used with Guix packages), then a definition for the specified version of the
+package will be generated.  If no version suffix is pecified, then the
+generated package definition will correspond to the latest available
+version.\n"))
+  (display (_ "
+  -h, --help                   display this help and exit"))
+  (display (_ "
+  -t, --no-test-dependencies   don't include test only dependencies"))
+  (display (_ "
+  -V, --version                display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specification of the command-line options.
+  (cons* (option '(#\h "help") #f #f
+                 (lambda args
+                   (show-help)
+                   (exit 0)))
+         (option '(#\V "version") #f #f
+                 (lambda args
+                   (show-version-and-exit "guix import hackage")))
+         (option '(#\t "no-test-dependencies") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'include-test-dependencies? #f
+                               (alist-delete 'include-test-dependencies?
+                                             result))))
+         %standard-import-options))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import-hackage . 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))
+         (args (filter-map (match-lambda
+                            (('argument . value)
+                             value)
+                            (_ #f))
+                           (reverse opts))))
+    (match args
+      ((package-name)
+       (let ((sexp (hackage->guix-package
+                    package-name
+                    #:include-test-dependencies?
+                    (assoc-ref opts 'include-test-dependencies?))))
+         (unless sexp
+           (leave (_ "failed to download cabal file for package '~a'~%")
+                  package-name))
+         sexp))
+      (()
+       (leave (_ "too few arguments~%")))
+      ((many ...)
+       (leave (_ "too many arguments~%"))))))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index c40d76b558..cced1bda66 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -19,6 +19,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix scripts lint)
+  #:use-module (guix store)
   #:use-module (guix base32)
   #:use-module (guix download)
   #:use-module (guix ftp-client)
@@ -32,6 +33,8 @@
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
   #:use-module (web uri)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module ((guix build download)
                 #:select (maybe-expand-mirrors
                           open-connection-for-uri))
@@ -41,12 +44,15 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
   #:export (guix-lint
             check-description-style
             check-inputs-should-be-native
-            check-patches
+            check-patch-file-names
             check-synopsis-style
+            check-derivation
             check-home-page
             check-source))
 
@@ -348,26 +354,30 @@ warning for PACKAGE mentionning the FIELD."
                                     (package-home-page package))
                     'home-page)))))
 
-(define (check-patches package)
-  ;; Emit a warning if the patches requires by PACKAGE are badly named.
-  (let ((patches   (and=> (package-source package) origin-patches))
-        (name      (package-name package))
-        (full-name (package-full-name package)))
-    (when (and patches
-               (any (match-lambda
-                     ((? string? patch)
-                      (let ((filename (basename patch)))
-                        (not (or (eq? (string-contains filename name) 0)
-                                 (eq? (string-contains filename full-name)
-                                      0)))))
-                     (_
-                      ;; This must be an <origin> or something like that.
-                      #f))
-                    patches))
-      (emit-warning package
-                    (_ "file names of patches should start with \
+(define (check-patch-file-names package)
+  "Emit a warning if the patches requires by PACKAGE are badly named or if the
+patch could not be found."
+  (guard (c ((message-condition? c)               ;raised by 'search-patch'
+             (emit-warning package (condition-message c)
+                           'patch-file-names)))
+    (let ((patches   (and=> (package-source package) origin-patches))
+          (name      (package-name package))
+          (full-name (package-full-name package)))
+      (when (and patches
+                 (any (match-lambda
+                        ((? string? patch)
+                         (let ((file (basename patch)))
+                           (not (or (eq? (string-contains file name) 0)
+                                    (eq? (string-contains file full-name)
+                                         0)))))
+                        (_
+                         ;; This must be an <origin> or something like that.
+                         #f))
+                      patches))
+        (emit-warning package
+                      (_ "file names of patches should start with \
 the package name")
-                    'patches))))
+                      'patch-file-names)))))
 
 (define (escape-quotes str)
   "Replace any quote character in STR by an escaped quote character."
@@ -434,6 +444,25 @@ descriptions maintained upstream."
              (append-map (cut maybe-expand-mirrors <> %mirrors)
                          uris))))))
 
+(define (check-derivation package)
+  "Emit a warning if we fail to compile PACKAGE to a derivation."
+  (catch #t
+    (lambda ()
+      (guard (c ((nix-protocol-error? c)
+                 (emit-warning package
+                               (format #f (_ "failed to create derivation: ~a")
+                                       (nix-protocol-error-message c))))
+                ((message-condition? c)
+                 (emit-warning package
+                               (format #f (_ "failed to create derivation: ~a")
+                                       (condition-message c)))))
+        (with-store store
+          (package-derivation store package))))
+    (lambda args
+      (emit-warning package
+                    (format #f (_ "failed to create derivation: ~s~%")
+                            args)))))
+
 
 
 ;;;
@@ -455,9 +484,9 @@ descriptions maintained upstream."
      (description "Identify inputs that should be native inputs")
      (check       check-inputs-should-be-native))
    (lint-checker
-     (name        'patch-filenames)
-     (description "Validate file names of patches")
-     (check       check-patches))
+     (name        'patch-file-names)
+     (description "Validate file names and availability of patches")
+     (check       check-patch-file-names))
    (lint-checker
      (name        'home-page)
      (description "Validate home-page URLs")
@@ -467,6 +496,10 @@ descriptions maintained upstream."
      (description "Validate source URLs")
      (check       check-source))
    (lint-checker
+     (name        'derivation)
+     (description "Report failure to compile a package to a derivation")
+     (check       check-derivation))
+   (lint-checker
      (name        'synopsis)
      (description "Validate package synopses")
      (check       check-synopsis-style))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 3cc7ae760f..06ee441799 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
-;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -25,6 +25,7 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix profiles)
+  #:use-module (guix search-paths)
   #:use-module (guix monads)
   #:use-module (guix utils)
   #:use-module (guix config)
@@ -89,6 +90,15 @@ return PROFILE unchanged.  The goal is to treat '-p ~/.guix-profile' as if
       %current-profile
       profile))
 
+(define (user-friendly-profile profile)
+  "Return either ~/.guix-profile if that's what PROFILE refers to, directly or
+indirectly, or PROFILE."
+  (if (and %user-profile-directory
+           (false-if-exception
+            (string=? (readlink %user-profile-directory) profile)))
+      %user-profile-directory
+      profile))
+
 (define (link-to-empty-profile store generation)
   "Link GENERATION, a string, to the empty profile."
   (let* ((drv  (run-with-store store
@@ -232,6 +242,41 @@ DURATION-RELATION with the current time."
          filter-by-duration)
         (else #f)))
 
+(define (delete-matching-generations store profile pattern)
+  "Delete from PROFILE all the generations matching PATTERN.  PATTERN must be
+a string denoting a set of generations: the empty list means \"all generations
+but the current one\", a number designates a generation, and other patterns
+denote ranges as interpreted by 'matching-derivations'."
+  (let ((current (generation-number profile)))
+    (cond ((not (file-exists? profile))            ; XXX: race condition
+           (raise (condition (&profile-not-found-error
+                              (profile profile)))))
+          ((string-null? pattern)
+           (delete-generations (%store) profile
+                               (delv current (profile-generations profile))))
+          ;; Do not delete the zeroth generation.
+          ((equal? 0 (string->number pattern))
+           #t)
+
+          ;; If PATTERN is a duration, match generations that are
+          ;; older than the specified duration.
+          ((matching-generations pattern profile
+                                 #:duration-relation >)
+           =>
+           (lambda (numbers)
+             (when (memv current numbers)
+               (warning (_ "not removing generation ~a, which is current~%")
+                        current))
+
+             ;; Make sure we don't inadvertently remove the current
+             ;; generation.
+             (let ((numbers (delv current numbers)))
+               (when (null-list? numbers)
+                 (leave (_ "no matching generation~%")))
+               (delete-generations (%store) profile numbers))))
+          (else
+           (leave (_ "invalid syntax: ~a~%") pattern)))))
+
 
 ;;;
 ;;; Package specifications.
@@ -330,77 +375,35 @@ an output path different than CURRENT-PATH."
 ;;; Search paths.
 ;;;
 
-(define-syntax-rule (with-null-error-port exp)
-  "Evaluate EXP with the error port pointing to the bit bucket."
-  (with-error-to-port (%make-void-port "w")
-    (lambda () exp)))
-
 (define* (search-path-environment-variables entries profile
-                                            #:optional (getenv getenv))
+                                            #:optional (getenv getenv)
+                                            #:key (kind 'exact))
   "Return environment variable definitions that may be needed for the use of
 ENTRIES, a list of manifest entries, in PROFILE.  Use GETENV to determine the
-current settings and report only settings not already effective."
-
-  ;; Prefer ~/.guix-profile to the real profile directory name.
-  (let ((profile (if (and %user-profile-directory
-                          (false-if-exception
-                           (string=? (readlink %user-profile-directory)
-                                     profile)))
-                     %user-profile-directory
-                     profile)))
-
-    ;; The search path info is not stored in the manifest.  Thus, we infer the
-    ;; search paths from same-named packages found in the distro.
-
-    (define manifest-entry->package
-      (match-lambda
-       (($ <manifest-entry> name version)
-        ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name';
-        ;; the former traverses the module tree only once and then allows for
-        ;; efficient access via a vhash.
-        (match (find-best-packages-by-name name version)
-          ((p _ ...) p)
-          (_
-           (match (find-best-packages-by-name name #f)
-             ((p _ ...) p)
-             (_ #f)))))))
-
-    (define search-path-definition
-      (match-lambda
-       (($ <search-path-specification> variable files separator
-                                       type pattern)
-        (let* ((values (or (and=> (getenv variable)
-                                  (cut string-tokenize* <> separator))
-                           '()))
-               ;; Add a trailing slash to force symlinks to be treated as
-               ;; directories when 'find-files' traverses them.
-               (files  (if pattern
-                           (map (cut string-append <> "/") files)
-                           files))
-
-               ;; XXX: Silence 'find-files' when it stumbles upon non-existent
-               ;; directories (see
-               ;; <http://lists.gnu.org/archive/html/guix-devel/2015-01/msg00269.html>.)
-               (path   (with-null-error-port
-                        (search-path-as-list files (list profile)
-                                             #:type type
-                                             #:pattern pattern))))
-          (if (every (cut member <> values) path)
-              #f
-              (format #f "export ~a=\"~a\""
-                      variable
-                      (string-join path separator)))))))
-
-    (let* ((packages     (filter-map manifest-entry->package entries))
-           (search-paths (delete-duplicates
-                          (append-map package-native-search-paths
-                                      packages))))
-      (filter-map search-path-definition search-paths))))
+current settings and report only settings not already effective.  KIND
+must be one of 'exact, 'prefix, or 'suffix, depending on the kind of search
+path definition to be returned."
+  (let ((search-paths (delete-duplicates
+                       (cons $PATH
+                             (append-map manifest-entry-search-paths
+                                         entries)))))
+    (filter-map (match-lambda
+                  ((spec . value)
+                   (let ((variable (search-path-specification-variable spec))
+                         (sep      (search-path-specification-separator spec)))
+                     (environment-variable-definition variable value
+                                                      #:separator sep
+                                                      #:kind kind))))
+                (evaluate-search-paths search-paths (list profile)
+                                       getenv))))
 
-(define (display-search-paths entries profile)
+(define* (display-search-paths entries profile
+                               #:key (kind 'exact))
   "Display the search path environment variables that may need to be set for
 ENTRIES, a list of manifest entries, in the context of PROFILE."
-  (let ((settings (search-path-environment-variables entries profile)))
+  (let* ((profile  (user-friendly-profile profile))
+         (settings (search-path-environment-variables entries profile
+                                                      #:kind kind)))
     (unless (null? settings)
       (format #t (_ "The following environment variable definitions may be needed:~%"))
       (format #t "~{   ~a~%~}" settings))))
@@ -430,9 +433,15 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
   (display (_ "
   -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP"))
   (display (_ "
+  -m, --manifest=FILE    create a new profile generation with the manifest
+                         from FILE"))
+  (display (_ "
+      --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP"))
+  (display (_ "
       --roll-back        roll back to the previous generation"))
   (display (_ "
-      --search-paths     display needed environment variable definitions"))
+      --search-paths[=KIND]
+                         display needed environment variable definitions"))
   (display (_ "
   -l, --list-generations[=PATTERN]
                          list generations matching PATTERN"))
@@ -508,10 +517,21 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
                                          ;; would upgrade everything.
                                          (delete '(upgrade . #f) result))
                              arg-handler))))
+         (option '("do-not-upgrade") #f #t
+                 (lambda (opt name arg result arg-handler)
+                   (let arg-handler ((arg arg) (result result))
+                     (values (if arg
+                                 (alist-cons 'do-not-upgrade arg result)
+                                 result)
+                             arg-handler))))
          (option '("roll-back") #f #f
                  (lambda (opt name arg result arg-handler)
                    (values (alist-cons 'roll-back? #t result)
                            #f)))
+         (option '(#\m "manifest") #t #f
+                 (lambda (opt name arg result arg-handler)
+                   (values (alist-cons 'manifest arg result)
+                           arg-handler)))
          (option '(#\l "list-generations") #f #t
                  (lambda (opt name arg result arg-handler)
                    (values (cons `(query list-generations ,(or arg ""))
@@ -526,10 +546,20 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
                  (lambda (opt name arg result arg-handler)
                    (values (alist-cons 'switch-generation arg result)
                            #f)))
-         (option '("search-paths") #f #f
+         (option '("search-paths") #f #t
                  (lambda (opt name arg result arg-handler)
-                   (values (cons `(query search-paths) result)
-                           #f)))
+                   (let ((kind (match arg
+                                 ((or "exact" "prefix" "suffix")
+                                  (string->symbol arg))
+                                 (#f
+                                  'exact)
+                                 (x
+                                  (leave (_ "~a: unsupported \
+kind of search path~%")
+                                         x)))))
+                     (values (cons `(query search-paths ,kind)
+                                   result)
+                             #f))))
          (option '(#\p "profile") #t #f
                  (lambda (opt name arg result arg-handler)
                    (values (alist-cons 'profile (canonicalize-profile arg)
@@ -586,6 +616,13 @@ return the new list of manifest entries."
                  (_ #f))
                 opts))
 
+  (define do-not-upgrade-regexps
+    (filter-map (match-lambda
+                 (('do-not-upgrade . regexp)
+                  (make-regexp regexp))
+                 (_ #f))
+                opts))
+
   (define packages-to-upgrade
     (match upgrade-regexps
       (()
@@ -595,6 +632,8 @@ return the new list of manifest entries."
                     (($ <manifest-entry> name version output path _)
                      (and (any (cut regexp-exec <> name)
                                upgrade-regexps)
+                          (not (any (cut regexp-exec <> name)
+                                    do-not-upgrade-regexps))
                           (upgradeable? name version path)
                           (let ((output (or output "out")))
                             (call-with-values
@@ -677,13 +716,31 @@ doesn't need it."
 
 (define (readlink* file)
   "Call 'readlink' until the result is not a symlink."
-  (catch 'system-error
-    (lambda ()
-      (readlink* (readlink file)))
-    (lambda args
-      (if (= EINVAL (system-error-errno args))
-          file
-          (apply throw args)))))
+  (define %max-symlink-depth 50)
+
+  (let loop ((file  file)
+             (depth 0))
+    (define (absolute target)
+      (if (absolute-file-name? target)
+          target
+          (string-append (dirname file) "/" target)))
+
+    (if (>= depth %max-symlink-depth)
+        file
+        (call-with-values
+            (lambda ()
+              (catch 'system-error
+                (lambda ()
+                  (values #t (readlink file)))
+                (lambda args
+                  (let ((errno (system-error-errno args)))
+                    (if (or (= errno EINVAL))
+                        (values #f file)
+                        (apply throw args))))))
+          (lambda (success? target)
+            (if success?
+                (loop (absolute target) (+ depth 1))
+                file))))))
 
 
 ;;;
@@ -751,8 +808,49 @@ more information.~%"))
     (define dry-run? (assoc-ref opts 'dry-run?))
     (define profile  (assoc-ref opts 'profile))
 
-    (define current-generation-number
-      (generation-number profile))
+    (define (build-and-use-profile manifest)
+      (let* ((bootstrap?  (assoc-ref opts 'bootstrap?)))
+
+        (when (equal? profile %current-profile)
+          (ensure-default-profile))
+
+        (let* ((prof-drv (run-with-store (%store)
+                           (profile-derivation
+                            manifest
+                            #:hooks (if bootstrap?
+                                        '()
+                                        %default-profile-hooks))))
+               (prof     (derivation->output-path prof-drv)))
+          (show-what-to-build (%store) (list prof-drv)
+                              #:use-substitutes?
+                              (assoc-ref opts 'substitutes?)
+                              #:dry-run? dry-run?)
+
+          (cond
+           (dry-run? #t)
+           ((and (file-exists? profile)
+                 (and=> (readlink* profile) (cut string=? prof <>)))
+            (format (current-error-port) (_ "nothing to be done~%")))
+           (else
+            (let* ((number (generation-number profile))
+
+                   ;; Always use NUMBER + 1 for the new profile,
+                   ;; possibly overwriting a "previous future
+                   ;; generation".
+                   (name   (generation-file-name profile
+                                                 (+ 1 number))))
+              (and (build-derivations (%store) (list prof-drv))
+                   (let* ((entries (manifest-entries manifest))
+                          (count   (length entries)))
+                     (switch-symlinks name prof)
+                     (switch-symlinks profile name)
+                     (unless (string=? profile %current-profile)
+                       (register-gc-root (%store) name))
+                     (format #t (N_ "~a package in profile~%"
+                                    "~a packages in profile~%"
+                                    count)
+                             count)
+                     (display-search-paths entries profile)))))))))
 
     ;; First roll back if asked to.
     (cond ((and (assoc-ref opts 'roll-back?)
@@ -782,88 +880,34 @@ more information.~%"))
            (for-each
             (match-lambda
              (('delete-generations . pattern)
-              (cond ((not (file-exists? profile)) ; XXX: race condition
-                     (raise (condition (&profile-not-found-error
-                                        (profile profile)))))
-                    ((string-null? pattern)
-                     (delete-generations
-                      (%store) profile
-                      (delete current-generation-number
-                              (profile-generations profile))))
-                    ;; Do not delete the zeroth generation.
-                    ((equal? 0 (string->number pattern))
-                     (exit 0))
-
-                    ;; If PATTERN is a duration, match generations that are
-                    ;; older than the specified duration.
-                    ((matching-generations pattern profile
-                                           #:duration-relation >)
-                     =>
-                     (lambda (numbers)
-                       (if (null-list? numbers)
-                           (exit 1)
-                           (delete-generations (%store) profile numbers))))
-                    (else
-                     (leave (_ "invalid syntax: ~a~%")
-                            pattern)))
+              (delete-matching-generations (%store) profile pattern)
 
               (process-actions
                (alist-delete 'delete-generations opts)))
              (_ #f))
             opts))
+          ((and (assoc-ref opts 'manifest)
+                (not dry-run?))
+           (let* ((file-name (assoc-ref opts 'manifest))
+                  (user-module (make-user-module '((guix profiles)
+                                                   (gnu))))
+                  (manifest (load* file-name user-module)))
+             (format #t (_ "installing new manifest from ~a with ~d entries.~%")
+                     file-name (length (manifest-entries manifest)))
+             (build-and-use-profile manifest)))
           (else
            (let* ((manifest    (profile-manifest profile))
                   (install     (options->installable opts manifest))
                   (remove      (options->removable opts manifest))
-                  (bootstrap?  (assoc-ref opts 'bootstrap?))
                   (transaction (manifest-transaction (install install)
                                                      (remove remove)))
                   (new         (manifest-perform-transaction
                                 manifest transaction)))
 
-             (when (equal? profile %current-profile)
-               (ensure-default-profile))
-
              (unless (and (null? install) (null? remove))
-               (let* ((prof-drv (run-with-store (%store)
-                                  (profile-derivation
-                                   new
-                                   #:info-dir? (not bootstrap?)
-                                   #:ca-certificate-bundle? (not bootstrap?))))
-                      (prof     (derivation->output-path prof-drv)))
-                 (show-manifest-transaction (%store) manifest transaction
-                                            #:dry-run? dry-run?)
-                 (show-what-to-build (%store) (list prof-drv)
-                                     #:use-substitutes?
-                                     (assoc-ref opts 'substitutes?)
-                                     #:dry-run? dry-run?)
-
-                 (cond
-                  (dry-run? #t)
-                  ((and (file-exists? profile)
-                        (and=> (readlink* profile) (cut string=? prof <>)))
-                   (format (current-error-port) (_ "nothing to be done~%")))
-                  (else
-                   (let* ((number (generation-number profile))
-
-                          ;; Always use NUMBER + 1 for the new profile,
-                          ;; possibly overwriting a "previous future
-                          ;; generation".
-                          (name   (generation-file-name profile
-                                                        (+ 1 number))))
-                     (and (build-derivations (%store) (list prof-drv))
-                          (let* ((entries (manifest-entries new))
-                                 (count   (length entries)))
-                            (switch-symlinks name prof)
-                            (switch-symlinks profile name)
-                            (unless (string=? profile %current-profile)
-                              (register-gc-root (%store) name))
-                            (format #t (N_ "~a package in profile~%"
-                                           "~a packages in profile~%"
-                                           count)
-                                    count)
-                            (display-search-paths entries
-                                                  profile))))))))))))
+               (show-manifest-transaction (%store) manifest transaction
+                                          #:dry-run? dry-run?)
+               (build-and-use-profile new))))))
 
   (define (process-query opts)
     ;; Process any query specified by OPTS.  Return #t when a query was
@@ -932,11 +976,13 @@ more information.~%"))
                 (available (fold-packages
                             (lambda (p r)
                               (let ((n (package-name p)))
-                                (if regexp
-                                    (if (regexp-exec regexp n)
-                                        (cons p r)
-                                        r)
-                                    (cons p r))))
+                                (if (supported-package? p)
+                                    (if regexp
+                                        (if (regexp-exec regexp n)
+                                            (cons p r)
+                                            r)
+                                        (cons p r))
+                                    r)))
                             '())))
            (leave-on-EPIPE
             (for-each (lambda (p)
@@ -966,11 +1012,13 @@ more information.~%"))
                       (find-packages-by-name name version)))
            #t))
 
-        (('search-paths)
+        (('search-paths kind)
          (let* ((manifest (profile-manifest profile))
                 (entries  (manifest-entries manifest))
+                (profile  (user-friendly-profile profile))
                 (settings (search-path-environment-variables entries profile
-                                                             (const #f))))
+                                                             (const #f)
+                                                             #:kind kind)))
            (format #t "~{~a~%~}" settings)
            #t))
 
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
new file mode 100644
index 0000000000..7bad2619b9
--- /dev/null
+++ b/guix/scripts/publish.scm
@@ -0,0 +1,314 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <davet@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 publish)
+  #:use-module ((system repl server) #:prefix repl:)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-37)
+  #:use-module (web http)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web server)
+  #:use-module (web uri)
+  #:use-module (guix base32)
+  #:use-module (guix base64)
+  #:use-module (guix config)
+  #:use-module (guix derivations)
+  #:use-module (guix hash)
+  #:use-module (guix pki)
+  #:use-module (guix pk-crypto)
+  #:use-module (guix store)
+  #:use-module (guix serialization)
+  #:use-module (guix ui)
+  #:export (guix-publish))
+
+(define (show-help)
+  (format #t (_ "Usage: guix publish [OPTION]...
+Publish ~a over HTTP.\n") %store-directory)
+  (display (_ "
+  -p, --port=PORT        listen on PORT"))
+  (display (_ "
+      --listen=HOST      listen on the network interface for HOST"))
+  (display (_ "
+  -u, --user=USER        change privileges to USER as soon as possible"))
+  (display (_ "
+  -r, --repl[=PORT]      spawn REPL server on PORT"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define (getaddrinfo* host)
+  "Like 'getaddrinfo', but properly report errors."
+  (catch 'getaddrinfo-error
+    (lambda ()
+      (getaddrinfo host))
+    (lambda (key error)
+      (leave (_ "lookup of host '~a' failed: ~a~%")
+             host (gai-strerror error)))))
+
+(define %options
+  (list (option '(#\h "help") #f #f
+                (lambda _
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda _
+                  (show-version-and-exit "guix publish")))
+        (option '(#\u "user") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'user arg result)))
+        (option '(#\p "port") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'port (string->number* arg) result)))
+        (option '("listen") #t #f
+                (lambda (opt name arg result)
+                  (match (getaddrinfo* arg)
+                    ((info _ ...)
+                     (alist-cons 'address (addrinfo:addr info)
+                                 result))
+                    (()
+                     (leave (_ "lookup of host '~a' returned nothing")
+                            name)))))
+        (option '(#\r "repl") #f #t
+                (lambda (opt name arg result)
+                  ;; If port unspecified, use default Guile REPL port.
+                  (let ((port (and arg (string->number* arg))))
+                    (alist-cons 'repl (or port 37146) result))))))
+
+(define %default-options
+  `((port . 8080)
+    (address . ,(make-socket-address AF_INET INADDR_ANY 0))
+    (repl . #f)))
+
+(define (lazy-read-file-sexp file)
+  "Return a promise to read the canonical sexp from FILE."
+  (delay
+    (call-with-input-file file
+      (compose string->canonical-sexp
+               get-string-all))))
+
+(define %private-key
+  (lazy-read-file-sexp %private-key-file))
+
+(define %public-key
+  (lazy-read-file-sexp %public-key-file))
+
+(define %nix-cache-info
+  `(("StoreDir" . ,%store-directory)
+    ("WantMassQuery" . 0)
+    ("Priority" . 100)))
+
+(define (load-derivation file)
+  "Read the derivation from FILE."
+  (call-with-input-file file read-derivation))
+
+(define (signed-string s)
+  "Sign the hash of the string S with the daemon's key."
+  (let* ((public-key (force %public-key))
+         (hash (bytevector->hash-data (sha256 (string->utf8 s))
+                                      #:key-type (key-type public-key))))
+    (signature-sexp hash (force %private-key) public-key)))
+
+(define base64-encode-string
+  (compose base64-encode string->utf8))
+
+(define (narinfo-string store-path path-info key)
+  "Generate a narinfo key/value string for STORE-PATH using the details in
+PATH-INFO.  The narinfo is signed with KEY."
+  (let* ((url        (string-append "nar/" (basename store-path)))
+         (hash       (bytevector->base32-string
+                      (path-info-hash path-info)))
+         (size       (path-info-nar-size path-info))
+         (references (string-join
+                      (map basename (path-info-references path-info))
+                      " "))
+         (deriver (path-info-deriver path-info))
+         (base-info  (format #f
+                             "StorePath: ~a
+URL: ~a
+Compression: none
+NarHash: sha256:~a
+NarSize: ~d
+References: ~a~%"
+                             store-path url hash size references))
+         ;; Do not render a "Deriver" or "System" line if we are rendering
+         ;; info for a derivation.
+         (info (if (string-null? deriver)
+                   base-info
+                   (let ((drv (load-derivation deriver)))
+                     (format #f "~aSystem: ~a~%Deriver: ~a~%"
+                             base-info (derivation-system drv)
+                             (basename deriver)))))
+         (signature  (base64-encode-string
+                      (canonical-sexp->string (signed-string info)))))
+    (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature)))
+
+(define (not-found request)
+  "Render 404 response for REQUEST."
+  (values (build-response #:code 404)
+          (string-append "Resource not found: "
+                         (uri-path (request-uri request)))))
+
+(define (render-nix-cache-info)
+  "Render server information."
+  (values '((content-type . (text/plain)))
+          (lambda (port)
+            (for-each (match-lambda
+                       ((key . value)
+                        (format port "~a: ~a~%" key value)))
+                      %nix-cache-info))))
+
+(define (render-narinfo store request hash)
+  "Render metadata for the store path corresponding to HASH."
+  (let* ((store-path (hash-part->path store hash))
+         (path-info (and (not (string-null? store-path))
+                         (query-path-info store store-path))))
+    (if path-info
+        (values '((content-type . (application/x-nix-narinfo)))
+                (cut display
+                     (narinfo-string store-path path-info (force %private-key))
+                     <>))
+        (not-found request))))
+
+(define (render-nar request store-item)
+  "Render archive of the store path corresponding to STORE-ITEM."
+  (let ((store-path (string-append %store-directory "/" store-item)))
+    ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will
+    ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte
+    ;; sequences.
+    (if (file-exists? store-path)
+        (values '((content-type . (application/x-nix-archive
+                                   (charset . "ISO-8859-1"))))
+                (lambda (port)
+                  (write-file store-path port)))
+        (not-found request))))
+
+(define extract-narinfo-hash
+  (let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$")))
+    (lambda (str)
+      "Return the hash within the narinfo resource string STR, or false if STR
+is invalid."
+      (and=> (regexp-exec regexp str)
+             (cut match:substring <> 1)))))
+
+(define (get-request? request)
+  "Return #t if REQUEST uses the GET method."
+  (eq? (request-method request) 'GET))
+
+(define (request-path-components request)
+  "Split the URI path of REQUEST into a list of component strings.  For
+example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
+  (split-and-decode-uri-path (uri-path (request-uri request))))
+
+(define (make-request-handler store)
+  (lambda (request body)
+    (format #t "~a ~a~%"
+            (request-method request)
+            (uri-path (request-uri request)))
+    (if (get-request? request) ; reject POST, PUT, etc.
+        (match (request-path-components request)
+          ;; /nix-cache-info
+          (("nix-cache-info")
+           (render-nix-cache-info))
+          ;; /<hash>.narinfo
+          (((= extract-narinfo-hash (? string? hash)))
+           (render-narinfo store request hash))
+          ;; /nar/<store-item>
+          (("nar" store-item)
+           (render-nar request store-item))
+          (_ (not-found request)))
+        (not-found request))))
+
+(define (run-publish-server socket store)
+  (run-server (make-request-handler store)
+              'http
+              `(#:socket ,socket)))
+
+(define (open-server-socket address)
+  "Return a TCP socket bound to ADDRESS, a socket address."
+  (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
+    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+    (bind sock address)
+    sock))
+
+(define (gather-user-privileges user)
+  "Switch to the identity of USER, a user name."
+  (catch 'misc-error
+    (lambda ()
+      (let ((user (getpw user)))
+        (setgroups #())
+        (setgid (passwd:gid user))
+        (setuid (passwd:uid user))))
+    (lambda (key proc message args . rest)
+      (leave (_ "user '~a' not found: ~a~%")
+             user (apply format #f message args)))))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-publish . args)
+  (with-error-handling
+    (let* ((opts    (args-fold* args %options
+                                (lambda (opt name arg result)
+                                  (leave (_ "~A: unrecognized option~%") name))
+                                (lambda (arg result)
+                                  (leave (_ "~A: extraneuous argument~%") arg))
+                                %default-options))
+           (user    (assoc-ref opts 'user))
+           (port    (assoc-ref opts 'port))
+           (address (let ((addr (assoc-ref opts 'address)))
+                      (make-socket-address (sockaddr:fam addr)
+                                           (sockaddr:addr addr)
+                                           port)))
+           (socket  (open-server-socket address))
+           (repl-port (assoc-ref opts 'repl)))
+      ;; Read the key right away so that (1) we fail early on if we can't
+      ;; access them, and (2) we can then drop privileges.
+      (force %private-key)
+      (force %public-key)
+
+      (when user
+        ;; Now that we've read the key material and opened the socket, we can
+        ;; drop privileges.
+        (gather-user-privileges user))
+
+      (when (zero? (getuid))
+        (warning (_ "server running as root; \
+consider using the '--user' option!~%")))
+      (format #t (_ "publishing ~a on ~a, port ~d~%")
+              %store-directory
+              (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
+              (sockaddr:port address))
+      (when repl-port
+        (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
+      (with-store store
+        (run-publish-server socket store)))))
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 04886499a2..28519d78e2 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;;
@@ -207,16 +207,13 @@ update would trigger a complete rebuild."
          (list-dependent? (assoc-ref opts 'list-dependent?))
          (key-download    (assoc-ref opts 'key-download))
          (packages
-          (match (concatenate
-                  (filter-map (match-lambda
-                               (('argument . value)
-                                (let ((p (find-packages-by-name value)))
-                                  (when (null? p)
-                                    (leave (_ "~a: no package by that name~%")
-                                           value))
-                                  p))
+          (match (filter-map (match-lambda
+                               (('argument . spec)
+                                ;; Take either the specified version or the
+                                ;; latest one.
+                                (specification->package spec))
                                (_ #f))
-                              opts))
+                             opts)
                  (()                          ; default to all packages
                   (let ((select? (match (assoc-ref opts 'select)
                                         ('core core-package?)
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute.scm
index a4d153d4a0..8b4fa36d2a 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute.scm
@@ -17,7 +17,7 @@
 ;;; 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)
+(define-module (guix scripts substitute)
   #:use-module (guix ui)
   #:use-module (guix store)
   #:use-module (guix utils)
@@ -28,13 +28,12 @@
   #:use-module (guix base64)
   #:use-module (guix pk-crypto)
   #:use-module (guix pki)
-  #:use-module ((guix build utils) #:select (mkdir-p))
+  #:use-module ((guix build utils) #:select (mkdir-p dump-port))
   #:use-module ((guix build download)
                 #:select (progress-proc uri-abbreviation))
   #: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 (ice-9 ftw)
   #:use-module (ice-9 binary-ports)
@@ -48,11 +47,13 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (web uri)
+  #:use-module (web request)
+  #:use-module (web response)
   #:use-module (guix http-client)
   #:export (narinfo-signature->canonical-sexp
             read-narinfo
             write-narinfo
-            guix-substitute-binary))
+            guix-substitute))
 
 ;;; Comment:
 ;;;
@@ -68,8 +69,8 @@
 (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")))
+             (cut string-append <> "/guix/substitute"))
+      (string-append %state-directory "/substitute/cache")))
 
 (define %allow-unauthenticated-substitutes?
   ;; Whether to allow unchecked substitutes.  This is useful for testing
@@ -83,8 +84,10 @@ disabled!~%"))
 
 (define %narinfo-ttl
   ;; Number of seconds during which cached narinfo lookups are considered
-  ;; valid.
-  (* 24 3600))
+  ;; valid.  This is a reasonable default value (corresponds to the TTL for
+  ;; nginx's .nar cache on hydra.gnu.org) but we'd rather want publishers to
+  ;; state what their TTL is in /nix-cache-info.  (XXX)
+  (* 36 3600))
 
 (define %narinfo-negative-ttl
   ;; Likewise, but for negative lookups---i.e., cached lookup failures.
@@ -94,15 +97,6 @@ disabled!~%"))
   ;; How often we want to remove files corresponding to expired cache entries.
   (* 7 24 3600))
 
-;; In Guile 2.0.9, `regexp-exec' is thread-unsafe, so work around it.
-;; See <http://bugs.gnu.org/14404>.
-(set! regexp-exec
-      (let ((real regexp-exec)
-            (lock (make-mutex)))
-        (lambda (rx str . rest)
-          (with-mutex lock
-            (apply real rx str rest)))))
-
 (define fields->alist
   ;; The narinfo format is really just like recutils.
   recutils->alist)
@@ -163,15 +157,12 @@ to the caller without emitting an error message."
                       (leave (_ "download from '~a' failed: ~a, ~s~%")
                              (uri->string (http-get-error-uri c))
                              code (http-get-error-reason c))))))
-       ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once.  So
-       ;; honor TIMEOUT? to disable the timeout when fetching a nar.
-       ;;
        ;; Test this with:
        ;;   sudo tc qdisc add dev eth0 root netem delay 1500ms
        ;; and then cancel with:
        ;;   sudo tc qdisc del dev eth0 root
        (let ((port #f))
-         (with-timeout (if (or timeout? (guile-version>? "2.0.5"))
+         (with-timeout (if timeout?
                            %fetch-timeout
                            0)
            (begin
@@ -188,7 +179,9 @@ to the caller without emitting an error message."
                  (close-port port))))
            (begin
              (when (or (not port) (port-closed? port))
-               (set! port (open-socket-for-uri uri #:buffered? buffered?)))
+               (set! port (open-socket-for-uri uri))
+               (unless buffered?
+                 (setvbuf port _IONBF)))
              (http-fetch uri #:text? #f #:port port))))))))
 
 (define-record-type <cache>
@@ -218,7 +211,7 @@ failure."
 gonna have to wait."
   (delay (begin
            (format (current-error-port)
-                   (_ "updating list of substitutes from '~a'...~%")
+                   (_ "updating list of substitutes from '~a'...\r")
                    url)
            (open-cache url))))
 
@@ -309,12 +302,16 @@ NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO."
       (corrupt-signature
        (leave (_ "signature on '~a' is corrupt~%") uri)))))
 
-(define* (read-narinfo port #:optional url)
+(define* (read-narinfo port #:optional url
+                       #:key size)
   "Read a narinfo from PORT.  If URL is true, it must be a string used to
-build full URIs from relative URIs found while reading PORT.
+build full URIs from relative URIs found while reading PORT.  When SIZE is
+true, read at most SIZE bytes from PORT; otherwise, read as much as possible.
 
 No authentication and authorization checks are performed here!"
-  (let ((str (utf8->string (get-bytevector-all port))))
+  (let ((str (utf8->string (if size
+                               (get-bytevector-n port size)
+                               (get-bytevector-all port)))))
     (alist->record (call-with-input-string str fields->alist)
                    (narinfo-maker str url)
                    '("StorePath" "URL" "Compression"
@@ -376,40 +373,56 @@ or is signed by an unauthorized key."
 the cache STR originates form."
   (call-with-input-string str (cut read-narinfo <> cache-uri)))
 
-(define (fetch-narinfo cache path)
-  "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
-  (define (download url)
-    ;; Download the .narinfo from URL, and return its contents as a list of
-    ;; key/value pairs.  Don't emit an error message upon 404.
-    (false-if-exception (fetch (string->uri url)
-                               #:quiet-404? #t)))
-
-  (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 (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-threads
-  ;; Number of threads spawned to perform lookup operations.  This means we
-  ;; can have this many simultaneous HTTP GET requests to the server, which
-  ;; limits the impact of connection latency.
-  20)
 
-(define (lookup-narinfo cache path)
-  "Check locally if we have valid info about PATH, otherwise go to CACHE and
-check what it has."
+(define (narinfo-cache-file path)
+  "Return the name of the local file that contains an entry for PATH."
+  (string-append %narinfo-cache-directory "/"
+                 (store-path-hash-part path)))
+
+(define (cached-narinfo path)
+  "Check locally if we have valid info about PATH.  Return two values: a
+Boolean indicating whether we have valid cached info, and that info, which may
+be either #f (when PATH is unavailable) or the narinfo for PATH."
   (define now
     (current-time time-monotonic))
 
   (define cache-file
-    (string-append %narinfo-cache-directory "/"
-                   (store-path-hash-part path)))
+    (narinfo-cache-file path))
+
+  (catch 'system-error
+    (lambda ()
+      (call-with-input-file cache-file
+        (lambda (p)
+          (match (read p)
+            (('narinfo ('version 1)
+                       ('cache-uri cache-uri)
+                       ('date date) ('value #f))
+             ;; A cached negative lookup.
+             (if (obsolete? date now %narinfo-negative-ttl)
+                 (values #f #f)
+                 (values #t #f)))
+            (('narinfo ('version 1)
+                       ('cache-uri cache-uri)
+                       ('date date) ('value value))
+             ;; A cached positive lookup
+             (if (obsolete? date now %narinfo-ttl)
+                 (values #f #f)
+                 (values #t (string->narinfo value cache-uri))))
+            (('narinfo ('version v) _ ...)
+             (values #f #f))))))
+    (lambda _
+      (values #f #f))))
+
+(define (cache-narinfo! cache path narinfo)
+  "Cache locally NARNIFO for PATH, which originates from CACHE.  NARINFO may
+be #f, in which case it indicates that PATH is unavailable at CACHE."
+  (define now
+    (current-time time-monotonic))
 
   (define (cache-entry cache-uri narinfo)
     `(narinfo (version 1)
@@ -417,43 +430,154 @@ check what it has."
               (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 1)
-                                      ('cache-uri cache-uri)
-                                      ('date date) ('value #f))
-                            ;; A cached negative lookup.
-                            (if (obsolete? date now %narinfo-negative-ttl)
-                                (values #f #f)
-                                (values #t #f)))
-                           (('narinfo ('version 1)
-                                      ('cache-uri cache-uri)
-                                      ('date date) ('value value))
-                            ;; A cached positive lookup
-                            (if (obsolete? date now %narinfo-ttl)
-                                (values #f #f)
-                                (values #t (string->narinfo value
-                                                            cache-uri))))
-                           (('narinfo ('version v) _ ...)
-                            (values #f #f))))))
-                   (lambda _
-                     (values #f #f)))))
-    (if valid?
-        cached                                    ; including negative caches
+  (with-atomic-file-output (narinfo-cache-file path)
+    (lambda (out)
+      (write (cache-entry (cache-url cache) narinfo) out)))
+  narinfo)
+
+(define (narinfo-request cache-url path)
+  "Return an HTTP request for the narinfo of PATH at CACHE-URL."
+  (let ((url (string-append cache-url "/" (store-path-hash-part path)
+                            ".narinfo")))
+    (build-request (string->uri url) #:method 'GET)))
+
+(define (http-multiple-get base-url requests proc)
+  "Send all of REQUESTS to the server at BASE-URL.  Call PROC for each
+response, passing it the request object, the response, and a port from which
+to read the response body.  Return the list of results."
+  (let connect ((requests requests)
+                (result   '()))
+    ;; (format (current-error-port) "connecting (~a requests left)..."
+    ;;         (length requests))
+    (let ((p (open-socket-for-uri base-url)))
+      ;; Send all of REQUESTS in a row.
+      (setvbuf p _IOFBF (expt 2 16))
+      (for-each (cut write-request <> p) requests)
+      (force-output p)
+
+      ;; Now start processing responses.
+      (let loop ((requests requests)
+                 (result   result))
+        (match requests
+          (()
+           (reverse result))
+          ((head tail ...)
+           (let* ((resp (read-response p))
+                  (body (response-body-port resp)))
+             ;; The server can choose to stop responding at any time, in which
+             ;; case we have to try again.  Check whether that is the case.
+             (match (assq 'connection (response-headers resp))
+               (('connection 'close)
+                (close-port p)
+                (connect requests result))        ;try again
+               (_
+                (loop tail                        ;keep going
+                      (cons (proc head resp body) result)))))))))))
+
+(define (read-to-eof port)
+  "Read from PORT until EOF is reached.  The data are discarded."
+  (dump-port port (%make-void-port "w")))
+
+(define (narinfo-from-file file url)
+  "Attempt to read a narinfo from FILE, using URL as the cache URL.  Return #f
+if file doesn't exist, and the narinfo otherwise."
+  (catch 'system-error
+    (lambda ()
+      (call-with-input-file file
+        (cut read-narinfo <> url)))
+    (lambda args
+      (if (= ENOENT (system-error-errno args))
+          #f
+          (apply throw args)))))
+
+(define (fetch-narinfos cache paths)
+  "Retrieve all the narinfos for PATHS from CACHE and return them."
+  (define url
+    (cache-url cache))
+
+  (define update-progress!
+    (let ((done 0))
+      (lambda ()
+        (display #\cr (current-error-port))
+        (force-output (current-error-port))
+        (format (current-error-port)
+                (_ "updating list of substitutes from '~a'... ~5,1f%")
+                url (* 100. (/ done (length paths))))
+        (set! done (+ 1 done)))))
+
+  (define (handle-narinfo-response request response port)
+    (let ((len (response-content-length response)))
+      ;; Make sure to read no more than LEN bytes since subsequent bytes may
+      ;; belong to the next response.
+      (case (response-code response)
+        ((200)                                     ; hit
+         (let ((narinfo (read-narinfo port url #:size len)))
+           (cache-narinfo! cache (narinfo-path narinfo) narinfo)
+           (update-progress!)
+           narinfo))
+        ((404)                                     ; failure
+         (let* ((path      (uri-path (request-uri request)))
+                (hash-part (string-drop-right path 8))) ; drop ".narinfo"
+           (if len
+               (get-bytevector-n port len)
+               (read-to-eof port))
+           (cache-narinfo! cache
+                           (find (cut string-contains <> hash-part) paths)
+                           #f)
+           (update-progress!))
+         #f)
+        (else                                      ; transient failure
+         (if len
+             (get-bytevector-n port len)
+             (read-to-eof port))
+         #f))))
+
+  (and (string=? (cache-store-directory cache) (%store-prefix))
+       (let ((uri (string->uri url)))
+         (case (and=> uri uri-scheme)
+           ((http)
+            (let ((requests (map (cut narinfo-request url <>) paths)))
+              (update-progress!)
+              (let ((result (http-multiple-get url requests
+                                               handle-narinfo-response)))
+                (newline (current-error-port))
+                result)))
+           ((file #f)
+            (let* ((base  (string-append (uri-path uri) "/"))
+                   (files (map (compose (cut string-append base <> ".narinfo")
+                                        store-path-hash-part)
+                               paths)))
+              (filter-map (cut narinfo-from-file <> url) files)))
+           (else
+            (leave (_ "~s: unsupported server URI scheme~%")
+                   (if uri (uri-scheme uri) url)))))))
+
+(define (lookup-narinfos cache paths)
+  "Return the narinfos for PATHS, invoking the server at CACHE when no
+information is available locally."
+  (let-values (((cached missing)
+                (fold2 (lambda (path cached missing)
+                         (let-values (((valid? value)
+                                       (cached-narinfo path)))
+                           (if valid?
+                               (values (cons value cached) missing)
+                               (values cached (cons path missing)))))
+                       '()
+                       '()
+                       paths)))
+    (if (null? missing)
+        cached
         (let* ((cache   (force cache))
-               (narinfo (and cache (fetch-narinfo cache path))))
-          ;; Cache NARINFO only when CACHE was actually accessible.  This
-          ;; avoids caching negative hits when in fact we just lacked network
-          ;; access.
-          (when cache
-            (with-atomic-file-output cache-file
-              (lambda (out)
-                (write (cache-entry (cache-url cache) narinfo) out))))
-          narinfo))))
+               (missing (if cache
+                            (fetch-narinfos cache missing)
+                            '())))
+          (append cached missing)))))
+
+(define (lookup-narinfo cache path)
+  "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was
+found."
+  (match (lookup-narinfos cache (list path))
+    ((answer) answer)))
 
 (define (remove-expired-cached-narinfos)
   "Remove expired narinfo entries from the cache.  The sole purpose of this
@@ -522,17 +646,9 @@ PORT.  REPORT-PROGRESS is a two-argument procedure such as that returned by
       ;; XXX: We're not in control, so we always return anyway.
       n))
 
-  ;; Since `http-fetch' in Guile 2.0.5 returns all the data once it's done,
-  ;; don't pretend to report any progress in that case.
-  (if (guile-version>? "2.0.5")
-      (make-custom-binary-input-port "progress-port-proc"
-                                     read! #f #f
-                                     (cut close-port port))
-      (begin
-        (format (current-error-port) (_ "Downloading, please wait...~%"))
-        (format (current-error-port)
-                (_ "(Please consider upgrading Guile to get proper progress report.)~%"))
-        port)))
+  (make-custom-binary-input-port "progress-port-proc"
+                                 read! #f #f
+                                 (cut close-port port)))
 
 (define-syntax with-networking
   (syntax-rules ()
@@ -553,7 +669,7 @@ PORT.  REPORT-PROGRESS is a two-argument procedure such as that returned by
 ;;;
 
 (define (show-help)
-  (display (_ "Usage: guix substitute-binary [OPTION]...
+  (display (_ "Usage: guix substitute [OPTION]...
 Internal tool to substitute a pre-built binary to a local build.\n"))
   (display (_ "
       --query            report on the availability of substitutes for the
@@ -576,16 +692,6 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
 ;;; Entry point.
 ;;;
 
-(define n-par-map*
-  ;; We want the ability to run many threads in parallel, regardless of the
-  ;; number of cores.  However, Guile 2.0.5 has a bug whereby 'n-par-map' ends
-  ;; up consuming a lot of memory, possibly leading to death.  Thus, resort to
-  ;; 'par-map' on 2.0.5.
-  (if (guile-version>? "2.0.5")
-      n-par-map
-      (lambda (n proc lst)
-        (par-map proc lst))))
-
 (define (check-acl-initialized)
   "Warn if the ACL is uninitialized."
   (define (singleton? acl)
@@ -649,7 +755,7 @@ found."
      ;; daemon.
      "http://hydra.gnu.org")))
 
-(define (guix-substitute-binary . args)
+(define (guix-substitute . args)
   "Implement the build daemon's substituter protocol."
   (mkdir-p %narinfo-cache-directory)
   (maybe-remove-expired-cached-narinfo)
@@ -694,9 +800,7 @@ substituter disabled~%")
                      ;; Return the subset of PATHS available in CACHE.
                      (let ((substitutable
                             (if cache
-                                (n-par-map* %lookup-threads
-                                            (cut lookup-narinfo cache <>)
-                                            paths)
+                                (lookup-narinfos cache paths)
                                 '())))
                        (for-each (lambda (narinfo)
                                    (format #t "~a~%" (narinfo-path narinfo)))
@@ -706,9 +810,7 @@ substituter disabled~%")
                      ;; Reply info about PATHS if it's in CACHE.
                      (let ((substitutable
                             (if cache
-                                (n-par-map* %lookup-threads
-                                            (cut lookup-narinfo cache <>)
-                                            paths)
+                                (lookup-narinfos cache paths)
                                 '())))
                        (for-each (lambda (narinfo)
                                    (format #t "~a\n~a\n~a\n"
@@ -774,7 +876,7 @@ substituter disabled~%")
 
             (every (compose zero? cdr waitpid) pids))))
        (("--version")
-        (show-version-and-exit "guix substitute-binary"))
+        (show-version-and-exit "guix substitute"))
        (("--help")
         (show-help))
        (opts
@@ -785,4 +887,4 @@ substituter disabled~%")
 ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
 ;;; End:
 
-;;; substitute-binary.scm ends here
+;;; substitute.scm ends here
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 1b64e6fb92..8d5fbe5a78 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -48,42 +48,14 @@
 
 (define %user-module
   ;; Module in which the machine description file is loaded.
-  (let ((module (make-fresh-user-module)))
-    (for-each (lambda (iface)
-                (module-use! module (resolve-interface iface)))
-              '((gnu system)
-                (gnu services)
-                (gnu system shadow)))
-    module))
+  (make-user-module '((gnu system)
+                      (gnu services)
+                      (gnu system shadow))))
 
 (define (read-operating-system file)
   "Read the operating-system declaration from FILE and return it."
-  ;; TODO: Factorize.
-  (catch #t
-    (lambda ()
-      ;; Avoid ABI incompatibility with the <operating-system> record.
-      (set! %fresh-auto-compile #t)
+  (load* file %user-module))
 
-      (save-module-excursion
-       (lambda ()
-         (set-current-module %user-module)
-         (primitive-load file))))
-    (lambda args
-      (match args
-        (('system-error . _)
-         (let ((err (system-error-errno args)))
-           (leave (_ "failed to open operating system file '~a': ~a~%")
-                  file (strerror err))))
-        (('syntax-error proc message properties form . rest)
-         (let ((loc (source-properties->location properties)))
-           (format (current-error-port) (_ "~a: error: ~a~%")
-                   (location->string loc) message)
-           (exit 1)))
-        ((error args ...)
-         (report-error (_ "failed to load operating system file '~a':~%")
-                       file)
-         (apply display-error #f (current-error-port) args)
-         (exit 1))))))
 
 
 ;;;
@@ -95,8 +67,6 @@
   (store-lift references))
 (define topologically-sorted*
   (store-lift topologically-sorted))
-(define show-what-to-build*
-  (store-lift show-what-to-build))
 
 
 (define* (copy-item item target