Merge branch 'master' into core-updates

6 files changed, 107 insertions, 43 deletions

diff --git a/guix/build/bournish.scm b/guix/build/bournish.scm
index 4022796658..1f17e0a22d 100644
--- a/guix/build/bournish.scm
+++ b/guix/build/bournish.scm
@@ -134,8 +134,10 @@ commands such as 'ls' and 'cd'; it lacks globbing, pipes---everything.\n"))
 (define (read-bournish port env)
   "Read a Bournish expression from PORT, and return the corresponding Scheme
 code as an sexp."
-  (match (string-tokenize (read-line port))
-    ((command args ...)
+  (match (read-line port)
+    ((? eof-object? eof)
+     eof)
+    ((= string-tokenize (command args ...))
      (match (assoc command %commands)
        ((command proc)                            ;built-in command
         (apply proc (map expand-variable args)))
@@ -147,11 +149,24 @@ code as an sexp."
 
 (define %bournish-language
   (let ((scheme (lookup-language 'scheme)))
+    ;; XXX: The 'scheme' language lacks a "joiner", so we add one here.  This
+    ;; allows us to have 'read-bournish' read one shell statement at a time
+    ;; instead of having to read until EOF.
+    (set! (language-joiner scheme)
+      (lambda (exps env)
+        (match exps
+          (()   '(begin))
+          ((exp) exp)
+          (_    `(begin ,@exps)))))
+
     (make-language #:name 'bournish
                    #:title "Bournish"
+
+                   ;; The reader does all the heavy lifting.
                    #:reader read-bournish
-                   #:compilers (language-compilers scheme)
-                   #:decompilers (language-decompilers scheme)
+                   #:compilers `((scheme . ,(lambda (exp env options)
+                                              (values exp env env))))
+                   #:decompilers '()
                    #:evaluator (language-evaluator scheme)
                    #:printer (language-printer scheme)
                    #:make-default-environment
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 7741726c41..bd011ce878 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -234,9 +234,10 @@ and 'guix publish', something like
         (string-drop path 33)
         path)))
 
-(define (ftp-fetch uri file)
-  "Fetch data from URI and write it to FILE.  Return FILE on success."
-  (let* ((conn (ftp-open (uri-host uri)))
+(define* (ftp-fetch uri file #:key timeout)
+  "Fetch data from URI and write it to FILE.  Return FILE on success.  Bail
+out if the connection could not be established in less than TIMEOUT seconds."
+  (let* ((conn (ftp-open (uri-host uri) #:timeout timeout))
          (size (false-if-exception (ftp-size conn (uri-path uri))))
          (in   (ftp-retr conn (basename (uri-path uri))
                          (dirname (uri-path uri)))))
@@ -585,8 +586,10 @@ Return the resulting target URI."
                     #:query    (uri-query    ref)
                     #:fragment (uri-fragment ref)))))
 
-(define (http-fetch uri file)
-  "Fetch data from URI and write it to FILE.  Return FILE on success."
+(define* (http-fetch uri file #:key timeout)
+  "Fetch data from URI and write it to FILE; when TIMEOUT is true, bail out if
+the connection could not be established in less than TIMEOUT seconds.  Return
+FILE on success."
 
   (define post-2.0.7?
     (or (> (string->number (major-version)) 2)
@@ -605,7 +608,7 @@ Return the resulting target URI."
       (Accept . "*/*")))
 
   (let*-values (((connection)
-                 (open-connection-for-uri uri))
+                 (open-connection-for-uri uri #:timeout timeout))
                 ((resp bv-or-port)
                  ;; XXX: `http-get*' was introduced in 2.0.7, and replaced by
                  ;; #:streaming? in 2.0.8.  We know we're using it within the
@@ -646,7 +649,7 @@ Return the resulting target URI."
          (format #t "following redirection to `~a'...~%"
                  (uri->string uri))
          (close connection)
-         (http-fetch uri file)))
+         (http-fetch uri file #:timeout timeout)))
       (else
        (error "download failed" (uri->string uri)
               code (response-reason-phrase resp))))))
@@ -686,6 +689,7 @@ Return a list of URIs."
 
 (define* (url-fetch url file
                     #:key
+                    (timeout 10)
                     (mirrors '()) (content-addressed-mirrors '())
                     (hashes '()))
   "Fetch FILE from URL; URL may be either a single string, or a list of
@@ -711,19 +715,19 @@ or #f."
             file (uri->string uri))
     (case (uri-scheme uri)
       ((http https)
-       (false-if-exception* (http-fetch uri file)))
+       (false-if-exception* (http-fetch uri file #:timeout timeout)))
       ((ftp)
-       (false-if-exception* (ftp-fetch uri file)))
+       (false-if-exception* (ftp-fetch uri file #:timeout timeout)))
       (else
        (format #t "skipping URI with unsupported scheme: ~s~%"
                uri)
        #f)))
 
-  (define content-addressed-urls
+  (define content-addressed-uris
     (append-map (lambda (make-url)
                   (filter-map (match-lambda
                                 ((hash-algo . hash)
-                                 (make-url hash-algo hash)))
+                                 (string->uri (make-url hash-algo hash))))
                               hashes))
                 content-addressed-mirrors))
 
@@ -733,7 +737,7 @@ or #f."
 
   (setvbuf (current-error-port) _IOLBF)
 
-  (let try ((uri (append uri content-addressed-urls)))
+  (let try ((uri (append uri content-addressed-uris)))
     (match uri
       ((uri tail ...)
        (or (fetch uri file)
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index f0a9a6e125..ab970012a7 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -21,6 +21,7 @@
   #:use-module (guix build utils)
   #:use-module (guix build emacs-utils)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
@@ -39,6 +40,27 @@
 ;; archive signature.
 (define %install-suffix "/share/emacs/site-lisp/guix.d")
 
+(define gnu:unpack (assoc-ref gnu:%standard-phases 'unpack))
+
+(define (store-file->elisp-source-file file)
+  "Convert FILE, a store file name for an Emacs Lisp source file, into a file
+name that has been stripped of the hash and version number."
+  (let-values (((name version)
+                (package-name->name+version
+                 (strip-store-file-name file))))
+    (string-append name ".el")))
+
+(define* (unpack #:key source #:allow-other-keys)
+  "Unpack SOURCE into the build directory.  SOURCE may be a compressed
+archive, a directory, or an Emacs Lisp file."
+  (if (string-suffix? ".el" source)
+      (begin
+        (mkdir "source")
+        (chdir "source")
+        (copy-file source (store-file->elisp-source-file source))
+        #t)
+      (gnu:unpack #:source source)))
+
 (define* (build #:key outputs inputs #:allow-other-keys)
   "Compile .el files."
   (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs"))
@@ -151,6 +173,7 @@ second hyphen.  This corresponds to 'name-version' as used in ELPA packages."
 
 (define %standard-phases
   (modify-phases gnu:%standard-phases
+    (replace 'unpack unpack)
     (delete 'configure)
     (delete 'check)
     (delete 'install)
diff --git a/guix/build/graft.scm b/guix/build/graft.scm
index b61982dd64..fb21fc3af3 100644
--- a/guix/build/graft.scm
+++ b/guix/build/graft.scm
@@ -105,6 +105,19 @@ a list of store file name pairs."
                                (string-append (dirname file) "/" target))))
               matches)))
 
+(define (exit-on-exception proc)
+  "Return a procedure that wraps PROC so that 'primitive-exit' is called when
+an exception is caught."
+  (lambda (arg)
+    (catch #t
+      (lambda ()
+        (proc arg))
+      (lambda (key . args)
+        ;; Since ports are not thread-safe as of Guile 2.0, reopen stderr.
+        (let ((port (fdopen 2 "w0")))
+          (print-exception port #f key args)
+          (primitive-exit 1))))))
+
 (define* (rewrite-directory directory output mapping
                             #:optional (store (%store-directory)))
   "Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of
@@ -147,9 +160,13 @@ file name pairs."
   ;; #o777.
   (umask #o022)
 
+  ;; Use 'exit-on-exception' to force an exit upon I/O errors, given that
+  ;; 'n-par-for-each' silently swallows exceptions.
+  ;; See <http://bugs.gnu.org/23581>.
   (n-par-for-each (parallel-job-count)
-                  rewrite-leaf (find-files directory (const #t)
-                                           #:directories? #t))
+                  (exit-on-exception rewrite-leaf)
+                  (find-files directory (const #t)
+                              #:directories? #t))
   (rename-matching-files output mapping))
 
 ;;; graft.scm ends here
diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm
index a4ac3b307c..79ac380cb8 100644
--- a/guix/build/ruby-build-system.scm
+++ b/guix/build/ruby-build-system.scm
@@ -66,14 +66,13 @@ directory."
       ;; Use GNU unpack strategy for things that aren't gem archives.
       (gnu:unpack #:source source)))
 
-(define* (build #:key source #:allow-other-keys)
-  "Build a new gem using the gemspec from the SOURCE gem."
-  (define (first-gemspec)
-    (first-matching-file "\\.gemspec$"))
+(define (first-gemspec)
+  (first-matching-file "\\.gemspec$"))
 
-  ;; Remove the original gemspec, if present, and replace it with a new one.
-  ;; This avoids issues with upstream gemspecs requiring tools such as git to
-  ;; generate the files list.
+(define* (extract-gemspec #:key source #:allow-other-keys)
+  "Remove the original gemspec, if present, and replace it with a new one.
+This avoids issues with upstream gemspecs requiring tools such as git to
+generate the files list."
   (when (gem-archive? source)
     (let ((gemspec (or (false-if-exception (first-gemspec))
                        ;; Make new gemspec if one wasn't shipped.
@@ -94,7 +93,10 @@ directory."
                   (write-char (read-char pipe) out))))
             #t)
           (lambda ()
-            (close-pipe pipe))))))
+            (close-pipe pipe)))))))
+
+(define* (build #:key source #:allow-other-keys)
+  "Build a new gem using the gemspec from the SOURCE gem."
 
   ;; Build a new gem from the current working directory.  This also allows any
   ;; dynamic patching done in previous phases to be present in the installed
@@ -134,6 +136,7 @@ GEM-FLAGS are passed to the 'gem' invokation, if present."
 (define %standard-phases
   (modify-phases gnu:%standard-phases
     (delete 'configure)
+    (add-before 'build 'extract-gemspec extract-gemspec)
     (replace 'build build)
     (replace 'unpack unpack)
     (replace 'install install)
diff --git a/guix/build/union.scm b/guix/build/union.scm
index ccd2d5c103..6640b56523 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -53,22 +53,24 @@
 identical, #f otherwise."
   (let ((st1 (stat file1))
         (st2 (stat file2)))
-    (and (eq? (stat:type st1) 'regular)
-         (eq? (stat:type st2) 'regular)
-         (= (stat:size st1) (stat:size st2))
-         (call-with-input-file file1
-           (lambda (port1)
-             (call-with-input-file file2
-               (lambda (port2)
-                 (define len 8192)
-                 (define buf1 (make-bytevector len))
-                 (define buf2 (make-bytevector len))
-                 (let loop ()
-                   (let ((n1 (get-bytevector-n! port1 buf1 0 len))
-                         (n2 (get-bytevector-n! port2 buf2 0 len)))
-                     (and (equal? n1 n2)
-                          (or (eof-object? n1)
-                              (loop))))))))))))
+    ;; When deduplication is enabled, identical files share the same inode.
+    (or (= (stat:ino st1) (stat:ino st2))
+        (and (eq? (stat:type st1) 'regular)
+             (eq? (stat:type st2) 'regular)
+             (= (stat:size st1) (stat:size st2))
+             (call-with-input-file file1
+               (lambda (port1)
+                 (call-with-input-file file2
+                   (lambda (port2)
+                     (define len 8192)
+                     (define buf1 (make-bytevector len))
+                     (define buf2 (make-bytevector len))
+                     (let loop ()
+                       (let ((n1 (get-bytevector-n! port1 buf1 0 len))
+                             (n2 (get-bytevector-n! port2 buf2 0 len)))
+                         (and (equal? n1 n2)
+                              (or (eof-object? n1)
+                                  (loop)))))))))))))
 
 (define* (union-build output inputs
                       #:key (log-port (current-error-port)))