Merge branch 'master' into core-updates

14 files changed, 564 insertions, 269 deletions

diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm
index 80ce679496..9a8ea0ed4f 100644
--- a/guix/build/linux-initrd.scm
+++ b/guix/build/linux-initrd.scm
@@ -114,6 +114,14 @@
                   (device-number 4 n))
            (loop (+ 1 n)))))
 
+  ;; Pseudo ttys.
+  (mknod (scope "dev/ptmx") 'char-special #o666
+         (device-number 5 2))
+
+  (unless (file-exists? (scope "dev/pts"))
+    (mkdir (scope "dev/pts")))
+  (mount "none" (scope "dev/pts") "devpts")
+
   ;; Rendez-vous point for syslogd.
   (mknod (scope "dev/log") 'socket #o666 0)
   (mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11))
diff --git a/guix/config.scm.in b/guix/config.scm.in
index 5edb4ced30..eaadae9618 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -57,7 +57,7 @@
 
 (define %state-directory
   ;; This must match `NIX_STATE_DIR' as defined in `daemon.am'.
-  (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/nix"))
+  (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/guix"))
 
 (define %config-directory
   ;; This must match `NIX_CONF_DIR' as defined in `daemon.am'.
diff --git a/guix/download.scm b/guix/download.scm
index 2cc8a4a5b8..0889928d3a 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -242,7 +242,11 @@ must be a list of symbol/URL-list pairs."
                                               (guix build utils)
                                               (guix ftp-client))
                                   #:guile-for-build guile-for-build
-                                  #:env-vars env-vars)))
+                                  #:env-vars env-vars
+
+                                  ;; In general, offloading downloads is not a
+                                  ;; good idea.
+                                  #:local-build? #t)))
 
 (define* (download-to-store store url #:optional (name (basename url))
                             #:key (log (current-error-port)))
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 472bf756ce..5e0a6a21dc 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -84,6 +84,7 @@ type HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if
                                   #:recursive? #t
                                   #:modules '((guix build git)
                                               (guix build utils))
-                                  #:guile-for-build guile-for-build)))
+                                  #:guile-for-build guile-for-build
+                                  #:local-build? #t)))
 
 ;;; git-download.scm ends here
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 98432a69ce..14195da7ba 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -275,6 +275,10 @@ open (resp. close) FTP connections; this can be useful to reuse connections."
   (define contains-digit?
     (cut string-any char-set:digit <>))
 
+  (define patch-directory-name?
+    ;; Return #t for patch directory names such as 'bash-4.2-patches'.
+    (cut string-suffix? "patches" <>))
+
   (let-values (((server directory) (ftp-server/directory project)))
     (define conn (ftp-open server))
 
@@ -284,6 +288,9 @@ open (resp. close) FTP connections; this can be useful to reuse connections."
              ;; Filter out sub-directories that do not contain digits---e.g.,
              ;; /gnuzilla/lang and /gnupg/patches.
              (subdirs (filter-map (match-lambda
+                                   (((? patch-directory-name? dir)
+                                     'directory . _)
+                                    #f)
                                    (((? contains-digit? dir) 'directory . _)
                                     dir)
                                    (_ #f))
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 11231cbc1e..1f05df4b05 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.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 © 2012 Free Software Foundation, Inc.
 ;;;
 ;;; This file is part of GNU Guix.
@@ -23,19 +23,36 @@
   #:use-module (web client)
   #:use-module (web response)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (guix ui)
   #:use-module (guix utils)
-  #:export (open-socket-for-uri
+  #:export (&http-get-error
+            http-get-error?
+            http-get-error-uri
+            http-get-error-code
+            http-get-error-reason
+
+            open-socket-for-uri
             http-fetch))
 
 ;;; Commentary:
 ;;;
-;;; HTTP client portable among Guile versions.
+;;; HTTP client portable among Guile versions, and with proper error condition
+;;; reporting.
 ;;;
 ;;; Code:
 
+;; HTTP GET error.
+(define-condition-type &http-get-error &error
+  http-get-error?
+  (uri    http-get-error-uri)                     ; URI
+  (code   http-get-error-code)                    ; integer
+  (reason http-get-error-reason))                 ; string
+
+
 (define-syntax when-guile<=2.0.5
   (lambda (s)
     (syntax-case s ()
@@ -154,7 +171,9 @@ unbuffered."
   "Return an input port containing the data at URI, and the expected number of
 bytes available or #f.  If TEXT? is true, the data at URI is considered to be
 textual.  Follow any HTTP redirection.  When BUFFERED? is #f, return an
-unbuffered port, suitable for use in `filtered-port'."
+unbuffered port, suitable for use in `filtered-port'.
+
+Raise an '&http-get-error' condition if downloading fails."
   (let loop ((uri uri))
     (let ((port (or port
                     (open-socket-for-uri uri
@@ -202,7 +221,11 @@ unbuffered port, suitable for use in `filtered-port'."
                      (uri->string uri))
              (loop uri)))
           (else
-           (error "download failed" uri code
-                  (response-reason-phrase resp))))))))
+           (raise (condition (&http-get-error
+                              (uri uri)
+                              (code code)
+                              (reason (response-reason-phrase resp)))
+                             (&message
+                              (message "download failed"))))))))))
 
 ;;; http-client.scm ends here
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 4788468584..8280a821c5 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -64,6 +64,9 @@ Export/import one or more packages from/to the store.\n"))
       --generate-key[=PARAMETERS]
                          generate a key pair with the given parameters"))
   (display (_ "
+      --authorize        authorize imports signed by the public key on stdin"))
+  (newline)
+  (display (_ "
   -e, --expression=EXPR  build the package or derivation EXPR evaluates to"))
   (display (_ "
   -S, --source           build the packages' source derivations"))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 4a00505022..618015e9ba 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -127,6 +127,8 @@ options handled by 'set-build-options-from-command-line', and listed in
       --max-silent-time=SECONDS
                          mark the build as failed after SECONDS of silence"))
   (display (_ "
+      --timeout=SECONDS  mark the build as failed after SECONDS of activity"))
+  (display (_ "
       --verbosity=LEVEL  use the given verbosity LEVEL"))
   (display (_ "
   -c, --cores=N          allow the use of up to N CPU cores for the build")))
@@ -142,39 +144,57 @@ options handled by 'set-build-options-from-command-line', and listed in
                      #:use-substitutes? (assoc-ref opts 'substitutes?)
                      #:use-build-hook? (assoc-ref opts 'build-hook?)
                      #:max-silent-time (assoc-ref opts 'max-silent-time)
+                     #:timeout (assoc-ref opts 'timeout)
                      #:verbosity (assoc-ref opts 'verbosity)))
 
 (define %standard-build-options
   ;; List of standard command-line options for tools that build something.
   (list (option '(#\K "keep-failed") #f #f
-                (lambda (opt name arg result)
-                  (alist-cons 'keep-failed? #t result)))
+                (lambda (opt name arg result . rest)
+                  (apply values
+                         (alist-cons 'keep-failed? #t result)
+                         rest)))
         (option '("fallback") #f #f
-                (lambda (opt name arg result)
-                  (alist-cons 'fallback? #t
-                              (alist-delete 'fallback? result))))
+                (lambda (opt name arg result . rest)
+                  (apply values
+                         (alist-cons 'fallback? #t
+                                     (alist-delete 'fallback? result))
+                         rest)))
         (option '("no-substitutes") #f #f
-                (lambda (opt name arg result)
-                  (alist-cons 'substitutes? #f
-                              (alist-delete 'substitutes? result))))
+                (lambda (opt name arg result . rest)
+                  (apply values
+                         (alist-cons 'substitutes? #f
+                                     (alist-delete 'substitutes? result))
+                         rest)))
         (option '("no-build-hook") #f #f
-                (lambda (opt name arg result)
-                  (alist-cons 'build-hook? #f
-                              (alist-delete 'build-hook? result))))
+                (lambda (opt name arg result . rest)
+                  (apply values
+                         (alist-cons 'build-hook? #f
+                                     (alist-delete 'build-hook? result))
+                         rest)))
         (option '("max-silent-time") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'max-silent-time (string->number* arg)
-                              result)))
+                (lambda (opt name arg result . rest)
+                  (apply values
+                         (alist-cons 'max-silent-time (string->number* arg)
+                                     result)
+                         rest)))
+        (option '("timeout") #t #f
+                (lambda (opt name arg result . rest)
+                  (apply values
+                         (alist-cons 'timeout (string->number* arg) result)
+                         rest)))
         (option '("verbosity") #t #f
-                (lambda (opt name arg result)
+                (lambda (opt name arg result . rest)
                   (let ((level (string->number arg)))
-                    (alist-cons 'verbosity level
-                                (alist-delete 'verbosity result)))))
+                    (apply values
+                           (alist-cons 'verbosity level
+                                       (alist-delete 'verbosity result))
+                           rest))))
         (option '(#\c "cores") #t #f
-                (lambda (opt name arg result)
+                (lambda (opt name arg result . rest)
                   (let ((c (false-if-exception (string->number arg))))
                     (if c
-                        (alist-cons 'cores c result)
+                        (apply values (alist-cons 'cores c result) rest)
                         (leave (_ "~a: not a number~%") arg)))))))
 
 
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 00a145e5e9..4d2f78f711 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -23,7 +23,7 @@
   #:use-module (guix derivations)
   #:use-module (guix nar)
   #:use-module (guix utils)
-  #:use-module ((guix build utils) #:select (which))
+  #:use-module ((guix build utils) #:select (which mkdir-p))
   #:use-module (guix ui)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -122,38 +122,40 @@ determined."
          (leave (_ "failed to load machine file '~a': ~s~%")
                 file args))))))
 
-(define (open-ssh-gateway machine)
-  "Initiate an SSH connection gateway to MACHINE, and return the PID of the
-running lsh gateway upon success, or #f on failure."
-  (catch 'system-error
-    (lambda ()
-      (let* ((port   (open-pipe* OPEN_READ %lsh-command
-                                 "-l" (build-machine-user machine)
-                                 "-i" (build-machine-private-key machine)
-                                 ;; XXX: With lsh 2.1, passing '--write-pid'
-                                 ;; last causes the PID not to be printed.
-                                 "--write-pid" "--gateway" "--background" "-z"
-                                 (build-machine-name machine)))
-             (line   (read-line port))
-             (status (close-pipe port)))
-       (if (zero? status)
-           (let ((pid (string->number line)))
-             (if (integer? pid)
-                 pid
-                 (begin
-                   (warning (_ "'~a' did not write its PID on stdout: ~s~%")
-                            %lsh-command line)
-                   #f)))
-           (begin
-             (warning (_ "failed to initiate SSH connection to '~a':\
- '~a' exited with ~a~%")
-                      (build-machine-name machine)
-                      %lsh-command
-                      (status:exit-val status))
-             #f))))
-    (lambda args
-      (leave (_ "failed to execute '~a': ~a~%")
-             %lsh-command (strerror (system-error-errno args))))))
+;;; FIXME: The idea was to open the connection to MACHINE once for all, but
+;;; lshg is currently non-functional.
+;; (define (open-ssh-gateway machine)
+;;   "Initiate an SSH connection gateway to MACHINE, and return the PID of the
+;; running lsh gateway upon success, or #f on failure."
+;;   (catch 'system-error
+;;     (lambda ()
+;;       (let* ((port   (open-pipe* OPEN_READ %lsh-command
+;;                                  "-l" (build-machine-user machine)
+;;                                  "-i" (build-machine-private-key machine)
+;;                                  ;; XXX: With lsh 2.1, passing '--write-pid'
+;;                                  ;; last causes the PID not to be printed.
+;;                                  "--write-pid" "--gateway" "--background" "-z"
+;;                                  (build-machine-name machine)))
+;;              (line   (read-line port))
+;;              (status (close-pipe port)))
+;;        (if (zero? status)
+;;            (let ((pid (string->number line)))
+;;              (if (integer? pid)
+;;                  pid
+;;                  (begin
+;;                    (warning (_ "'~a' did not write its PID on stdout: ~s~%")
+;;                             %lsh-command line)
+;;                    #f)))
+;;            (begin
+;;              (warning (_ "failed to initiate SSH connection to '~a':\
+;;  '~a' exited with ~a~%")
+;;                       (build-machine-name machine)
+;;                       %lsh-command
+;;                       (status:exit-val status))
+;;              #f))))
+;;     (lambda args
+;;       (leave (_ "failed to execute '~a': ~a~%")
+;;              %lsh-command (strerror (system-error-errno args))))))
 
 (define (remote-pipe machine mode command)
   "Run COMMAND on MACHINE, assuming an lsh gateway has been set up."
@@ -161,6 +163,10 @@ running lsh gateway upon success, or #f on failure."
     (lambda ()
       (apply open-pipe* mode %lshg-command
              "-l" (build-machine-user machine) "-z"
+
+             ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg.
+             "-i" (build-machine-private-key machine)
+
              (build-machine-name machine)
              command))
     (lambda args
@@ -168,9 +174,89 @@ running lsh gateway upon success, or #f on failure."
                %lshg-command (strerror (system-error-errno args)))
       #f)))
 
+
+;;;
+;;; Synchronization.
+;;;
+
+(define (lock-file file)
+  "Wait and acquire an exclusive lock on FILE.  Return an open port."
+  (mkdir-p (dirname file))
+  (let ((port (open-file file "w0")))
+    (fcntl-flock port 'write-lock)
+    port))
+
+(define (unlock-file lock)
+  "Unlock LOCK."
+  (fcntl-flock lock 'unlock)
+  (close-port lock)
+  #t)
+
+(define-syntax-rule (with-file-lock file exp ...)
+  "Wait to acquire a lock on FILE and evaluate EXP in that context."
+  (let ((port (lock-file file)))
+    (dynamic-wind
+      (lambda ()
+        #t)
+      (lambda ()
+        exp ...)
+      (lambda ()
+        (unlock-file port)))))
+
+(define-syntax-rule (with-machine-lock machine hint exp ...)
+  "Wait to acquire MACHINE's exclusive lock for HINT, and evaluate EXP in that
+context."
+  (with-file-lock (machine-lock-file machine hint)
+    exp ...))
+
+
+(define (machine-slot-file machine slot)
+  "Return the file name of MACHINE's file for SLOT."
+  ;; For each machine we have a bunch of files representing each build slot.
+  ;; When choosing a build machine, we attempt to get an exclusive lock on one
+  ;; of these; if we fail, that means all the build slots are already taken.
+  ;; Inspired by Nix's build-remote.pl.
+  (string-append  (string-append %state-directory "/offload/"
+                                 (build-machine-name machine)
+                                 "/" (number->string slot))))
+
+(define (acquire-build-slot machine)
+  "Attempt to acquire a build slot on MACHINE.  Return the port representing
+the slot, or #f if none is available.
+
+This mechanism allows us to set a hard limit on the number of simultaneous
+connections allowed to MACHINE."
+  (mkdir-p (dirname (machine-slot-file machine 0)))
+  (with-machine-lock machine 'slots
+    (any (lambda (slot)
+           (let ((port (open-file (machine-slot-file machine slot)
+                                  "w0")))
+             (catch 'flock-error
+               (lambda ()
+                 (fcntl-flock port 'write-lock #:wait? #f)
+                 ;; Got it!
+                 (format (current-error-port)
+                         "process ~a acquired build slot '~a'~%"
+                         (getpid) (port-filename port))
+                 port)
+               (lambda args
+                 ;; PORT is already locked by another process.
+                 (close-port port)
+                 #f))))
+         (iota (build-machine-parallel-builds machine)))))
+
+(define (release-build-slot slot)
+  "Release SLOT, a build slot as returned as by 'acquire-build-slot'."
+  (close-port slot))
+
+
+;;;
+;;; Offloading.
+;;;
+
 (define* (offload drv machine
                   #:key print-build-trace? (max-silent-time 3600)
-                  (build-timeout 7200) (log-port (current-output-port)))
+                  build-timeout (log-port (current-output-port)))
   "Perform DRV on MACHINE, assuming DRV and its prerequisites are available
 there, and write the build log to LOG-PORT.  Return the exit status."
   (format (current-error-port) "offloading '~a' to '~a'...~%"
@@ -181,9 +267,12 @@ there, and write the build log to LOG-PORT.  Return the exit status."
   ;; FIXME: Protect DRV from garbage collection on MACHINE.
   (let ((pipe (remote-pipe machine OPEN_READ
                            `("guix" "build"
-                             ;; FIXME: more options
                              ,(format #f "--max-silent-time=~a"
                                       max-silent-time)
+                             ,@(if build-timeout
+                                   (list (format #f "--timeout=~a"
+                                                 build-timeout))
+                                   '())
                              ,(derivation-file-name drv)))))
     (let loop ((line (read-line pipe)))
       (unless (eof-object? line)
@@ -193,6 +282,43 @@ there, and write the build log to LOG-PORT.  Return the exit status."
 
     (close-pipe pipe)))
 
+(define* (transfer-and-offload drv machine
+                               #:key
+                               (inputs '())
+                               (outputs '())
+                               (max-silent-time 3600)
+                               build-timeout
+                               print-build-trace?)
+  "Offload DRV to MACHINE.  Prior to the actual offloading, transfer all of
+INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from
+MACHINE."
+  ;; Acquire MACHINE's exclusive lock to serialize file transfers
+  ;; to/from MACHINE in the presence of several 'offload' hook
+  ;; instance.
+  (when (with-machine-lock machine 'bandwidth
+          (send-files (cons (derivation-file-name drv) inputs)
+                      machine))
+    (let ((status (offload drv machine
+                           #:print-build-trace? print-build-trace?
+                           #:max-silent-time max-silent-time
+                           #:build-timeout build-timeout)))
+      (if (zero? status)
+          (begin
+            ;; Likewise (see above.)
+            (with-machine-lock machine 'bandwidth
+              (retrieve-files outputs machine))
+            (format (current-error-port)
+                    "done with offloaded '~a'~%"
+                    (derivation-file-name drv)))
+          (begin
+            (format (current-error-port)
+                    "derivation '~a' offloaded to '~a' failed \
+with exit code ~a~%"
+                    (derivation-file-name drv)
+                    (build-machine-name machine)
+                    (status:exit-val status))
+            (primitive-exit (status:exit-val status)))))))
+
 (define (send-files files machine)
   "Send the subset of FILES that's missing to MACHINE's store.  Return #t on
 success, #f otherwise."
@@ -256,6 +382,11 @@ success, #f otherwise."
 
              (zero? (close-pipe pipe)))))))
 
+
+;;;
+;;; Scheduling.
+;;;
+
 (define (machine-matches? machine requirements)
   "Return #t if MACHINE matches REQUIREMENTS."
   (and (string=? (build-requirements-system requirements)
@@ -268,57 +399,124 @@ success, #f otherwise."
   "Return #t if M1 is faster than M2."
   (> (build-machine-speed m1) (build-machine-speed m2)))
 
-(define (choose-build-machine requirements machines)
-  "Return the best machine among MACHINES fulfilling REQUIREMENTS, or #f."
-  ;; FIXME: Take machine load into account, and/or shuffle MACHINES.
-  (let ((machines (sort (filter (cut machine-matches? <> requirements)
-                                machines)
-                        machine-faster?)))
-    (match machines
-      ((head . _)
-       head)
-      (_ #f))))
+(define (machine-load machine)
+  "Return the load of MACHINE, divided by the number of parallel builds
+allowed on MACHINE."
+  (let* ((pipe (remote-pipe machine OPEN_READ `("cat" "/proc/loadavg")))
+         (line (read-line pipe)))
+    (close-pipe pipe)
+    (if (eof-object? line)
+        1.
+        (match (string-tokenize line)
+          ((one five fifteen . _)
+           (let* ((raw        (string->number five))
+                  (jobs       (build-machine-parallel-builds machine))
+                  (normalized (/ raw jobs)))
+             (format (current-error-port) "load on machine '~a' is ~s\
+ (normalized: ~s)~%"
+                     (build-machine-name machine) raw normalized)
+             normalized))
+          (_
+           1.)))))
+
+(define (machine-less-loaded? m1 m2)
+  "Return #t if the load on M1 is lower than that on M2."
+  (< (machine-load m1) (machine-load m2)))
+
+(define (machine-less-loaded-or-faster? m1 m2)
+  "Return #t if M1 is either less loaded or faster than M2."
+  (or (machine-less-loaded? m1 m2)
+      (machine-faster? m1 m2)))
+
+(define (machine-lock-file machine hint)
+  "Return the name of MACHINE's lock file for HINT."
+  (string-append %state-directory "/offload/"
+                 (build-machine-name machine)
+                 "." (symbol->string hint) ".lock"))
+
+(define (machine-choice-lock-file)
+  "Return the name of the file used as a lock when choosing a build machine."
+  (string-append %state-directory "/offload/machine-choice.lock"))
+
+
+(define %slots
+  ;; List of acquired build slots (open ports).
+  '())
+
+(define (choose-build-machine machines)
+  "Return the best machine among MACHINES, or #f."
+
+  ;; Proceed like this:
+  ;;   1. Acquire the global machine-choice lock.
+  ;;   2. For all MACHINES, attempt to acquire a build slot, and filter out
+  ;;      those machines for which we failed.
+  ;;   3. Choose the best machine among those that are left.
+  ;;   4. Release the previously-acquired build slots of the other machines.
+  ;;   5. Release the global machine-choice lock.
+
+  (with-file-lock (machine-choice-lock-file)
+    (define machines+slots
+      (filter-map (lambda (machine)
+                    (let ((slot (acquire-build-slot machine)))
+                      (and slot (list machine slot))))
+                  machines))
+
+    (define (undecorate pred)
+      (match-lambda
+       ((machine slot)
+        (and (pred machine)
+             (list machine slot)))))
+
+    (let ((machines+slots (sort machines+slots
+                                (undecorate machine-less-loaded-or-faster?))))
+      (match machines+slots
+        (((best slot) (others slots) ...)
+         ;; Release slots from the uninteresting machines.
+         (for-each release-build-slot slots)
+
+         ;; Return the best machine unless it's already overloaded.
+         (if (< (machine-load best) 2.)
+             (begin
+               ;; Prevent SLOT from being GC'd.
+               (set! %slots (cons slot %slots))
+               best)
+             (begin
+               (release-build-slot slot)
+               #f)))
+        (() #f)))))
 
 (define* (process-request wants-local? system drv features
                           #:key
                           print-build-trace? (max-silent-time 3600)
-                          (build-timeout 7200))
+                          build-timeout)
   "Process a request to build DRV."
-  (let* ((local?  (and wants-local? (string=? system (%current-system))))
-         (reqs    (build-requirements
-                   (system system)
-                   (features features)))
-         (machine (choose-build-machine reqs (build-machines))))
-    (if machine
-        (match (open-ssh-gateway machine)
-          ((? integer? pid)
-           (display "# accept\n")
-           (let ((inputs  (string-tokenize (read-line)))
-                 (outputs (string-tokenize (read-line))))
-             (when (send-files (cons (derivation-file-name drv) inputs)
-                               machine)
-               (let ((status (offload drv machine
-                                      #:print-build-trace? print-build-trace?
-                                      #:max-silent-time max-silent-time
-                                      #:build-timeout build-timeout)))
-                 (kill pid SIGTERM)
-                 (if (zero? status)
-                     (begin
-                       (retrieve-files outputs machine)
-                       (format (current-error-port)
-                               "done with offloaded '~a'~%"
-                               (derivation-file-name drv)))
-                     (begin
-                       (format (current-error-port)
-                               "derivation '~a' offloaded to '~a' failed \
-with exit code ~a~%"
-                               (derivation-file-name drv)
-                               (build-machine-name machine)
-                               (status:exit-val status))
-                       (primitive-exit (status:exit-val status))))))))
-          (#f
-           (display "# decline\n")))
-        (display "# decline\n"))))
+  (let* ((local?     (and wants-local? (string=? system (%current-system))))
+         (reqs       (build-requirements
+                      (system system)
+                      (features features)))
+         (candidates (filter (cut machine-matches? <> reqs)
+                             (build-machines))))
+    (match candidates
+      (()
+       ;; We'll never be able to match REQS.
+       (display "# decline\n"))
+      ((_ ...)
+       (let ((machine (choose-build-machine candidates)))
+         (if machine
+             (begin
+               ;; Offload DRV to MACHINE.
+               (display "# accept\n")
+               (let ((inputs  (string-tokenize (read-line)))
+                     (outputs (string-tokenize (read-line))))
+                 (transfer-and-offload drv machine
+                                       #:inputs inputs
+                                       #:outputs outputs
+                                       #:max-silent-time max-silent-time
+                                       #:build-timeout build-timeout
+                                       #:print-build-trace? print-build-trace?)))
+
+             ;; Not now, all the machines are busy.
+             (display "# postpone\n")))))))
 
 (define-syntax-rule (with-nar-error-handling body ...)
   "Execute BODY with any &nar-error suitably reported to the user."
@@ -388,4 +586,9 @@ This tool is meant to be used internally by 'guix-daemon'.\n"))
     (x
      (leave (_ "invalid arguments: ~{~s ~}~%") x))))
 
+;;; Local Variables:
+;;; eval: (put 'with-machine-lock 'scheme-indent-function 2)
+;;; eval: (put 'with-file-lock 'scheme-indent-function 1)
+;;; End:
+
 ;;; offload.scm ends here
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index d41a83de8a..6069b203de 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -26,6 +26,7 @@
   #:use-module (guix profiles)
   #:use-module (guix utils)
   #:use-module (guix config)
+  #:use-module (guix scripts build)
   #:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
   #:use-module ((guix ftp-client) #:select (ftp-open))
   #:use-module (ice-9 format)
@@ -460,6 +461,7 @@ ENTRIES, a list of manifest entries, in the context of PROFILE."
   ;; Alist of default option values.
   `((profile . ,%current-profile)
     (max-silent-time . 3600)
+    (verbosity . 0)
     (substitutes? . #t)))
 
 (define (show-help)
@@ -484,18 +486,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
   (display (_ "
   -d, --delete-generations[=PATTERN]
                          delete generations matching PATTERN"))
-  (newline)
   (display (_ "
   -p, --profile=PROFILE  use PROFILE instead of the user's default profile"))
-  (display (_ "
-  -n, --dry-run          show what would be done without actually doing it"))
-  (display (_ "
-      --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"))
+  (newline)
   (display (_ "
       --bootstrap        use the bootstrap Guile to build the profile"))
   (display (_ "
@@ -510,6 +503,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
   -A, --list-available[=REGEXP]
                          list available packages matching REGEXP"))
   (newline)
+  (show-build-options-help)
+  (newline)
   (display (_ "
   -h, --help             display this help and exit"))
   (display (_ "
@@ -519,107 +514,94 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
 
 (define %options
   ;; Specification 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 package")))
-
-        (option '(#\i "install") #f #t
-                (lambda (opt name arg result arg-handler)
-                  (let arg-handler ((arg arg) (result result))
-                    (values (if arg
-                                (alist-cons 'install arg result)
-                                result)
-                            arg-handler))))
-        (option '(#\e "install-from-expression") #t #f
-                (lambda (opt name arg result arg-handler)
-                  (values (alist-cons 'install (read/eval-package-expression arg)
-                                      result)
-                          #f)))
-        (option '(#\r "remove") #f #t
-                (lambda (opt name arg result arg-handler)
-                  (let arg-handler ((arg arg) (result result))
-                    (values (if arg
-                                (alist-cons 'remove arg result)
-                                result)
-                            arg-handler))))
-        (option '(#\u "upgrade") #f #t
-                (lambda (opt name arg result arg-handler)
-                  (let arg-handler ((arg arg) (result result))
-                    (values (alist-cons 'upgrade arg
-                                        ;; Delete any prior "upgrade all"
-                                        ;; command, or else "--upgrade gcc"
-                                        ;; would upgrade everything.
-                                        (delete '(upgrade . #f) result))
-                            arg-handler))))
-        (option '("roll-back") #f #f
-                (lambda (opt name arg result arg-handler)
-                  (values (alist-cons 'roll-back? #t result)
-                          #f)))
-        (option '(#\l "list-generations") #f #t
-                (lambda (opt name arg result arg-handler)
-                  (values (cons `(query list-generations ,(or arg ""))
-                                result)
-                          #f)))
-        (option '(#\d "delete-generations") #f #t
-                (lambda (opt name arg result arg-handler)
-                  (values (alist-cons 'delete-generations (or arg "")
-                                      result)
-                          #f)))
-        (option '("search-paths") #f #f
-                (lambda (opt name arg result arg-handler)
-                  (values (cons `(query search-paths) result)
-                          #f)))
-        (option '(#\p "profile") #t #f
-                (lambda (opt name arg result arg-handler)
-                  (values (alist-cons 'profile arg
-                                      (alist-delete 'profile result))
-                          #f)))
-        (option '(#\n "dry-run") #f #f
-                (lambda (opt name arg result arg-handler)
-                  (values (alist-cons 'dry-run? #t result)
-                          #f)))
-        (option '("fallback") #f #f
-                (lambda (opt name arg result arg-handler)
-                  (values (alist-cons 'fallback? #t
-                                      (alist-delete 'fallback? result))
-                          #f)))
-        (option '("no-substitutes") #f #f
-                (lambda (opt name arg result arg-handler)
-                  (values (alist-cons 'substitutes? #f
-                                      (alist-delete 'substitutes? result))
-                          #f)))
-        (option '("max-silent-time") #t #f
-                (lambda (opt name arg result arg-handler)
-                  (values (alist-cons 'max-silent-time (string->number* arg)
-                                      result)
-                          #f)))
-        (option '("bootstrap") #f #f
-                (lambda (opt name arg result arg-handler)
-                  (values (alist-cons 'bootstrap? #t result)
-                          #f)))
-        (option '("verbose") #f #f
-                (lambda (opt name arg result arg-handler)
-                  (values (alist-cons 'verbose? #t result)
-                          #f)))
-        (option '(#\s "search") #t #f
-                (lambda (opt name arg result arg-handler)
-                  (values (cons `(query search ,(or arg ""))
-                                result)
-                          #f)))
-        (option '(#\I "list-installed") #f #t
-                (lambda (opt name arg result arg-handler)
-                  (values (cons `(query list-installed ,(or arg ""))
-                                result)
-                          #f)))
-        (option '(#\A "list-available") #f #t
-                (lambda (opt name arg result arg-handler)
-                  (values (cons `(query list-available ,(or arg ""))
-                                result)
-                          #f)))))
+  (cons* (option '(#\h "help") #f #f
+                 (lambda args
+                   (show-help)
+                   (exit 0)))
+         (option '(#\V "version") #f #f
+                 (lambda args
+                   (show-version-and-exit "guix package")))
+
+         (option '(#\i "install") #f #t
+                 (lambda (opt name arg result arg-handler)
+                   (let arg-handler ((arg arg) (result result))
+                     (values (if arg
+                                 (alist-cons 'install arg result)
+                                 result)
+                             arg-handler))))
+         (option '(#\e "install-from-expression") #t #f
+                 (lambda (opt name arg result arg-handler)
+                   (values (alist-cons 'install (read/eval-package-expression arg)
+                                       result)
+                           #f)))
+         (option '(#\r "remove") #f #t
+                 (lambda (opt name arg result arg-handler)
+                   (let arg-handler ((arg arg) (result result))
+                     (values (if arg
+                                 (alist-cons 'remove arg result)
+                                 result)
+                             arg-handler))))
+         (option '(#\u "upgrade") #f #t
+                 (lambda (opt name arg result arg-handler)
+                   (let arg-handler ((arg arg) (result result))
+                     (values (alist-cons 'upgrade arg
+                                         ;; Delete any prior "upgrade all"
+                                         ;; command, or else "--upgrade gcc"
+                                         ;; would upgrade everything.
+                                         (delete '(upgrade . #f) result))
+                             arg-handler))))
+         (option '("roll-back") #f #f
+                 (lambda (opt name arg result arg-handler)
+                   (values (alist-cons 'roll-back? #t result)
+                           #f)))
+         (option '(#\l "list-generations") #f #t
+                 (lambda (opt name arg result arg-handler)
+                   (values (cons `(query list-generations ,(or arg ""))
+                                 result)
+                           #f)))
+         (option '(#\d "delete-generations") #f #t
+                 (lambda (opt name arg result arg-handler)
+                   (values (alist-cons 'delete-generations (or arg "")
+                                       result)
+                           #f)))
+         (option '("search-paths") #f #f
+                 (lambda (opt name arg result arg-handler)
+                   (values (cons `(query search-paths) result)
+                           #f)))
+         (option '(#\p "profile") #t #f
+                 (lambda (opt name arg result arg-handler)
+                   (values (alist-cons 'profile arg
+                                       (alist-delete 'profile result))
+                           #f)))
+         (option '(#\n "dry-run") #f #f
+                 (lambda (opt name arg result arg-handler)
+                   (values (alist-cons 'dry-run? #t result)
+                           #f)))
+         (option '("bootstrap") #f #f
+                 (lambda (opt name arg result arg-handler)
+                   (values (alist-cons 'bootstrap? #t result)
+                           #f)))
+         (option '("verbose") #f #f
+                 (lambda (opt name arg result arg-handler)
+                   (values (alist-cons 'verbose? #t result)
+                           #f)))
+         (option '(#\s "search") #t #f
+                 (lambda (opt name arg result arg-handler)
+                   (values (cons `(query search ,(or arg ""))
+                                 result)
+                           #f)))
+         (option '(#\I "list-installed") #f #t
+                 (lambda (opt name arg result arg-handler)
+                   (values (cons `(query list-installed ,(or arg ""))
+                                 result)
+                           #f)))
+         (option '(#\A "list-available") #f #t
+                 (lambda (opt name arg result arg-handler)
+                   (values (cons `(query list-available ,(or arg ""))
+                                 result)
+                           #f)))
+
+         %standard-build-options))
 
 (define (options->installable opts manifest)
   "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
@@ -1052,13 +1034,7 @@ more information.~%"))
     (or (process-query opts)
         (with-error-handling
           (parameterize ((%store (open-connection)))
-            (set-build-options (%store)
-                               #:print-build-trace #f
-                               #:fallback? (assoc-ref opts 'fallback?)
-                               #:use-substitutes?
-                               (assoc-ref opts 'substitutes?)
-                               #:max-silent-time
-                               (assoc-ref opts 'max-silent-time))
+            (set-build-options-from-command-line (%store) opts)
 
             (parameterize ((%guile-for-build
                             (package-derivation (%store)
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 3aaa1c4284..54f4aaa6c0 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -38,6 +38,7 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (web uri)
   #:use-module (guix http-client)
   #:export (guix-substitute-binary))
@@ -133,33 +134,38 @@ provide."
                             (if buffered? "rb" "r0b"))))
        (values port (stat:size (stat port)))))
     ((http)
-     ;; 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"))
-                         %fetch-timeout
-                         0)
-         (begin
-           (warning (_ "while fetching ~a: server is unresponsive~%")
-                    (uri->string uri))
-           (warning (_ "try `--no-substitutes' if the problem persists~%"))
-
-           ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user,
-           ;; and thus PORT had to be closed and re-opened.  This is not the
-           ;; case afterward.
-           (unless (or (guile-version>? "2.0.9")
-                       (version>? (version) "2.0.9.39"))
-             (when port
-               (close-port port))))
-         (begin
-           (when (or (not port) (port-closed? port))
-             (set! port (open-socket-for-uri uri #:buffered? buffered?)))
-           (http-fetch uri #:text? #f #:port port)))))))
+     (guard (c ((http-get-error? c)
+                (leave (_ "download from '~a' failed: ~a, ~s~%")
+                       (uri->string (http-get-error-uri c))
+                       (http-get-error-code c)
+                       (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"))
+                           %fetch-timeout
+                           0)
+           (begin
+             (warning (_ "while fetching ~a: server is unresponsive~%")
+                      (uri->string uri))
+             (warning (_ "try `--no-substitutes' if the problem persists~%"))
+
+             ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user,
+             ;; and thus PORT had to be closed and re-opened.  This is not the
+             ;; case afterward.
+             (unless (or (guile-version>? "2.0.9")
+                         (version>? (version) "2.0.9.39"))
+               (when port
+                 (close-port port))))
+           (begin
+             (when (or (not port) (port-closed? port))
+               (set! port (open-socket-for-uri uri #:buffered? buffered?)))
+             (http-fetch uri #:text? #f #:port port))))))))
 
 (define-record-type <cache>
   (%make-cache url store-directory wants-mass-query?)
diff --git a/guix/serialization.scm b/guix/serialization.scm
index 474dc69de5..284b174794 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.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.
 ;;;
@@ -22,11 +22,13 @@
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
   #:export (write-int read-int
             write-long-long read-long-long
             write-padding
             write-string read-string read-latin1-string
             write-string-list read-string-list
+            write-string-pairs
             write-store-path read-store-path
             write-store-path-list read-store-path-list))
 
@@ -94,6 +96,14 @@
   (write-int (length l) p)
   (for-each (cut write-string <> p) l))
 
+(define (write-string-pairs l p)
+  (write-int (length l) p)
+  (for-each (match-lambda
+             ((first . second)
+              (write-string first p)
+              (write-string second p)))
+            l))
+
 (define (read-string-list p)
   (let ((len (read-int p)))
     (unfold (cut >= <> len)
diff --git a/guix/store.scm b/guix/store.scm
index 54ed31cbbc..909ef195de 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -197,7 +197,7 @@
                       result))))))
 
 (define-syntax write-arg
-  (syntax-rules (integer boolean file string string-list
+  (syntax-rules (integer boolean file string string-list string-pairs
                  store-path store-path-list base16)
     ((_ integer arg p)
      (write-int arg p))
@@ -209,6 +209,8 @@
      (write-string arg p))
     ((_ string-list arg p)
      (write-string-list arg p))
+    ((_ string-pairs arg p)
+     (write-string-pairs arg p))
     ((_ store-path arg p)
      (write-store-path arg p))
     ((_ store-path-list arg p)
@@ -430,6 +432,7 @@ encoding conversion errors."
                             #:key keep-failed? keep-going? fallback?
                             (verbosity 0)
                             (max-build-jobs (current-processor-count))
+                            timeout
                             (max-silent-time 3600)
                             (use-build-hook? #t)
                             (build-verbosity 0)
@@ -462,12 +465,11 @@ encoding conversion errors."
     (when (>= (nix-server-minor-version server) 10)
       (send (boolean use-substitutes?)))
     (when (>= (nix-server-minor-version server) 12)
-      (send (string-list (fold-right (lambda (pair result)
-                                       (match pair
-                                         ((h . t)
-                                          (cons* h t result))))
-                                     '()
-                                     binary-caches))))
+      (let ((pairs (if timeout
+                       `(("build-timeout" . ,(number->string timeout))
+                         ,@binary-caches)
+                       binary-caches)))
+        (send (string-pairs pairs))))
     (let loop ((done? (process-stderr server)))
       (or done? (process-stderr server)))))
 
@@ -734,8 +736,13 @@ is raised if the set of paths read from PORT is not signed (as per
 (define* (export-paths server paths port #:key (sign? #t))
   "Export the store paths listed in PATHS to PORT, in topological order,
 signing them if SIGN? is true."
+  (define ordered
+    ;; Sort PATHS, but don't include their references.
+    (filter (cut member <> paths)
+            (topologically-sorted server paths)))
+
   (let ((s (nix-server-socket server)))
-    (let loop ((paths (topologically-sorted server paths)))
+    (let loop ((paths ordered))
       (match paths
         (()
          (write-int 0 port))
@@ -822,7 +829,7 @@ must be an absolute store file name, or a derivation file name."
   (cond ((derivation-path? file)
          (let* ((base    (basename file))
                 (log     (string-append (dirname %state-directory) ; XXX
-                                        "/log/nix/drvs/"
+                                        "/log/guix/drvs/"
                                         (string-take base 2) "/"
                                         (string-drop base 2)))
                 (log.bz2 (string-append log ".bz2")))
diff --git a/guix/utils.scm b/guix/utils.scm
index 5fda2116de..68329ec915 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -244,6 +244,13 @@ buffered data is lost."
          ((string-contains %host-type "linux") 7) ; *-linux-gnu
          (else 9))))                              ; *-gnu*
 
+(define F_SETLK
+  ;; Likewise: GNU/Hurd and SPARC use 8, while the others typically use 6.
+  (compile-time-value
+   (cond ((string-contains %host-type "sparc") 8) ; sparc-*-linux-gnu
+         ((string-contains %host-type "linux") 6) ; *-linux-gnu
+         (else 8))))                              ; *-gnu*
+
 (define F_xxLCK
   ;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
   (compile-time-value
@@ -252,12 +259,30 @@ buffered data is lost."
          ((string-contains %host-type "linux") #(0 1 2))    ; *-linux-gnu
          (else                                 #(1 2 3))))) ; *-gnu*
 
+(define %libc-errno-pointer
+  ;; Glibc's 'errno' pointer.
+  (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link))))
+    (and errno-loc
+         (let ((proc (pointer->procedure '* errno-loc '())))
+           (proc)))))
+
+(define (errno)
+  "Return the current errno."
+  ;; XXX: We assume that nothing changes 'errno' while we're doing all this.
+  ;; In particular, that means that no async must be running here.
+  (if %libc-errno-pointer
+      (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int))))
+        (bytevector-sint-ref bv 0 (native-endianness) (sizeof int)))
+      0))
+
 (define fcntl-flock
   (let* ((ptr  (dynamic-func "fcntl" (dynamic-link)))
          (proc (pointer->procedure int ptr `(,int ,int *))))
-    (lambda (fd-or-port operation)
+    (lambda* (fd-or-port operation #:key (wait? #t))
       "Perform locking OPERATION on the file beneath FD-OR-PORT.  OPERATION
-must be a symbol, one of 'read-lock, 'write-lock, or 'unlock."
+must be a symbol, one of 'read-lock, 'write-lock, or 'unlock.  When WAIT? is
+true, block until the lock is acquired; otherwise, thrown an 'flock-error'
+exception if it's already taken."
       (define (operation->int op)
         (case op
           ((read-lock)  (vector-ref F_xxLCK 0))
@@ -273,7 +298,9 @@ must be a symbol, one of 'read-lock, 'write-lock, or 'unlock."
       ;; XXX: 'fcntl' is a vararg function, but here we happily use the
       ;; standard ABI; crossing fingers.
       (let ((err (proc fd
-                       F_SETLKW                   ; lock & wait
+                       (if wait?
+                           F_SETLKW               ; lock & wait
+                           F_SETLK)               ; non-blocking attempt
                        (make-c-struct %struct-flock
                                       (list (operation->int operation)
                                             SEEK_SET
@@ -282,7 +309,7 @@ must be a symbol, one of 'read-lock, 'write-lock, or 'unlock."
         (or (zero? err)
 
             ;; Presumably we got EAGAIN or so.
-            (throw 'flock-error fd))))))
+            (throw 'flock-error (errno)))))))
 
 
 ;;;