store: Add #:timeout build option.

* guix/serialization.scm (write-string-pairs): New procedure.
* guix/store.scm (write-arg): Add 'string-pairs' case.
  (set-build-options): Add 'timeout' keyword parameter.  Honor it.
* tests/derivations.scm ("build-expression->derivation and timeout"):
  New test.

3 files changed, 34 insertions, 8 deletions

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 75edb340ae..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)))))
 
diff --git a/tests/derivations.scm b/tests/derivations.scm
index f31b00b8a2..e87662a198 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -446,6 +446,20 @@
       (build-derivations store (list drv))
       #f)))
 
+(test-assert "build-expression->derivation and timeout"
+  (let* ((store      (let ((s (open-connection)))
+                       (set-build-options s #:timeout 1)
+                       s))
+         (builder    '(begin (sleep 100) (mkdir %output) #t))
+         (drv        (build-expression->derivation store "slow" builder))
+         (out-path   (derivation->output-path drv)))
+    (guard (c ((nix-protocol-error? c)
+               (and (string-contains (nix-protocol-error-message c)
+                                     "failed")
+                    (not (valid-path? store out-path)))))
+      (build-derivations store (list drv))
+      #f)))
+
 (test-assert "build-expression->derivation and derivation-prerequisites-to-build"
   (let ((drv (build-expression->derivation %store "fail" #f)))
     ;; The only direct dependency is (%guile-for-build) and it's already