Merge branch 'master' into core-updates

5 files changed, 106 insertions, 32 deletions

diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm
index 50f709418c..481d3f2463 100644
--- a/guix/pk-crypto.scm
+++ b/guix/pk-crypto.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,7 +24,8 @@
   #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
-  #:export (canonical-sexp?
+  #:export (gcrypt-version
+            canonical-sexp?
             error-source
             error-string
             string->canonical-sexp
@@ -39,6 +40,7 @@
             canonical-sexp-list?
             bytevector->hash-data
             hash-data->bytevector
+            key-type
             sign
             verify
             generate-key
@@ -85,6 +87,17 @@
       "Return a pointer to symbol FUNC in libgcrypt."
       (dynamic-func func lib))))
 
+(define gcrypt-version
+  ;; According to the manual, this function must be called before any other,
+  ;; and it's not clear whether it can be called more than once.  So call it
+  ;; right here from the top level.
+  (let* ((ptr     (libgcrypt-func "gcry_check_version"))
+         (proc    (pointer->procedure '* ptr '(*)))
+         (version (pointer->string (proc %null-pointer))))
+    (lambda ()
+      "Return the version number of libgcrypt as a string."
+      version)))
+
 (define finalize-canonical-sexp!
   (libgcrypt-func "gcry_sexp_release"))
 
@@ -232,15 +245,31 @@ Return #f if that element does not exist, or if it's a list."
   "Return an s-expression representing NUMBER."
   (string->canonical-sexp (string-append "#" (number->string number 16) "#")))
 
-(define* (bytevector->hash-data bv #:optional (hash-algo "sha256"))
+(define* (bytevector->hash-data bv
+                                #:optional
+                                (hash-algo "sha256")
+                                #:key (key-type 'ecc))
   "Given BV, a bytevector containing a hash, return an s-expression suitable
-for use as the data for 'sign'."
+for use as the data for 'sign'.  KEY-TYPE must be a symbol: 'dsa, 'ecc, or
+'rsa."
   (string->canonical-sexp
-   (format #f "(data (flags pkcs1) (hash \"~a\" #~a#))"
+   (format #f "(data (flags ~a) (hash \"~a\" #~a#))"
+           (case key-type
+             ((ecc dsa) "rfc6979")
+             ((rsa)     "pkcs1")
+             (else (error "unknown key type" key-type)))
            hash-algo
            (bytevector->base16-string bv))))
 
-(define (hash-data->bytevector data)
+(define (key-type sexp)
+  "Return a symbol denoting the type of key representing by SEXP--e.g., 'rsa',
+'ecc'--or #f if SEXP does not denote a valid key."
+  (case (canonical-sexp-nth-data sexp 0)
+    ((public-key private-key)
+     (canonical-sexp-nth-data (canonical-sexp-nth sexp 1) 0))
+    (else #f)))
+
+(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."
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 0ab7686585..c900fcecb9 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -87,6 +87,13 @@ Export/import one or more packages from/to the store.\n"))
   (newline)
   (show-bug-report-information))
 
+(define %key-generation-parameters
+  ;; Default key generation parameters.  We prefer Ed25519, but it was
+  ;; introduced in libgcrypt 1.6.0.
+  (if (version>? (gcrypt-version) "1.6.0")
+      "(genkey (ecdsa (curve Ed25519) (flags rfc6979)))"
+      "(genkey (rsa (nbits 4:4096)))"))
+
 (define %options
   ;; Specifications of the command-line options.
   (cons* (option '(#\h "help") #f #f
@@ -110,13 +117,16 @@ Export/import one or more packages from/to the store.\n"))
                  (lambda (opt name arg result)
                    (catch 'gcry-error
                      (lambda ()
+                       ;; XXX: Curve25519 was actually introduced in
+                       ;; libgcrypt 1.6.0.
                        (let ((params
                               (string->canonical-sexp
-                               (or arg "(genkey (rsa (nbits 4:4096)))"))))
+                               (or arg %key-generation-parameters))))
                          (alist-cons 'generate-key params result)))
-                     (lambda args
-                       (leave (_ "invalid key generation parameters: ~s~%")
-                              arg)))))
+                     (lambda (key err)
+                       (leave (_ "invalid key generation parameters: ~a: ~a~%")
+                              (error-source err)
+                              (error-string err))))))
          (option '("authorize") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'authorize #t result)))
diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm
index 27580dedff..927dbe8afc 100644
--- a/guix/scripts/authenticate.scm
+++ b/guix/scripts/authenticate.scm
@@ -39,11 +39,12 @@
   (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."
+(define (read-hash-data file key-type)
+  "Read sha256 hash data from FILE and return it as a gcrypt sexp.  KEY-TYPE
+is a symbol representing the type of public key algo being used."
   (let* ((hex (call-with-input-file file get-string-all))
          (bv  (base16-string->bytevector (string-trim-both hex))))
-    (bytevector->hash-data bv)))
+    (bytevector->hash-data bv #:key-type key-type)))
 
 
 ;;;
@@ -64,7 +65,7 @@
                             (leave
                              (_ "cannot find public key for secret key '~a'~%")
                              key)))
-            (data       (read-hash-data hash-file))
+            (data       (read-hash-data hash-file (key-type public-key)))
             (signature  (signature-sexp data secret-key public-key)))
        (display (canonical-sexp->string signature))
        #t))
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 95e35088a1..e078012582 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -159,19 +159,35 @@ determined."
 ;;       (leave (_ "failed to execute '~a': ~a~%")
 ;;              %lsh-command (strerror (system-error-errno args))))))
 
-(define (remote-pipe machine mode command)
+(define-syntax with-error-to-port
+  (syntax-rules ()
+    ((_ port exp0 exp ...)
+     (let ((new port)
+           (old (current-error-port)))
+       (dynamic-wind
+         (lambda ()
+           (set-current-error-port new))
+         (lambda ()
+           exp0 exp ...)
+         (lambda ()
+           (set-current-error-port old)))))))
+
+(define* (remote-pipe machine mode command
+                      #:key (error-port (current-error-port)))
   "Run COMMAND on MACHINE, assuming an lsh gateway has been set up."
   (catch 'system-error
     (lambda ()
-      (apply open-pipe* mode %lshg-command "-z"
-             "-l" (build-machine-user machine)
-             "-p" (number->string (build-machine-port machine))
+      ;; Let the child inherit ERROR-PORT.
+      (with-error-to-port error-port
+        (apply open-pipe* mode %lshg-command "-z"
+               "-l" (build-machine-user machine)
+               "-p" (number->string (build-machine-port machine))
 
-             ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg.
-             "-i" (build-machine-private-key machine)
+               ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg.
+               "-i" (build-machine-private-key machine)
 
-             (build-machine-name machine)
-             command))
+               (build-machine-name machine)
+               command)))
     (lambda args
       (warning (_ "failed to execute '~a': ~a~%")
                %lshg-command (strerror (system-error-errno args)))
@@ -257,9 +273,18 @@ connections allowed to MACHINE."
 ;;; Offloading.
 ;;;
 
+(define (build-log-port)
+  "Return the default port where build logs should be sent.  The default is
+file descriptor 4, which is open by the daemon before running the offload
+hook."
+  (let ((port (fdopen 4 "w0")))
+    ;; Make sure file descriptor 4 isn't closed when PORT is GC'd.
+    (set-port-revealed! port 1)
+    port))
+
 (define* (offload drv machine
                   #:key print-build-trace? (max-silent-time 3600)
-                  build-timeout (log-port (current-output-port)))
+                  build-timeout (log-port (build-log-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'...~%"
@@ -276,7 +301,11 @@ there, and write the build log to LOG-PORT.  Return the exit status."
                                    (list (format #f "--timeout=~a"
                                                  build-timeout))
                                    '())
-                             ,(derivation-file-name drv)))))
+                             ,(derivation-file-name drv))
+
+                           ;; Since 'guix build' writes the build log to its
+                           ;; stderr, everything will go directly to LOG-PORT.
+                           #:error-port log-port)))
     (let loop ((line (read-line pipe)))
       (unless (eof-object? line)
         (display line log-port)
@@ -597,6 +626,7 @@ This tool is meant to be used internally by 'guix-daemon'.\n"))
 ;;; Local Variables:
 ;;; eval: (put 'with-machine-lock 'scheme-indent-function 2)
 ;;; eval: (put 'with-file-lock 'scheme-indent-function 1)
+;;; eval: (put 'with-error-to-port 'scheme-indent-function 1)
 ;;; End:
 
 ;;; offload.scm ends here
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 54f4aaa6c0..7ac12ddef2 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -125,9 +125,10 @@ again."
         (sigaction SIGALRM SIG_DFL)
         (apply values result)))))
 
-(define* (fetch uri #:key (buffered? #t) (timeout? #t))
+(define* (fetch uri #:key (buffered? #t) (timeout? #t) (quiet-404? #f))
   "Return a binary input port to URI and the number of bytes it's expected to
-provide."
+provide.  If QUIET-404? is true, HTTP 404 error conditions are passed through
+to the caller without emitting an error message."
   (case (uri-scheme uri)
     ((file)
      (let ((port (open-file (uri-path uri)
@@ -135,10 +136,12 @@ provide."
        (values port (stat:size (stat port)))))
     ((http)
      (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))))
+                (let ((code (http-get-error-code c)))
+                  (if (and (= code 404) quiet-404?)
+                      (raise c)
+                      (leave (_ "download from '~a' failed: ~a, ~s~%")
+                             (uri->string (http-get-error-uri c))
+                             code (http-get-error-reason c))))))
        ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once.  So
        ;; honor TIMEOUT? to disable the timeout when fetching a nar.
        ;;
@@ -275,8 +278,9 @@ reading PORT."
   "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
   (define (download url)
     ;; Download the .narinfo from URL, and return its contents as a list of
-    ;; key/value pairs.
-    (false-if-exception (fetch (string->uri url))))
+    ;; key/value pairs.  Don't emit an error message upon 404.
+    (false-if-exception (fetch (string->uri url)
+                               #:quiet-404? #t)))
 
   (and (string=? (cache-store-directory cache) (%store-prefix))
        (and=> (download (string-append (cache-url cache) "/"