Merge branch 'master' into core-updates

9 files changed, 216 insertions, 101 deletions

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 97f96d99c1..da686e89e2 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -230,7 +230,7 @@ Nix itself keeps only one of them."
 
 CUT? is a predicate that is passed a derivation-input and returns true to
 eliminate the given input and its dependencies from the search.  An example of
-search a predicate is 'valid-derivation-input?'; when it is used as CUT?, the
+such a predicate is 'valid-derivation-input?'; when it is used as CUT?, the
 result is the set of prerequisites of DRV not already in valid."
   (let loop ((drv       drv)
              (result    '())
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 233a20e983..a7485bb4d0 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -59,7 +59,9 @@
              (repository (assoc-ref crate "repository"))
              (synopsis (assoc-ref crate "description"))
              (description (assoc-ref crate "description"))
-             (license (string->license (assoc-ref crate "license")))
+             (license (or (and=> (assoc-ref crate "license")
+                                 string->license)
+                          '()))                   ;missing license info
              (path (string-append "/" version "/dependencies"))
              (deps-json (json-fetch (string-append crate-url name path)))
              (deps (assoc-ref deps-json "dependencies"))
diff --git a/guix/import/gem.scm b/guix/import/gem.scm
index 3ad7facc7f..6e914d6290 100644
--- a/guix/import/gem.scm
+++ b/guix/import/gem.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copryight © 2016 Ben Woodcroft <donttrustben@gmail.com>
+;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 2c9df073d3..4fb00af404 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
 ;;; Copyright © 2016 Eric Bavier <bavier@member.fsf.org>
-;;; Coypright © 2016 ng0 <ng0@we.make.ritual.n0.is>
+;;; Copyright © 2016 ng0 <ng0@we.make.ritual.n0.is>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index dd54f03996..1673fb9f33 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -326,7 +326,7 @@ advertise it as the maximum validity period (in seconds) via the
 appropriate duration.  NAR-PATH specifies the prefix for nar URLs."
   (let ((store-path (hash-part->path store hash)))
     (if (string-null? store-path)
-        (not-found request)
+        (not-found request #:phrase "")
         (values `((content-type . (application/x-nix-narinfo))
                   ,@(if ttl
                         `((cache-control (max-age . ,ttl)))
@@ -461,7 +461,7 @@ requested using POOL."
                       #:phrase "We're baking it"
                       #:ttl 300))              ;should be available within 5m
           (else
-           (not-found request)))))
+           (not-found request #:phrase "")))))
 
 (define* (bake-narinfo+nar cache item
                            #:key ttl (compression %no-compression)
@@ -505,10 +505,10 @@ requested using POOL."
                                                       stat:size))
                    port))))))
 
-;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for
+;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for
 ;; internal consumption: it allows us to pass the compression info to
 ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>.
-(declare-header! "Guix-Nar-Compression"
+(declare-header! "X-Nar-Compression"
                  (lambda (str)
                    (match (call-with-input-string str read)
                      (('compression type level)
@@ -529,7 +529,7 @@ requested using POOL."
     (if (valid-path? store store-path)
         (values `((content-type . (application/x-nix-archive
                                    (charset . "ISO-8859-1")))
-                  (guix-nar-compression . ,compression))
+                  (x-nar-compression . ,compression))
                 ;; XXX: We're not returning the actual contents, deferring
                 ;; instead to 'http-write'.  This is a hack to work around
                 ;; <http://bugs.gnu.org/21093>.
@@ -544,11 +544,12 @@ return it; otherwise, return 404."
                                 #:compression compression)))
     (if (file-exists? cached)
         (values `((content-type . (application/octet-stream
-                                   (charset . "ISO-8859-1"))))
-                ;; XXX: We're not returning the actual contents, deferring
-                ;; instead to 'http-write'.  This is a hack to work around
-                ;; <http://bugs.gnu.org/21093>.
-                cached)
+                                   (charset . "ISO-8859-1")))
+                  ;; XXX: We're not returning the actual contents, deferring
+                  ;; instead to 'http-write'.  This is a hack to work around
+                  ;; <http://bugs.gnu.org/21093>.
+                  (x-raw-file . ,cached))
+                #f)
         (not-found request))))
 
 (define (render-content-addressed-file store request
@@ -562,14 +563,40 @@ has the given HASH of type ALGO."
                                      #:recursive? #f)))
         (if (valid-path? store item)
             (values `((content-type . (application/octet-stream
-                                       (charset . "ISO-8859-1"))))
-                    ;; XXX: We're not returning the actual contents, deferring
-                    ;; instead to 'http-write'.  This is a hack to work around
-                    ;; <http://bugs.gnu.org/21093>.
-                    item)
+                                       (charset . "ISO-8859-1")))
+                      ;; XXX: We're not returning the actual contents,
+                      ;; deferring instead to 'http-write'.  This is a hack to
+                      ;; work around <http://bugs.gnu.org/21093>.
+                      (x-raw-file . ,item))
+                    #f)
             (not-found request)))
       (not-found request)))
 
+(define (render-log-file store request name)
+  "Render the log file for NAME, the base name of a store item.  Don't attempt
+to compress or decompress the log file; just return it as-is."
+  (define (response-headers file)
+    ;; XXX: We're not returning the actual contents, deferring instead to
+    ;; 'http-write'.  This is a hack to work around
+    ;; <http://bugs.gnu.org/21093>.
+    (cond ((string-suffix? ".gz" file)
+           `((content-type . (text/plain (charset . "UTF-8")))
+             (content-encoding . (gzip))
+             (x-raw-file . ,file)))
+          ((string-suffix? ".bz2" file)
+           `((content-type . (application/x-bzip2
+                              (charset . "ISO-8859-1")))
+             (x-raw-file . ,file)))
+          (else                                   ;uncompressed
+           `((content-type . (text/plain (charset . "UTF-8")))
+             (x-raw-file . ,file)))))
+
+  (let ((log (log-file store
+                       (string-append (%store-prefix) "/" name))))
+    (if log
+        (values (response-headers log) log)
+        (not-found request))))
+
 (define (render-home-page request)
   "Render the home page."
   (values `((content-type . (text/html (charset . "UTF-8"))))
@@ -611,20 +638,22 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
 (define %http-write
   (@@ (web server http) http-write))
 
+(define (strip-headers response)
+  "Return RESPONSE's headers minus 'Content-Length' and our internal headers."
+  (fold alist-delete
+        (response-headers response)
+        '(content-length x-raw-file x-nar-compression)))
+
 (define (sans-content-length response)
   "Return RESPONSE without its 'content-length' header."
   (set-field response (response-headers)
-             (alist-delete 'content-length
-                           (response-headers response)
-                           eq?)))
+             (strip-headers response)))
 
 (define (with-content-length response length)
   "Return RESPONSE with a 'content-length' header set to LENGTH."
   (set-field response (response-headers)
              (alist-cons 'content-length length
-                         (alist-delete 'content-length
-                                       (response-headers response)
-                                       eq?))))
+                         (strip-headers response))))
 
 (define-syntax-rule (swallow-EPIPE exp ...)
   "Swallow EPIPE errors raised by EXP..."
@@ -646,7 +675,7 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
 (define (nar-response-port response)
   "Return a port on which to write the body of RESPONSE, the response of a
 /nar request, according to COMPRESSION."
-  (match (assoc-ref (response-headers response) 'guix-nar-compression)
+  (match (assoc-ref (response-headers response) 'x-nar-compression)
     (($ <compression> 'gzip level)
      ;; Note: We cannot used chunked encoding here because
      ;; 'make-gzip-output-port' wants a file port.
@@ -685,35 +714,37 @@ blocking."
           (swallow-zlib-error
            (close-port port))
           (values)))))
-    (('application/octet-stream . _)
-     ;; Send a raw file in a separate thread.
-     (call-with-new-thread
-      (lambda ()
-        (set-thread-name "publish file")
-        (catch 'system-error
-          (lambda ()
-            (call-with-input-file (utf8->string body)
-              (lambda (input)
-                (let* ((size     (stat:size (stat input)))
-                       (response (write-response (with-content-length response
-                                                                      size)
-                                                 client))
-                       (output   (response-port response)))
-                  (if (file-port? output)
-                      (sendfile output input size)
-                      (dump-port input output))
-                  (close-port output)
-                  (values)))))
-          (lambda args
-            ;; If the file was GC'd behind our back, that's fine.  Likewise if
-            ;; the client closes the connection.
-            (unless (memv (system-error-errno args)
-                          (list ENOENT EPIPE ECONNRESET))
-              (apply throw args))
-            (values))))))
     (_
-     ;; Handle other responses sequentially.
-     (%http-write server client response body))))
+     (match (assoc-ref (response-headers response) 'x-raw-file)
+       ((? string? file)
+        ;; Send a raw file in a separate thread.
+        (call-with-new-thread
+         (lambda ()
+           (set-thread-name "publish file")
+           (catch 'system-error
+             (lambda ()
+               (call-with-input-file file
+                 (lambda (input)
+                   (let* ((size     (stat:size (stat input)))
+                          (response (write-response (with-content-length response
+                                                                         size)
+                                                    client))
+                          (output   (response-port response)))
+                     (if (file-port? output)
+                         (sendfile output input size)
+                         (dump-port input output))
+                     (close-port output)
+                     (values)))))
+             (lambda args
+               ;; If the file was GC'd behind our back, that's fine.  Likewise if
+               ;; the client closes the connection.
+               (unless (memv (system-error-errno args)
+                             (list ENOENT EPIPE ECONNRESET))
+                 (apply throw args))
+               (values))))))
+       (#f
+        ;; Handle other responses sequentially.
+        (%http-write server client response body))))))
 
 (define-server-impl concurrent-http-server
   ;; A variant of Guile's built-in HTTP server that offloads possibly long
@@ -768,6 +799,10 @@ blocking."
                (render-content-addressed-file store request
                                               name 'sha256 hash))))
 
+          ;; /log/OUTPUT
+          (("log" name)
+           (render-log-file store request name))
+
           ;; Use different URLs depending on the compression type.  This
           ;; guarantees that /nar URLs remain valid even when 'guix publish'
           ;; is restarted with different compression parameters.
diff --git a/guix/serialization.scm b/guix/serialization.scm
index e6ae2fc307..b41a0a09d1 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -102,9 +102,9 @@
         (or (zero? m)
             (put-bytevector p zero 0 (- 8 m)))))))
 
-(define (write-bytevector s p)
-  (let* ((l (bytevector-length s))
-         (m (modulo l 8))
+(define* (write-bytevector s p
+                           #:optional (l (bytevector-length s)))
+  (let* ((m (modulo l 8))
          (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m))))))
     (bytevector-u32-set! b 0 l (endianness little))
     (bytevector-copy! s 0 b 8 l)
diff --git a/guix/ssh.scm b/guix/ssh.scm
index 7b33ef5a3b..cb560c0e9c 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -19,6 +19,7 @@
 (define-module (guix ssh)
   #:use-module (guix store)
   #:use-module (guix i18n)
+  #:use-module ((guix utils) #:select (&fix-hint))
   #:use-module (ssh session)
   #:use-module (ssh auth)
   #:use-module (ssh key)
@@ -100,30 +101,43 @@ Throw an error on failure."
     ;; Unix-domain sockets but libssh doesn't have an API for that, hence this
     ;; hack.
     `(begin
-       (use-modules (ice-9 match) (rnrs io ports))
+       (use-modules (ice-9 match) (rnrs io ports)
+                    (rnrs bytevectors) (system foreign))
+
+       (define read!
+         ;; XXX: We would use 'get-bytevector-some' but it always returns a
+         ;; single byte in Guile <= 2.2.3---see <https://bugs.gnu.org/30066>.
+         ;; This procedure works around it.
+         (let ((proc (pointer->procedure int
+                                         (dynamic-func "read" (dynamic-link))
+                                         (list int '* size_t))))
+           (lambda (port bv)
+             (proc (fileno port) (bytevector->pointer bv)
+                   (bytevector-length bv)))))
 
        (let ((sock   (socket AF_UNIX SOCK_STREAM 0))
              (stdin  (current-input-port))
-             (stdout (current-output-port)))
+             (stdout (current-output-port))
+             (buffer (make-bytevector 65536)))
          (setvbuf stdin _IONBF)
          (setvbuf stdout _IONBF)
          (connect sock AF_UNIX ,socket-name)
 
          (let loop ()
-           (match (select (list stdin sock) '() (list stdin stdout sock))
-             ((reads writes ())
+           (match (select (list stdin sock) '() '())
+             ((reads () ())
               (when (memq stdin reads)
-                (match (get-bytevector-some stdin)
-                  ((? eof-object?)
+                (match (read! stdin buffer)
+                  ((? zero?)                      ;EOF
                    (primitive-exit 0))
-                  (bv
-                   (put-bytevector sock bv))))
+                  (count
+                   (put-bytevector sock buffer 0 count))))
               (when (memq sock reads)
-                (match (get-bytevector-some sock)
-                  ((? eof-object?)
+                (match (read! sock buffer)
+                  ((? zero?)                      ;EOF
                    (primitive-exit 0))
-                  (bv
-                   (put-bytevector stdout bv))))
+                  (count
+                   (put-bytevector stdout buffer 0 count))))
               (loop))
              (_
               (primitive-exit 1)))))))
@@ -197,15 +211,36 @@ be read.  When RECURSIVE? is true, the closure of FILES is exported."
   ;; remote store.
   (define export
     `(begin
-       (use-modules (guix))
-
-       (with-store store
-         (setvbuf (current-output-port) _IONBF)
-
-         ;; FIXME: Exceptions are silently swallowed.  We should report them
-         ;; somehow.
-         (export-paths store ',files (current-output-port)
-                       #:recursive? ,recursive?))))
+       (eval-when (load expand eval)
+         (unless (resolve-module '(guix) #:ensure #f)
+           (write `(module-error))
+           (exit 7)))
+
+       (use-modules (guix) (srfi srfi-1)
+                    (srfi srfi-26) (srfi srfi-34))
+
+       (guard (c ((nix-connection-error? c)
+                  (write `(connection-error ,(nix-connection-error-file c)
+                                            ,(nix-connection-error-code c))))
+                 ((nix-protocol-error? c)
+                  (write `(protocol-error ,(nix-protocol-error-status c)
+                                          ,(nix-protocol-error-message c))))
+                 (else
+                  (write `(exception))))
+         (with-store store
+           (let* ((files ',files)
+                  (invalid (remove (cut valid-path? store <>)
+                                   files)))
+             (unless (null? invalid)
+               (write `(invalid-items ,invalid))
+               (exit 1))
+
+             (write '(exporting))                 ;we're ready
+             (force-output)
+
+             (setvbuf (current-output-port) _IONBF)
+             (export-paths store files (current-output-port)
+                           #:recursive? ,recursive?))))))
 
   (open-remote-input-pipe session
                           (string-join
@@ -291,6 +326,19 @@ to the length of FILES.)"
                                 #:recursive? recursive?)
           (length files)))            ;XXX: inaccurate when RECURSIVE? is true
 
+(define-syntax raise-error
+  (syntax-rules (=>)
+    ((_ fmt args ... (=> hint-fmt hint-args ...))
+     (raise (condition
+             (&message
+              (message (format #f fmt args ...)))
+             (&fix-hint
+              (hint (format #f hint-fmt hint-args ...))))))
+    ((_ fmt args ...)
+     (raise (condition
+             (&message
+              (message (format #f fmt args ...))))))))
+
 (define* (retrieve-files local files remote
                          #:key recursive? (log-port (current-error-port)))
   "Retrieve FILES from REMOTE and import them using the 'import-paths' RPC on
@@ -298,22 +346,44 @@ LOCAL.  When RECURSIVE? is true, retrieve the closure of FILES."
   (let-values (((port count)
                 (file-retrieval-port files remote
                                      #:recursive? recursive?)))
-    (format #t (N_ "retrieving ~a store item from '~a'...~%"
-                   "retrieving ~a store items from '~a'...~%" count)
-            count (remote-store-host remote))
-    (when (eof-object? (lookahead-u8 port))
-      ;; The failure could be because one of the requested store items is not
-      ;; valid on REMOTE, or because Guile or Guix is improperly installed.
-      ;; TODO: Improve error reporting.
-      (raise (condition
-              (&message
-               (message
-                (format #f
-                        (G_ "failed to retrieve store items from '~a'")
-                        (remote-store-host remote)))))))
-
-    (let ((result (import-paths local port)))
-      (close-port port)
-      result)))
+    (match (read port)                            ;read the initial status
+      (('exporting)
+       (format #t (N_ "retrieving ~a store item from '~a'...~%"
+                      "retrieving ~a store items from '~a'...~%" count)
+               count (remote-store-host remote))
+
+       (let ((result (import-paths local port)))
+         (close-port port)
+         result))
+      ((? eof-object?)
+       (raise-error (G_ "failed to start Guile on remote host '~A': exit code ~A")
+                    (remote-store-host remote)
+                    (channel-get-exit-status port)
+                    (=> (G_ "Make sure @command{guile} can be found in
+@code{$PATH} on the remote host.  Run @command{ssh ~A guile --version} to
+check.")
+                        (remote-store-host remote))))
+      (('module-error . _)
+       ;; TRANSLATORS: Leave "Guile" untranslated.
+       (raise-error (G_ "Guile modules not found on remote host '~A'")
+                    (remote-store-host remote)
+                    (=> (G_ "Make sure @code{GUILE_LOAD_PATH} includes Guix'
+own module directory.  Run @command{ssh ~A env | grep GUILE_LOAD_PATH} to
+check.")
+                        (remote-store-host remote))))
+      (('connection-error file code . _)
+       (raise-error (G_ "failed to connect to '~A' on remote host '~A': ~a")
+                    file (remote-store-host remote) (strerror code)))
+      (('invalid-items items . _)
+       (raise-error (N_ "no such item on remote host '~A':~{ ~a~}"
+                        "no such items on remote host '~A':~{ ~a~}"
+                        (length items))
+                    (remote-store-host remote) items))
+      (('protocol-error status message . _)
+       (raise-error (G_ "protocol error on remote host '~A': ~a")
+                    (remote-store-host remote) message))
+      (_
+       (raise-error (G_ "failed to retrieve store items from '~a'")
+                    (remote-store-host remote))))))
 
 ;;; ssh.scm ends here
diff --git a/guix/store.scm b/guix/store.scm
index e6e45ba89c..6742611c6f 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -609,7 +609,7 @@ encoding conversion errors."
            (let* ((max-len (read-int p))
                   (data    (make-bytevector max-len))
                   (len     (get-bytevector-n! user-port data 0 max-len)))
-             (write-bytevector data p)
+             (write-bytevector data p len)
              #f))
           ((= k %stderr-next)
            ;; Log a string.  Build logs are usually UTF-8-encoded, but they
@@ -1567,8 +1567,10 @@ must be an absolute store file name, or a derivation file name."
                                         "/log/guix/drvs/"
                                         (string-take base 2) "/"
                                         (string-drop base 2)))
+                (log.gz  (string-append log ".gz"))
                 (log.bz2 (string-append log ".bz2")))
-           (cond ((file-exists? log.bz2) log.bz2)
+           (cond ((file-exists? log.gz) log.gz)
+                 ((file-exists? log.bz2) log.bz2)
                  ((file-exists? log) log)
                  (else #f))))
         (else
diff --git a/guix/ui.scm b/guix/ui.scm
index 6e08a611cd..895179744b 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -623,6 +623,12 @@ directories:~{ ~a~}~%")
                      (location->string (error-location c))
                      (gettext (condition-message c) %gettext-domain))
              (exit 1))
+            ((and (message-condition? c) (fix-hint? c))
+             (format (current-error-port) "~a: error: ~a~%"
+                     (program-name)
+                     (gettext (condition-message c) %gettext-domain))
+             (display-hint (condition-fix-hint c))
+             (exit 1))
             ((message-condition? c)
              ;; Normally '&message' error conditions have an i18n'd message.
              (leave (G_ "~a~%")