Merge branch 'master' into core-updates

10 files changed, 1255 insertions, 224 deletions

diff --git a/guix/config.scm.in b/guix/config.scm.in
index 772ea8c289..3a5c50e00a 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,6 +23,7 @@
             %guix-home-page-url
             %store-directory
             %state-directory
+            %config-directory
             %system
             %libgcrypt
             %nixpkgs
@@ -50,11 +51,16 @@
   "@PACKAGE_URL@")
 
 (define %store-directory
-  "@storedir@")
+  (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
+      "@storedir@"))
 
 (define %state-directory
   ;; This must match `NIX_STATE_DIR' as defined in `daemon.am'.
-  "@guix_localstatedir@/nix")
+  (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/nix"))
+
+(define %config-directory
+  ;; This must match `NIX_CONF_DIR' as defined in `daemon.am'.
+  (or (getenv "NIX_CONF_DIR") "@guix_sysconfdir@/guix"))
 
 (define %system
   "@guix_system@")
diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm
new file mode 100644
index 0000000000..50f709418c
--- /dev/null
+++ b/guix/pk-crypto.scm
@@ -0,0 +1,372 @@
+;;; 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 pk-crypto)
+  #:use-module (guix config)
+  #:use-module ((guix utils)
+                #:select (bytevector->base16-string
+                          base16-string->bytevector))
+  #:use-module (system foreign)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 match)
+  #:export (canonical-sexp?
+            error-source
+            error-string
+            string->canonical-sexp
+            canonical-sexp->string
+            number->canonical-sexp
+            canonical-sexp-car
+            canonical-sexp-cdr
+            canonical-sexp-nth
+            canonical-sexp-nth-data
+            canonical-sexp-length
+            canonical-sexp-null?
+            canonical-sexp-list?
+            bytevector->hash-data
+            hash-data->bytevector
+            sign
+            verify
+            generate-key
+            find-sexp-token
+            canonical-sexp->sexp
+            sexp->canonical-sexp))
+
+
+;;; Commentary:
+;;;
+;;; Public key cryptographic routines from GNU Libgcrypt.
+;;;;
+;;; Libgcrypt uses "canonical s-expressions" to represent key material,
+;;; parameters, and data.  We keep it as an opaque object to map them to
+;;; Scheme s-expressions because (1) Libgcrypt sexps may be stored in secure
+;;; memory, and (2) the read syntax is different.
+;;;
+;;; A 'canonical-sexp->sexp' procedure is provided nevertheless, for use in
+;;; cases where it is safe to move data out of Libgcrypt---e.g., when
+;;; processing ACL entries, public keys, etc.
+;;;
+;;; Canonical sexps were defined by Rivest et al. in the IETF draft at
+;;; <http://people.csail.mit.edu/rivest/Sexp.txt> for the purposes of SPKI
+;;; (see <http://www.ietf.org/rfc/rfc2693.txt>.)
+;;;
+;;; Code:
+
+;; Libgcrypt "s-expressions".
+(define-wrapped-pointer-type <canonical-sexp>
+  canonical-sexp?
+  naked-pointer->canonical-sexp
+  canonical-sexp->pointer
+  (lambda (obj port)
+    ;; Don't print OBJ's external representation: we don't want key material
+    ;; to leak in backtraces and such.
+    (format port "#<canonical-sexp ~a | ~a>"
+            (number->string (object-address obj) 16)
+            (number->string (pointer-address (canonical-sexp->pointer obj))
+                            16))))
+
+(define libgcrypt-func
+  (let ((lib (dynamic-link %libgcrypt)))
+    (lambda (func)
+      "Return a pointer to symbol FUNC in libgcrypt."
+      (dynamic-func func lib))))
+
+(define finalize-canonical-sexp!
+  (libgcrypt-func "gcry_sexp_release"))
+
+(define-inlinable (pointer->canonical-sexp ptr)
+  "Return a <canonical-sexp> that wraps PTR."
+  (let* ((sexp (naked-pointer->canonical-sexp ptr))
+         (ptr* (canonical-sexp->pointer sexp)))
+    ;; Did we already have a <canonical-sexp> object for PTR?
+    (when (equal? ptr ptr*)
+      ;; No, so we can safely add a finalizer (in Guile 2.0.9
+      ;; 'set-pointer-finalizer!' *adds* a finalizer rather than replacing the
+      ;; existing one.)
+      (set-pointer-finalizer! ptr finalize-canonical-sexp!))
+    sexp))
+
+(define error-source
+  (let* ((ptr  (libgcrypt-func "gcry_strsource"))
+         (proc (pointer->procedure '* ptr (list int))))
+    (lambda (err)
+      "Return the error source (a string) for ERR, an error code as thrown
+along with 'gcry-error'."
+      (pointer->string (proc err)))))
+
+(define error-string
+  (let* ((ptr  (libgcrypt-func "gcry_strerror"))
+         (proc (pointer->procedure '* ptr (list int))))
+    (lambda (err)
+      "Return the error description (a string) for ERR, an error code as
+thrown along with 'gcry-error'."
+      (pointer->string (proc err)))))
+
+(define string->canonical-sexp
+  (let* ((ptr  (libgcrypt-func "gcry_sexp_new"))
+         (proc (pointer->procedure int ptr `(* * ,size_t ,int))))
+    (lambda (str)
+      "Parse STR and return the corresponding gcrypt s-expression."
+      (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*))))
+             (err  (proc sexp (string->pointer str) 0 1)))
+        (if (= 0 err)
+            (pointer->canonical-sexp (dereference-pointer sexp))
+            (throw 'gcry-error err))))))
+
+(define-syntax GCRYSEXP_FMT_ADVANCED
+  (identifier-syntax 3))
+
+(define canonical-sexp->string
+  (let* ((ptr  (libgcrypt-func "gcry_sexp_sprint"))
+         (proc (pointer->procedure size_t ptr `(* ,int * ,size_t))))
+    (lambda (sexp)
+      "Return a textual representation of SEXP."
+      (let loop ((len 1024))
+        (let* ((buf  (bytevector->pointer (make-bytevector len)))
+               (size (proc (canonical-sexp->pointer sexp)
+                           GCRYSEXP_FMT_ADVANCED buf len)))
+          (if (zero? size)
+              (loop (* len 2))
+              (pointer->string buf size "ISO-8859-1")))))))
+
+(define canonical-sexp-car
+  (let* ((ptr  (libgcrypt-func "gcry_sexp_car"))
+         (proc (pointer->procedure '* ptr '(*))))
+    (lambda (lst)
+      "Return the first element of LST, an sexp, if that element is a list;
+return #f if LST or its first element is not a list (this is different from
+the usual Lisp 'car'.)"
+      (let ((result (proc (canonical-sexp->pointer lst))))
+        (if (null-pointer? result)
+            #f
+            (pointer->canonical-sexp result))))))
+
+(define canonical-sexp-cdr
+  (let* ((ptr  (libgcrypt-func "gcry_sexp_cdr"))
+         (proc (pointer->procedure '* ptr '(*))))
+    (lambda (lst)
+      "Return the tail of LST, an sexp, or #f if LST is not a list."
+      (let ((result (proc (canonical-sexp->pointer lst))))
+        (if (null-pointer? result)
+            #f
+            (pointer->canonical-sexp result))))))
+
+(define canonical-sexp-nth
+  (let* ((ptr  (libgcrypt-func "gcry_sexp_nth"))
+         (proc (pointer->procedure '* ptr `(* ,int))))
+    (lambda (lst index)
+      "Return the INDEXth nested element of LST, an s-expression.  Return #f
+if that element does not exist, or if it's an atom.  (Note: this is obviously
+different from Scheme's 'list-ref'.)"
+      (let ((result (proc (canonical-sexp->pointer lst) index)))
+        (if (null-pointer? result)
+            #f
+            (pointer->canonical-sexp result))))))
+
+(define (dereference-size_t p)
+  "Return the size_t value pointed to by P."
+  (bytevector-uint-ref (pointer->bytevector p (sizeof size_t))
+                       0 (native-endianness)
+                       (sizeof size_t)))
+
+(define canonical-sexp-length
+  (let* ((ptr  (libgcrypt-func "gcry_sexp_length"))
+         (proc (pointer->procedure int ptr '(*))))
+    (lambda (sexp)
+      "Return the length of SEXP if it's a list (including the empty list);
+return zero if SEXP is an atom."
+      (proc (canonical-sexp->pointer sexp)))))
+
+(define token-string?
+  (let ((token-cs (char-set-union char-set:digit
+                                  char-set:letter
+                                  (char-set #\- #\. #\/ #\_
+                                            #\: #\* #\+ #\=))))
+    (lambda (str)
+      "Return #t if STR is a token as per Section 4.3 of
+<http://people.csail.mit.edu/rivest/Sexp.txt>."
+      (and (not (string-null? str))
+           (string-every token-cs str)
+           (not (char-set-contains? char-set:digit (string-ref str 0)))))))
+
+(define canonical-sexp-nth-data
+  (let* ((ptr  (libgcrypt-func "gcry_sexp_nth_data"))
+         (proc (pointer->procedure '* ptr `(* ,int *))))
+    (lambda (lst index)
+      "Return as a symbol (for \"sexp tokens\") or a bytevector (for any other
+\"octet string\") the INDEXth data element (atom) of LST, an s-expression.
+Return #f if that element does not exist, or if it's a list."
+      (let* ((size*  (bytevector->pointer (make-bytevector (sizeof '*))))
+             (result (proc (canonical-sexp->pointer lst) index size*)))
+        (if (null-pointer? result)
+            #f
+            (let* ((len (dereference-size_t size*))
+                   (str (pointer->string result len "ISO-8859-1")))
+              ;; The sexp spec speaks of "tokens" and "octet strings".
+              ;; Sometimes these octet strings are actual strings (text),
+              ;; sometimes they're bytevectors, and sometimes they're
+              ;; multi-precision integers (MPIs).  Only the application knows.
+              ;; However, for convenience, we return a symbol when a token is
+              ;; encountered since tokens are frequent (at least in the 'car'
+              ;; of each sexp.)
+              (if (token-string? str)
+                  (string->symbol str)   ; an sexp "token"
+                  (bytevector-copy       ; application data, textual or binary
+                   (pointer->bytevector result len)))))))))
+
+(define (number->canonical-sexp number)
+  "Return an s-expression representing NUMBER."
+  (string->canonical-sexp (string-append "#" (number->string number 16) "#")))
+
+(define* (bytevector->hash-data bv #:optional (hash-algo "sha256"))
+  "Given BV, a bytevector containing a hash, return an s-expression suitable
+for use as the data for 'sign'."
+  (string->canonical-sexp
+   (format #f "(data (flags pkcs1) (hash \"~a\" #~a#))"
+           hash-algo
+           (bytevector->base16-string bv))))
+
+(define (hash-data->bytevector data)
+  "Return two values: the hash value (a bytevector), and the hash algorithm (a
+string) extracted from DATA, an sexp as returned by 'bytevector->hash-data'.
+Return #f if DATA does not conform."
+  (let ((hash (find-sexp-token data 'hash)))
+    (if hash
+        (let ((algo  (canonical-sexp-nth-data hash 1))
+              (value (canonical-sexp-nth-data hash 2)))
+          (values value (symbol->string algo)))
+        (values #f #f))))
+
+(define sign
+  (let* ((ptr  (libgcrypt-func "gcry_pk_sign"))
+         (proc (pointer->procedure int ptr '(* * *))))
+    (lambda (data secret-key)
+      "Sign DATA (an s-expression) with SECRET-KEY (an s-expression whose car
+is 'private-key'.)"
+      (let* ((sig (bytevector->pointer (make-bytevector (sizeof '*))))
+             (err (proc sig (canonical-sexp->pointer data)
+                        (canonical-sexp->pointer secret-key))))
+        (if (= 0 err)
+            (pointer->canonical-sexp (dereference-pointer sig))
+            (throw 'gry-error err))))))
+
+(define verify
+  (let* ((ptr  (libgcrypt-func "gcry_pk_verify"))
+         (proc (pointer->procedure int ptr '(* * *))))
+    (lambda (signature data public-key)
+      "Verify that SIGNATURE is a signature of DATA with PUBLIC-KEY, all of
+which are gcrypt s-expressions."
+      (zero? (proc (canonical-sexp->pointer signature)
+                   (canonical-sexp->pointer data)
+                   (canonical-sexp->pointer public-key))))))
+
+(define generate-key
+  (let* ((ptr  (libgcrypt-func "gcry_pk_genkey"))
+         (proc (pointer->procedure int ptr '(* *))))
+    (lambda (params)
+      "Return as an s-expression a new key pair for PARAMS.  PARAMS must be an
+s-expression like: (genkey (rsa (nbits 4:2048)))."
+      (let* ((key (bytevector->pointer (make-bytevector (sizeof '*))))
+             (err (proc key (canonical-sexp->pointer params))))
+        (if (zero? err)
+            (pointer->canonical-sexp (dereference-pointer key))
+            (throw 'gcry-error err))))))
+
+(define find-sexp-token
+  (let* ((ptr  (libgcrypt-func "gcry_sexp_find_token"))
+         (proc (pointer->procedure '* ptr `(* * ,size_t))))
+    (lambda (sexp token)
+      "Find in SEXP the first element whose 'car' is TOKEN and return it;
+return #f if not found."
+      (let* ((token (string->pointer (symbol->string token)))
+             (res   (proc (canonical-sexp->pointer sexp) token 0)))
+        (if (null-pointer? res)
+            #f
+            (pointer->canonical-sexp res))))))
+
+(define-inlinable (canonical-sexp-null? sexp)
+  "Return #t if SEXP is the empty-list sexp."
+  (null-pointer? (canonical-sexp->pointer sexp)))
+
+(define (canonical-sexp-list? sexp)
+  "Return #t if SEXP is a list."
+  (or (canonical-sexp-null? sexp)
+      (> (canonical-sexp-length sexp) 0)))
+
+(define (canonical-sexp-fold proc seed sexp)
+  "Fold PROC (as per SRFI-1) over SEXP, a canonical sexp."
+  (if (canonical-sexp-list? sexp)
+      (let ((len (canonical-sexp-length sexp)))
+        (let loop ((index  0)
+                   (result seed))
+          (if (= index len)
+              result
+              (loop (+ 1 index)
+                    ;; XXX: Call 'nth-data' *before* 'nth' to work around
+                    ;; <https://bugs.g10code.com/gnupg/issue1594>, which
+                    ;; affects 1.6.0 and earlier versions.
+                    (proc (or (canonical-sexp-nth-data sexp index)
+                              (canonical-sexp-nth sexp index))
+                          result)))))
+      (error "sexp is not a list" sexp)))
+
+(define (canonical-sexp->sexp sexp)
+  "Return a Scheme sexp corresponding to SEXP.  This is particularly useful to
+compare sexps (since Libgcrypt does not provide an 'equal?' procedure), or to
+use pattern matching."
+  (if (canonical-sexp-list? sexp)
+      (reverse
+       (canonical-sexp-fold (lambda (item result)
+                              (cons (if (canonical-sexp? item)
+                                        (canonical-sexp->sexp item)
+                                        item)
+                                    result))
+                            '()
+                            sexp))
+
+      ;; As of Libgcrypt 1.6.0, there's no function to extract the buffer of a
+      ;; non-list sexp (!), so we first enlist SEXP, then get at its buffer.
+      (let ((sexp (string->canonical-sexp
+                   (string-append "(" (canonical-sexp->string sexp)
+                                  ")"))))
+        (or (canonical-sexp-nth-data sexp 0)
+            (canonical-sexp-nth sexp 0)))))
+
+(define (sexp->canonical-sexp sexp)
+  "Return a canonical sexp equivalent to SEXP, a Scheme sexp as returned by
+'canonical-sexp->sexp'."
+  ;; XXX: This is inefficient, but the Libgcrypt API doesn't allow us to do
+  ;; much better.
+  (string->canonical-sexp
+    (call-with-output-string
+     (lambda (port)
+       (define (write item)
+         (cond ((list? item)
+                (display "(" port)
+                (for-each write item)
+                (display ")" port))
+               ((symbol? item)
+                (format port " ~a" item))
+               ((bytevector? item)
+                (format port " #~a#"
+                        (bytevector->base16-string item)))
+               (else
+                (error "unsupported sexp item type" item))))
+
+       (write sexp)))))
+
+;;; pk-crypto.scm ends here
diff --git a/guix/pki.scm b/guix/pki.scm
new file mode 100644
index 0000000000..5e4dbadd35
--- /dev/null
+++ b/guix/pki.scm
@@ -0,0 +1,139 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014 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 pki)
+  #:use-module (guix config)
+  #:use-module (guix pk-crypto)
+  #:use-module ((guix utils) #:select (with-atomic-file-output))
+  #:use-module ((guix build utils) #:select (mkdir-p))
+  #:use-module (ice-9 match)
+  #:use-module (rnrs io ports)
+  #:export (%public-key-file
+            %private-key-file
+            %acl-file
+            current-acl
+            public-keys->acl
+            acl->public-keys
+            signature-sexp
+            authorized-key?))
+
+;;; Commentary:
+;;;
+;;; Public key infrastructure for the authentication and authorization of
+;;; archive imports.  This is essentially a subset of SPKI for our own
+;;; purposes (see <http://theworld.com/~cme/spki.txt> and
+;;; <http://www.ietf.org/rfc/rfc2693.txt>.)
+;;;
+;;; Code:
+
+(define (acl-entry-sexp public-key)
+  "Return a SPKI-style ACL entry sexp for PUBLIC-KEY, authorizing imports
+signed by the corresponding secret key (see the IETF draft at
+<http://theworld.com/~cme/spki.txt> for the ACL format.)"
+  ;; Note: We always use PUBLIC-KEY to designate the subject.  Someday we may
+  ;; want to have name certificates and to use subject names instead of
+  ;; complete keys.
+  (string->canonical-sexp
+   (format #f
+           "(entry ~a (tag (guix import)))"
+           (canonical-sexp->string public-key))))
+
+(define (acl-sexp entries)
+  "Return an ACL sexp from ENTRIES, a list of 'entry' sexps."
+  (string->canonical-sexp
+   (string-append "(acl "
+                  (string-join (map canonical-sexp->string entries))
+                  ")")))
+
+(define (public-keys->acl keys)
+  "Return an ACL canonical sexp that lists all of KEYS with a '(guix import)'
+tag---meaning that all of KEYS are authorized for archive imports.  Each
+element in KEYS must be a canonical sexp with type 'public-key'."
+  (acl-sexp (map acl-entry-sexp keys)))
+
+(define %acl-file
+  (string-append %config-directory "/acl"))
+
+(define %public-key-file
+  (string-append %config-directory "/signing-key.pub"))
+
+(define %private-key-file
+  (string-append %config-directory "/signing-key.sec"))
+
+(define (ensure-acl)
+  "Make sure the ACL file exists, and create an initialized one if needed."
+  (unless (file-exists? %acl-file)
+    ;; If there's no public key file, don't attempt to create the ACL.
+    (when (file-exists? %public-key-file)
+      (let ((public-key (call-with-input-file %public-key-file
+                          (compose string->canonical-sexp
+                                   get-string-all))))
+        (mkdir-p (dirname %acl-file))
+        (with-atomic-file-output %acl-file
+          (lambda (port)
+            (display (canonical-sexp->string
+                      (public-keys->acl (list public-key)))
+                     port)))))))
+
+(define (current-acl)
+  "Return the current ACL as a canonical sexp."
+  (ensure-acl)
+  (if (file-exists? %acl-file)
+      (call-with-input-file %acl-file
+        (compose string->canonical-sexp
+                 get-string-all))
+      (public-keys->acl '())))                    ; the empty ACL
+
+(define (acl->public-keys acl)
+  "Return the public keys (as canonical sexps) listed in ACL with the '(guix
+import)' tag."
+  (match (canonical-sexp->sexp acl)
+    (('acl
+      ('entry subject-keys
+              ('tag ('guix 'import)))
+      ...)
+     (map sexp->canonical-sexp subject-keys))
+    (_
+     (error "invalid access-control list" acl))))
+
+(define* (authorized-key? key
+                          #:optional (acl (current-acl)))
+  "Return #t if KEY (a canonical sexp) is an authorized public key for archive
+imports according to ACL."
+  (let ((key (canonical-sexp->sexp key)))
+    (match (canonical-sexp->sexp acl)
+      (('acl
+        ('entry subject-keys
+                ('tag ('guix 'import)))
+        ...)
+       (not (not (member key subject-keys))))
+      (_
+       (error "invalid access-control list" acl)))))
+
+(define (signature-sexp data secret-key public-key)
+  "Return a SPKI-style sexp for the signature of DATA with SECRET-KEY that
+includes DATA, the actual signature value (with a 'sig-val' tag), and
+PUBLIC-KEY (see <http://theworld.com/~cme/spki.txt> for examples.)"
+  (string->canonical-sexp
+   (format #f
+           "(signature ~a ~a ~a)"
+           (canonical-sexp->string data)
+           (canonical-sexp->string (sign data secret-key))
+           (canonical-sexp->string public-key))))
+
+;;; pki.scm ends here
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
new file mode 100644
index 0000000000..32690c6b45
--- /dev/null
+++ b/guix/scripts/archive.scm
@@ -0,0 +1,337 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014 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 archive)
+  #:use-module (guix config)
+  #:use-module (guix utils)
+  #:use-module ((guix build utils) #:select (mkdir-p))
+  #:use-module (guix store)
+  #:use-module (guix packages)
+  #:use-module (guix derivations)
+  #:use-module (guix ui)
+  #:use-module (guix pki)
+  #:use-module (guix pk-crypto)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 rdelim)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-37)
+  #:use-module (guix scripts build)
+  #:use-module (guix scripts package)
+  #:use-module (rnrs io ports)
+  #:export (guix-archive))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+  ;; Alist of default option values.
+  `((system . ,(%current-system))
+    (substitutes? . #t)
+    (max-silent-time . 3600)
+    (verbosity . 0)))
+
+(define (show-help)
+  (display (_ "Usage: guix archive [OPTION]... PACKAGE...
+Export/import one or more packages from/to the store.\n"))
+  (display (_ "
+      --export           export the specified files/packages to stdout"))
+  (display (_ "
+      --import           import from the archive passed on stdin"))
+  (display (_ "
+      --missing          print the files from stdin that are missing"))
+  (newline)
+  (display (_ "
+      --generate-key[=PARAMETERS]
+                         generate a key pair with the given parameters"))
+  (display (_ "
+  -e, --expression=EXPR  build the package or derivation EXPR evaluates to"))
+  (display (_ "
+  -S, --source           build the packages' source derivations"))
+  (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\""))
+  (display (_ "
+  -n, --dry-run          do not build the derivations"))
+  (display (_ "
+      --fallback         fall back to building when the substituter fails"))
+  (display (_ "
+      --no-substitutes   build instead of resorting to pre-built substitutes"))
+  (display (_ "
+      --max-silent-time=SECONDS
+                         mark the build as failed after SECONDS of silence"))
+  (display (_ "
+  -c, --cores=N          allow the use of up to N CPU cores for the build"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix build")))
+
+        (option '("export") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'export #t result)))
+        (option '("import") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'import #t result)))
+        (option '("missing") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'missing #t result)))
+        (option '("generate-key") #f #t
+                (lambda (opt name arg result)
+                  (catch 'gcry-error
+                    (lambda ()
+                      (let ((params
+                             (string->canonical-sexp
+                              (or arg "(genkey (rsa (nbits 4:4096)))"))))
+                        (alist-cons 'generate-key params result)))
+                    (lambda args
+                      (leave (_ "invalid key generation parameters: ~s~%")
+                             arg)))))
+        (option '("authorize") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'authorize #t result)))
+
+        (option '(#\S "source") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'source? #t result)))
+        (option '(#\s "system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'system arg
+                              (alist-delete 'system result eq?))))
+        (option '("target") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'target arg
+                              (alist-delete 'target result eq?))))
+        (option '(#\e "expression") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'expression arg result)))
+        (option '(#\c "cores") #t #f
+                (lambda (opt name arg result)
+                  (let ((c (false-if-exception (string->number arg))))
+                    (if c
+                        (alist-cons 'cores c result)
+                        (leave (_ "~a: not a number~%") arg)))))
+        (option '(#\n "dry-run") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'dry-run? #t result)))
+        (option '("fallback") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'fallback? #t
+                              (alist-delete 'fallback? result))))
+        (option '("no-substitutes") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'substitutes? #f
+                              (alist-delete 'substitutes? result))))
+        (option '("max-silent-time") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'max-silent-time (string->number* arg)
+                              result)))
+        (option '(#\r "root") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'gc-root arg result)))
+        (option '("verbosity") #t #f
+                (lambda (opt name arg result)
+                  (let ((level (string->number arg)))
+                    (alist-cons 'verbosity level
+                                (alist-delete 'verbosity result)))))))
+
+(define (options->derivations+files store opts)
+  "Given OPTS, the result of 'args-fold', return a list of derivations to
+build and a list of store files to transfer."
+  (define package->derivation
+    (match (assoc-ref opts 'target)
+      (#f package-derivation)
+      (triplet
+       (cut package-cross-derivation <> <> triplet <>))))
+
+  (define src? (assoc-ref opts 'source?))
+  (define sys  (assoc-ref opts 'system))
+
+  (fold2 (lambda (arg derivations files)
+           (match arg
+             (('expression . str)
+              (let ((drv (derivation-from-expression store str
+                                                     package->derivation
+                                                     sys src?)))
+                (values (cons drv derivations)
+                        (cons (derivation->output-path drv) files))))
+             (('argument . (? store-path? file))
+              (values derivations (cons file files)))
+             (('argument . (? string? spec))
+              (let-values (((p output)
+                            (specification->package+output spec)))
+                (if src?
+                    (let* ((s   (package-source p))
+                           (drv (package-source-derivation store s)))
+                      (values (cons drv derivations)
+                              (cons (derivation->output-path drv)
+                                    files)))
+                    (let ((drv (package->derivation store p sys)))
+                      (values (cons drv derivations)
+                              (cons (derivation->output-path drv output)
+                                    files))))))
+             (_
+              (values derivations files))))
+         '()
+         '()
+         opts))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (export-from-store store opts)
+  "Export the packages or derivations specified in OPTS from STORE.  Write the
+resulting archive to the standard output port."
+  (let-values (((drv files)
+                (options->derivations+files store opts)))
+    (show-what-to-build store drv
+                        #:use-substitutes? (assoc-ref opts 'substitutes?)
+                        #:dry-run? (assoc-ref opts 'dry-run?))
+
+    (set-build-options store
+                       #:build-cores (or (assoc-ref opts 'cores) 0)
+                       #:fallback? (assoc-ref opts 'fallback?)
+                       #:use-substitutes? (assoc-ref opts 'substitutes?)
+                       #:max-silent-time (assoc-ref opts 'max-silent-time))
+
+    (if (or (assoc-ref opts 'dry-run?)
+            (build-derivations store drv))
+        (export-paths store files (current-output-port))
+        (leave (_ "unable to export the given packages~%")))))
+
+(define (generate-key-pair parameters)
+  "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the
+right place."
+  (when (or (file-exists? %public-key-file)
+            (file-exists? %private-key-file))
+    (leave (_ "key pair exists under '~a'; remove it first~%")
+           (dirname %public-key-file)))
+
+  (format (current-error-port)
+          (_ "Please wait while gathering entropy to generate the key pair;
+this may take time...~%"))
+
+  (let* ((pair   (catch 'gcry-error
+                   (lambda ()
+                     (generate-key parameters))
+                   (lambda (key err)
+                     (leave (_ "key generation failed: ~a: ~a~%")
+                            (error-source err)
+                            (error-string err)))))
+         (public (find-sexp-token pair 'public-key))
+         (secret (find-sexp-token pair 'private-key)))
+    ;; Create the following files as #o400.
+    (umask #o266)
+
+    (mkdir-p (dirname %public-key-file))
+    (with-atomic-file-output %public-key-file
+      (lambda (port)
+        (display (canonical-sexp->string public) port)))
+    (with-atomic-file-output %private-key-file
+      (lambda (port)
+        (display (canonical-sexp->string secret) port)))
+
+    ;; Make the public key readable by everyone.
+    (chmod %public-key-file #o444)))
+
+(define (authorize-key)
+  "Authorize imports signed by the public key passed as an advanced sexp on
+the input port."
+  (define (read-key)
+    (catch 'gcry-error
+      (lambda ()
+        (string->canonical-sexp (get-string-all (current-input-port))))
+      (lambda (key err)
+        (leave (_ "failed to read public key: ~a: ~a~%")
+               (error-source err) (error-string err)))))
+
+  (let ((key (read-key))
+        (acl (current-acl)))
+    (unless (eq? 'public-key (canonical-sexp-nth-data key 0))
+      (leave (_ "s-expression does not denote a public key~%")))
+
+    ;; Add KEY to the ACL and write that.
+    (let ((acl (public-keys->acl (cons key (acl->public-keys acl)))))
+      (with-atomic-file-output %acl-file
+        (lambda (port)
+          (display (canonical-sexp->string acl) port))))))
+
+(define (guix-archive . 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))
+
+  (define (lines port)
+    ;; Return lines read from PORT.
+    (let loop ((line   (read-line port))
+               (result '()))
+      (if (eof-object? line)
+          (reverse result)
+          (loop (read-line port)
+                (cons line result)))))
+
+  (with-error-handling
+    ;; Ask for absolute file names so that .drv file names passed from the
+    ;; user to 'read-derivation' are absolute when it returns.
+    (with-fluids ((%file-port-name-canonicalization 'absolute))
+      (let ((opts (parse-options)))
+        (cond ((assoc-ref opts 'generate-key)
+               =>
+               generate-key-pair)
+              ((assoc-ref opts 'authorize)
+               (authorize-key))
+              (else
+               (let ((store (open-connection)))
+                 (cond ((assoc-ref opts 'export)
+                        (export-from-store store opts))
+                       ((assoc-ref opts 'import)
+                        (import-paths store (current-input-port)))
+                       ((assoc-ref opts 'missing)
+                        (let* ((files   (lines (current-input-port)))
+                               (missing (remove (cut valid-path? store <>)
+                                                files)))
+                          (format #t "~{~a~%~}" missing)))
+                       (else
+                        (leave
+                         (_ "either '--export' or '--import' \
+must be specified~%")))))))))))
diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm
new file mode 100644
index 0000000000..c7a14f7a8b
--- /dev/null
+++ b/guix/scripts/authenticate.scm
@@ -0,0 +1,101 @@
+;;; 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 authenticate)
+  #:use-module (guix config)
+  #:use-module (guix utils)
+  #:use-module (guix pk-crypto)
+  #:use-module (guix pki)
+  #:use-module (guix ui)
+  #:use-module (rnrs io ports)
+  #:use-module (ice-9 match)
+  #:export (guix-authenticate))
+
+;;; Commentary:
+;;;
+;;; This program is used internally by the daemon to sign exported archive
+;;; (the 'export-paths' RPC), and to authenticate imported archives (the
+;;; 'import-paths' RPC.)
+;;;
+;;; Code:
+
+(define (read-canonical-sexp file)
+  "Read a gcrypt sexp from FILE and return it."
+  (call-with-input-file file
+    (compose string->canonical-sexp get-string-all)))
+
+(define (read-hash-data file)
+  "Read sha256 hash data from FILE and return it as a gcrypt sexp."
+  (let* ((hex (call-with-input-file file get-string-all))
+         (bv  (base16-string->bytevector (string-trim-both hex))))
+    (bytevector->hash-data bv)))
+
+
+;;;
+;;; Entry point with 'openssl'-compatible interface.  We support this
+;;; interface because that's what the daemon expects, and we want to leave it
+;;; unmodified currently.
+;;;
+
+(define (guix-authenticate . args)
+  (match args
+    (("rsautl" "-sign" "-inkey" key "-in" hash-file)
+     ;; Sign the hash in HASH-FILE with KEY, and return an sexp that includes
+     ;; both the hash and the actual signature.
+     (let* ((secret-key (read-canonical-sexp key))
+            (public-key (if (string-suffix? ".sec" key)
+                            (read-canonical-sexp
+                             (string-append (string-drop-right key 4) ".pub"))
+                            (leave
+                             (_ "cannot find public key for secret key '~a'~%")
+                             key)))
+            (data       (read-hash-data hash-file))
+            (signature  (signature-sexp data secret-key public-key)))
+       (display (canonical-sexp->string signature))
+       #t))
+    (("rsautl" "-verify" "-inkey" _ "-pubin" "-in" signature-file)
+     ;; Read the signature as produced above, check whether its public key is
+     ;; authorized, and verify the signature, and print the signed data to
+     ;; stdout upon success.
+     (let* ((sig+data   (read-canonical-sexp signature-file))
+            (public-key (find-sexp-token sig+data 'public-key))
+            (data       (find-sexp-token sig+data 'data))
+            (signature  (find-sexp-token sig+data 'sig-val)))
+       (if (and data signature)
+           (if (authorized-key? public-key)
+               (if (verify signature data public-key)
+                   (begin
+                     (display (bytevector->base16-string
+                               (hash-data->bytevector data)))
+                     #t)                          ; success
+                   (leave (_ "error: invalid signature: ~a~%")
+                          (canonical-sexp->string signature)))
+               (leave (_ "error: unauthorized public key: ~a~%")
+                      (canonical-sexp->string public-key)))
+           (leave (_ "error: corrupt signature data: ~a~%")
+                  (canonical-sexp->string sig+data)))))
+    (("--help")
+     (display (_ "Usage: guix authenticate OPTION...
+Sign or verify the signature on the given file.  This tool is meant to
+be used internally by 'guix-daemon'.\n")))
+    (("--version")
+     (show-version-and-exit "guix authenticate"))
+    (else
+     (leave (_ "wrong arguments")))))
+
+;;; authenticate.scm ends here
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index dd9a9b8127..7cb3710853 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -32,14 +32,11 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
-  #:autoload   (gnu packages) (find-packages-by-name
-                               find-newest-available-packages)
-  #:export (guix-build))
+  #:autoload   (gnu packages) (find-best-packages-by-name)
+  #:export (derivation-from-expression
+            guix-build))
 
-(define %store
-  (make-parameter #f))
-
-(define (derivation-from-expression str package-derivation
+(define (derivation-from-expression store str package-derivation
                                     system source?)
   "Read/eval STR and return the corresponding derivation path for SYSTEM.
 When SOURCE? is true and STR evaluates to a package, return the derivation of
@@ -50,12 +47,57 @@ derivation of a package."
      (if source?
          (let ((source (package-source p)))
            (if source
-               (package-source-derivation (%store) source)
+               (package-source-derivation store source)
                (leave (_ "package `~a' has no source~%")
                       (package-name p))))
-         (package-derivation (%store) p system)))
+         (package-derivation store p system)))
     ((? procedure? proc)
-     (run-with-store (%store) (proc) #:system system))))
+     (run-with-store store (proc) #:system system))))
+
+(define (specification->package spec)
+  "Return a package matching SPEC.  SPEC may be a package name, or a package
+name followed by a hyphen and a version number.  If the version number is not
+present, return the preferred newest version."
+  (let-values (((name version)
+                (package-name->name+version spec)))
+    (match (find-best-packages-by-name name version)
+      ((p)                                      ; one match
+       p)
+      ((p x ...)                                ; several matches
+       (warning (_ "ambiguous package specification `~a'~%") spec)
+       (warning (_ "choosing ~a from ~a~%")
+                (package-full-name p)
+                (location->string (package-location p)))
+       p)
+      (_                                        ; no matches
+       (if version
+           (leave (_ "~A: package not found for version ~a~%")
+                  name version)
+           (leave (_ "~A: unknown package~%") name))))))
+
+(define (register-root store paths root)
+  "Register ROOT as an indirect GC root for all of PATHS."
+  (let* ((root (string-append (canonicalize-path (dirname root))
+                              "/" root)))
+    (catch 'system-error
+      (lambda ()
+        (match paths
+          ((path)
+           (symlink path root)
+           (add-indirect-root store root))
+          ((paths ...)
+           (fold (lambda (path count)
+                   (let ((root (string-append root
+                                              "-"
+                                              (number->string count))))
+                     (symlink path root)
+                     (add-indirect-root store root))
+                   (+ 1 count))
+                 0
+                 paths))))
+      (lambda args
+        (leave (_ "failed to create GC root `~a': ~a~%")
+               root (strerror (system-error-errno args)))))))
 
 
 ;;;
@@ -66,6 +108,7 @@ derivation of a package."
   ;; Alist of default option values.
   `((system . ,(%current-system))
     (substitutes? . #t)
+    (build-hook? . #t)
     (max-silent-time . 3600)
     (verbosity . 0)))
 
@@ -91,6 +134,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
   (display (_ "
       --no-substitutes   build instead of resorting to pre-built substitutes"))
   (display (_ "
+      --no-build-hook    do not attempt to offload builds via the build hook"))
+  (display (_ "
       --max-silent-time=SECONDS
                          mark the build as failed after SECONDS of silence"))
   (display (_ "
@@ -157,6 +202,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
                 (lambda (opt name arg result)
                   (alist-cons 'substitutes? #f
                               (alist-delete 'substitutes? result))))
+        (option '("no-build-hook") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-hook? #f
+                              (alist-delete 'build-hook? result))))
         (option '("max-silent-time") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'max-silent-time (string->number* arg)
@@ -173,6 +222,36 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
                 (lambda (opt name arg result)
                   (alist-cons 'log-file? #t result)))))
 
+(define (options->derivations store opts)
+  "Given OPTS, the result of 'args-fold', return a list of derivations to
+build."
+  (define package->derivation
+    (match (assoc-ref opts 'target)
+      (#f package-derivation)
+      (triplet
+       (cut package-cross-derivation <> <> triplet <>))))
+
+  (define src? (assoc-ref opts 'source?))
+  (define sys  (assoc-ref opts 'system))
+
+  (filter-map (match-lambda
+               (('expression . str)
+                (derivation-from-expression store str package->derivation
+                                            sys src?))
+               (('argument . (? derivation-path? drv))
+                (call-with-input-file drv read-derivation))
+               (('argument . (? store-path?))
+                ;; Nothing to do; maybe for --log-file.
+                #f)
+               (('argument . (? string? x))
+                (let ((p (specification->package x)))
+                  (if src?
+                      (let ((s (package-source p)))
+                        (package-source-derivation store s))
+                      (package->derivation store p sys))))
+               (_ #f))
+              opts))
+
 
 ;;;
 ;;; Entry point.
@@ -188,146 +267,66 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
                   (alist-cons 'argument arg result))
                 %default-options))
 
-  (define (register-root paths root)
-    ;; Register ROOT as an indirect GC root for all of PATHS.
-    (let* ((root (string-append (canonicalize-path (dirname root))
-                                "/" root)))
-     (catch 'system-error
-       (lambda ()
-         (match paths
-           ((path)
-            (symlink path root)
-            (add-indirect-root (%store) root))
-           ((paths ...)
-            (fold (lambda (path count)
-                    (let ((root (string-append root
-                                               "-"
-                                               (number->string count))))
-                      (symlink path root)
-                      (add-indirect-root (%store) root))
-                    (+ 1 count))
-                  0
-                  paths))))
-       (lambda args
-         (leave (_ "failed to create GC root `~a': ~a~%")
-                root (strerror (system-error-errno args)))))))
-
-  (define newest-available-packages
-    (memoize find-newest-available-packages))
-
-  (define (find-best-packages-by-name name version)
-    (if version
-        (find-packages-by-name name version)
-        (match (vhash-assoc name (newest-available-packages))
-          ((_ version pkgs ...) pkgs)
-          (#f '()))))
-
-  (define (find-package request)
-    ;; Return a package matching REQUEST.  REQUEST may be a package
-    ;; name, or a package name followed by a hyphen and a version
-    ;; number.  If the version number is not present, return the
-    ;; preferred newest version.
-    (let-values (((name version)
-                  (package-name->name+version request)))
-      (match (find-best-packages-by-name name version)
-        ((p)                                      ; one match
-         p)
-        ((p x ...)                                ; several matches
-         (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
-             (leave (_ "~A: package not found for version ~a~%")
-                    name version)
-             (leave (_ "~A: unknown package~%") name))))))
-
   (with-error-handling
     ;; Ask for absolute file names so that .drv file names passed from the
     ;; user to 'read-derivation' are absolute when it returns.
     (with-fluids ((%file-port-name-canonicalization 'absolute))
-      (let ((opts (parse-options)))
-        (define package->derivation
-          (match (assoc-ref opts 'target)
-            (#f package-derivation)
-            (triplet
-             (cut package-cross-derivation <> <> triplet <>))))
-
-        (parameterize ((%store (open-connection)))
-          (let* ((src? (assoc-ref opts 'source?))
-                 (sys  (assoc-ref opts 'system))
-                 (drv  (filter-map (match-lambda
-                                    (('expression . str)
-                                     (derivation-from-expression
-                                      str package->derivation sys src?))
-                                    (('argument . (? derivation-path? drv))
-                                     (call-with-input-file drv read-derivation))
-                                    (('argument . (? store-path?))
-                                     ;; Nothing to do; maybe for --log-file.
-                                     #f)
-                                    (('argument . (? string? x))
-                                     (let ((p (find-package x)))
-                                       (if src?
-                                           (let ((s (package-source p)))
-                                             (package-source-derivation
-                                              (%store) s))
-                                           (package->derivation (%store) p sys))))
-                                    (_ #f))
-                                   opts))
-                 (roots (filter-map (match-lambda
-                                     (('gc-root . root) root)
-                                     (_ #f))
-                                    opts)))
+      (let* ((opts  (parse-options))
+             (store (open-connection))
+             (drv   (options->derivations store opts))
+             (roots (filter-map (match-lambda
+                                 (('gc-root . root) root)
+                                 (_ #f))
+                                opts)))
 
-            (unless (assoc-ref opts 'log-file?)
-              (show-what-to-build (%store) drv
-                                  #:use-substitutes? (assoc-ref opts 'substitutes?)
-                                  #:dry-run? (assoc-ref opts 'dry-run?)))
+        (unless (assoc-ref opts 'log-file?)
+          (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)
-                               #:keep-failed? (assoc-ref opts 'keep-failed?)
-                               #:build-cores (or (assoc-ref opts 'cores) 0)
-                               #:fallback? (assoc-ref opts 'fallback?)
-                               #:use-substitutes? (assoc-ref opts 'substitutes?)
-                               #:max-silent-time (assoc-ref opts 'max-silent-time)
-                               #:verbosity (assoc-ref opts 'verbosity))
+        ;; TODO: Add more options.
+        (set-build-options store
+                           #:keep-failed? (assoc-ref opts 'keep-failed?)
+                           #:build-cores (or (assoc-ref opts 'cores) 0)
+                           #:fallback? (assoc-ref opts 'fallback?)
+                           #:use-substitutes? (assoc-ref opts 'substitutes?)
+                           #:use-build-hook? (assoc-ref opts 'build-hook?)
+                           #:max-silent-time (assoc-ref opts 'max-silent-time)
+                           #:verbosity (assoc-ref opts 'verbosity))
 
-            (cond ((assoc-ref opts 'log-file?)
-                   (for-each (lambda (file)
-                               (let ((log (log-file (%store) file)))
-                                 (if log
-                                     (format #t "~a~%" log)
-                                     (leave (_ "no build log for '~a'~%")
-                                            file))))
-                             (delete-duplicates
-                              (append (map derivation-file-name drv)
-                                      (filter-map (match-lambda
-                                                   (('argument
-                                                     . (? store-path? file))
-                                                    file)
-                                                   (_ #f))
-                                                  opts)))))
-                  ((assoc-ref opts 'derivations-only?)
-                   (format #t "~{~a~%~}" (map derivation-file-name drv))
-                   (for-each (cut register-root <> <>)
-                             (map (compose list derivation-file-name) drv)
-                             roots))
-                  ((not (assoc-ref opts 'dry-run?))
-                   (and (build-derivations (%store) drv)
-                        (for-each (lambda (d)
-                                    (format #t "~{~a~%~}"
-                                            (map (match-lambda
-                                                  ((out-name . out)
-                                                   (derivation->output-path
-                                                    d out-name)))
-                                                 (derivation-outputs d))))
-                                  drv)
-                        (for-each (cut register-root <> <>)
-                                  (map (lambda (drv)
-                                         (map cdr
-                                              (derivation->output-paths drv)))
-                                       drv)
-                                  roots))))))))))
+        (cond ((assoc-ref opts 'log-file?)
+               (for-each (lambda (file)
+                           (let ((log (log-file store file)))
+                             (if log
+                                 (format #t "~a~%" log)
+                                 (leave (_ "no build log for '~a'~%")
+                                        file))))
+                         (delete-duplicates
+                          (append (map derivation-file-name drv)
+                                  (filter-map (match-lambda
+                                               (('argument
+                                                 . (? store-path? file))
+                                                file)
+                                               (_ #f))
+                                              opts)))))
+              ((assoc-ref opts 'derivations-only?)
+               (format #t "~{~a~%~}" (map derivation-file-name drv))
+               (for-each (cut register-root store <> <>)
+                         (map (compose list derivation-file-name) drv)
+                         roots))
+              ((not (assoc-ref opts 'dry-run?))
+               (and (build-derivations store drv)
+                    (for-each (lambda (d)
+                                (format #t "~{~a~%~}"
+                                        (map (match-lambda
+                                              ((out-name . out)
+                                               (derivation->output-path
+                                                d out-name)))
+                                             (derivation-outputs d))))
+                              drv)
+                    (for-each (cut register-root store <> <>)
+                              (map (lambda (drv)
+                                     (map cdr
+                                          (derivation->output-paths drv)))
+                                   drv)
+                              roots))))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 49fa457a9c..04393abc9a 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;;
@@ -41,7 +41,8 @@
   #:use-module ((gnu packages base) #:select (guile-final))
   #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
   #:use-module (guix gnu-maintenance)
-  #:export (guix-package))
+  #:export (specification->package+output
+            guix-package))
 
 (define %store
   (make-parameter #f))
@@ -56,7 +57,7 @@
          (cut string-append <> "/.guix-profile")))
 
 (define %profile-directory
-  (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/"
+  (string-append %state-directory "/profiles/"
                  (or (and=> (getenv "USER")
                             (cut string-append "per-user/" <>))
                      "default")))
@@ -292,21 +293,24 @@ return its return value."
        (format (current-error-port) "  interrupted by signal ~a~%" SIGINT)
        #f))))
 
-(define newest-available-packages
-  (memoize find-newest-available-packages))
-
-(define (find-best-packages-by-name name version)
-  "If version is #f, return the list of packages named NAME with the highest
-version numbers; otherwise, return the list of packages named NAME and at
-VERSION."
-  (if version
-      (find-packages-by-name name version)
-      (match (vhash-assoc name (newest-available-packages))
-        ((_ version pkgs ...) pkgs)
-        (#f '()))))
+(define-syntax-rule (leave-on-EPIPE exp ...)
+  "Run EXP... in a context when EPIPE errors are caught and lead to 'exit'
+with successful exit code.  This is useful when writing to the standard output
+may lead to EPIPE, because the standard output is piped through 'head' or
+similar."
+  (catch 'system-error
+    (lambda ()
+      exp ...)
+    (lambda args
+      ;; We really have to exit this brutally, otherwise Guile eventually
+      ;; attempts to flush all the ports, leading to an uncaught EPIPE down
+      ;; the path.
+      (if (= EPIPE (system-error-errno args))
+          (primitive-_exit 0)
+          (apply throw args)))))
 
 (define* (specification->package+output spec #:optional (output "out"))
-  "Find the package and output specified by SPEC, or #f and #f; SPEC may
+  "Return the package and output specified by SPEC, or #f and #f; SPEC may
 optionally contain a version number and an output name, as in these examples:
 
   guile
@@ -342,7 +346,7 @@ version; if SPEC does not specify an output, return OUTPUT."
   "Return #t if there's a version of package NAME newer than CURRENT-VERSION,
 or if the newest available version is equal to CURRENT-VERSION but would have
 an output path different than CURRENT-PATH."
-  (match (vhash-assoc name (newest-available-packages))
+  (match (vhash-assoc name (find-newest-available-packages))
     ((_ candidate-version pkg . rest)
      (case (version-compare candidate-version current-version)
        ((>) #t)
@@ -970,15 +974,17 @@ more information.~%"))
                        profile))
                ((string-null? pattern)
                 (let ((numbers (generation-numbers profile)))
-                  (if (equal? numbers '(0))
-                      (exit 0)
-                      (for-each list-generation numbers))))
+                  (leave-on-EPIPE
+                   (if (equal? numbers '(0))
+                       (exit 0)
+                       (for-each list-generation numbers)))))
                ((matching-generations pattern profile)
                 =>
                 (lambda (numbers)
                   (if (null-list? numbers)
                       (exit 1)
-                      (for-each list-generation numbers))))
+                      (leave-on-EPIPE
+                       (for-each list-generation numbers)))))
                (else
                 (leave (_ "invalid syntax: ~a~%")
                        pattern)))
@@ -988,15 +994,16 @@ more information.~%"))
          (let* ((regexp    (and regexp (make-regexp regexp)))
                 (manifest  (profile-manifest profile))
                 (installed (manifest-entries manifest)))
-           (for-each (match-lambda
-                      (($ <manifest-entry> name version output path _)
-                       (when (or (not regexp)
-                                 (regexp-exec regexp name))
-                         (format #t "~a\t~a\t~a\t~a~%"
-                                 name (or version "?") output path))))
-
-                     ;; Show most recently installed packages last.
-                     (reverse installed))
+           (leave-on-EPIPE
+            (for-each (match-lambda
+                       (($ <manifest-entry> name version output path _)
+                        (when (or (not regexp)
+                                  (regexp-exec regexp name))
+                          (format #t "~a\t~a\t~a\t~a~%"
+                                  name (or version "?") output path))))
+
+                      ;; Show most recently installed packages last.
+                      (reverse installed)))
            #t))
 
         (('list-available regexp)
@@ -1010,16 +1017,17 @@ more information.~%"))
                                         r)
                                     (cons p r))))
                             '())))
-           (for-each (lambda (p)
-                       (format #t "~a\t~a\t~a\t~a~%"
-                               (package-name p)
-                               (package-version p)
-                               (string-join (package-outputs p) ",")
-                               (location->string (package-location p))))
-                     (sort available
-                           (lambda (p1 p2)
-                             (string<? (package-name p1)
-                                       (package-name p2)))))
+           (leave-on-EPIPE
+            (for-each (lambda (p)
+                        (format #t "~a\t~a\t~a\t~a~%"
+                                (package-name p)
+                                (package-version p)
+                                (string-join (package-outputs p) ",")
+                                (location->string (package-location p))))
+                      (sort available
+                            (lambda (p1 p2)
+                              (string<? (package-name p1)
+                                        (package-name p2))))))
            #t))
 
         (('search regexp)
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 0da29d435b..901b3fb064 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -72,21 +72,6 @@
   ;; 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
-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))))))
-
 ;; In Guile 2.0.9, `regexp-exec' is thread-unsafe, so work around it.
 ;; See <http://bugs.gnu.org/14404>.
 (set! regexp-exec
@@ -594,7 +579,6 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
 
 
 ;;; Local Variables:
-;;; eval: (put 'with-atomic-file-output 'scheme-indent-function 1)
 ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
 ;;; End:
 
diff --git a/guix/store.scm b/guix/store.scm
index 08b0671b29..1012480b39 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -80,6 +80,8 @@
             dead-paths
             collect-garbage
             delete-paths
+            import-paths
+            export-paths
 
             current-build-output-port
 
@@ -156,8 +158,7 @@
   (delete-specific 3))
 
 (define %default-socket-path
-  (string-append (or (getenv "NIX_STATE_DIR") %state-directory)
-                 "/daemon-socket/socket"))
+  (string-append %state-directory "/daemon-socket/socket"))
 
 (define %daemon-socket-file
   ;; File name of the socket the daemon listens too.
@@ -323,7 +324,30 @@ operate, should the disk become full.  Return a server object."
   ;; The port where build output is sent.
   (make-parameter (current-error-port)))
 
-(define (process-stderr server)
+(define* (dump-port in out
+                    #:optional len
+                    #:key (buffer-size 16384))
+  "Read LEN bytes from IN (or as much as possible if LEN is #f) and write it
+to OUT, using chunks of BUFFER-SIZE bytes."
+  (define buffer
+    (make-bytevector buffer-size))
+
+  (let loop ((total 0)
+             (bytes (get-bytevector-n! in buffer 0
+                                       (if len
+                                           (min len buffer-size)
+                                           buffer-size))))
+    (or (eof-object? bytes)
+        (and len (= total len))
+        (let ((total (+ total bytes)))
+          (put-bytevector out buffer 0 bytes)
+          (loop total
+                (get-bytevector-n! in buffer 0
+                                   (if len
+                                       (min (- len total) buffer-size)
+                                       buffer-size)))))))
+
+(define* (process-stderr server #:optional user-port)
   "Read standard output and standard error from SERVER, writing it to
 CURRENT-BUILD-OUTPUT-PORT.  Return #t when SERVER is done sending data, and
 #f otherwise; in the latter case, the caller should call `process-stderr'
@@ -344,17 +368,30 @@ encoding conversion errors."
 
   (let ((k (read-int p)))
     (cond ((= k %stderr-write)
-           (read-latin1-string p)
+           ;; Write a byte stream to USER-PORT.
+           (let* ((len (read-int p))
+                  (m   (modulo len 8)))
+             (dump-port p user-port len)
+             (unless (zero? m)
+               ;; Consume padding, as for strings.
+               (get-bytevector-n p (- 8 m))))
            #f)
           ((= k %stderr-read)
-           (let ((len (read-int p)))
-             (read-latin1-string p)               ; FIXME: what to do?
+           ;; Read a byte stream from USER-PORT.
+           (let* ((max-len (read-int p))
+                  (data    (get-bytevector-n user-port max-len))
+                  (len     (bytevector-length data)))
+             (write-int len p)
+             (put-bytevector p data)
+             (write-padding len p)
              #f))
           ((= k %stderr-next)
+           ;; Log a string.
            (let ((s (read-latin1-string p)))
              (display s (current-build-output-port))
              #f))
           ((= k %stderr-error)
+           ;; Report an error.
            (let ((error  (read-latin1-string p))
                  ;; Currently the daemon fails to send a status code for early
                  ;; errors like DB schema version mismatches, so check for EOF.
@@ -624,6 +661,39 @@ MIN-FREED bytes have been collected.  Return the paths that were
 collected, and the number of bytes freed."
   (run-gc server (gc-action delete-specific) paths min-freed))
 
+(define (import-paths server port)
+  "Import the set of store paths read from PORT into SERVER's store.  An error
+is raised if the set of paths read from PORT is not signed (as per
+'export-path #:sign? #t'.)  Return the list of store paths imported."
+  (let ((s (nix-server-socket server)))
+    (write-int (operation-id import-paths) s)
+    (let loop ((done? (process-stderr server port)))
+      (or done? (loop (process-stderr server port))))
+    (read-store-path-list s)))
+
+(define* (export-path server path port #:key (sign? #t))
+  "Export PATH to PORT.  When SIGN? is true, sign it."
+  (let ((s (nix-server-socket server)))
+    (write-int (operation-id export-path) s)
+    (write-store-path path s)
+    (write-arg boolean sign? s)
+    (let loop ((done? (process-stderr server port)))
+      (or done? (loop (process-stderr server port))))
+    (= 1 (read-int s))))
+
+(define* (export-paths server paths port #:key (sign? #t))
+  "Export the store paths listed in PATHS to PORT, signing them if SIGN?
+is true."
+  (let ((s (nix-server-socket server)))
+    (let loop ((paths paths))
+      (match paths
+        (()
+         (write-int 0 port))
+        ((head tail ...)
+         (write-int 1 port)
+         (and (export-path server head port #:sign? sign?)
+              (loop tail)))))))
+
 
 ;;;
 ;;; Store paths.
@@ -631,8 +701,7 @@ collected, and the number of bytes freed."
 
 (define %store-prefix
   ;; Absolute path to the Nix store.
-  (make-parameter (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
-                      %store-directory)))
+  (make-parameter %store-directory))
 
 (define (store-path? path)
   "Return #t if PATH is a store path."
@@ -678,16 +747,16 @@ syntactically valid store path."
 (define (log-file store file)
   "Return the build log file for FILE, or #f if none could be found.  FILE
 must be an absolute store file name, or a derivation file name."
-  (define state-dir                               ; XXX: factorize
-    (or (getenv "NIX_STATE_DIR") %state-directory))
-
   (cond ((derivation-path? file)
-         (let* ((base (basename file))
-                (log  (string-append (dirname state-dir) ; XXX: ditto
-                                     "/log/nix/drvs/"
-                                     (string-take base 2) "/"
-                                     (string-drop base 2) ".bz2")))
-           (and (file-exists? log) log)))
+         (let* ((base    (basename file))
+                (log     (string-append (dirname %state-directory) ; XXX
+                                        "/log/nix/drvs/"
+                                        (string-take base 2) "/"
+                                        (string-drop base 2)))
+                (log.bz2 (string-append log ".bz2")))
+           (cond ((file-exists? log.bz2) log.bz2)
+                 ((file-exists? log) log)
+                 (else #f))))
         (else
          (match (valid-derivers store file)
            ((derivers ...)
diff --git a/guix/utils.scm b/guix/utils.scm
index b730340eda..04a74ee29a 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -67,6 +67,7 @@
             file-extension
             file-sans-extension
             call-with-temporary-output-file
+            with-atomic-file-output
             fold2
             filtered-port))
 
@@ -426,6 +427,21 @@ call."
         (false-if-exception (close out))
         (false-if-exception (delete-file template))))))
 
+(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 fold2
   (case-lambda
     ((proc seed1 seed2 lst)